🍬 Script_ir_translator.v
Translated OCaml
File generated by coq-of-ocaml
Require Import CoqOfOCaml.CoqOfOCaml.
Require Import CoqOfOCaml.Settings.
Require Import TezosOfOCaml.Environment.V8.
Require TezosOfOCaml.Proto_alpha.Alpha_context.
Require TezosOfOCaml.Proto_alpha.Cache_memory_helpers.
Require TezosOfOCaml.Proto_alpha.Contract_hash.
Require TezosOfOCaml.Proto_alpha.Contract_repr.
Require TezosOfOCaml.Proto_alpha.Dependent_bool.
Require TezosOfOCaml.Proto_alpha.Entrypoint_repr.
Require TezosOfOCaml.Proto_alpha.Gas_limit_repr.
Require TezosOfOCaml.Proto_alpha.Gas_monad.
Require TezosOfOCaml.Proto_alpha.Lazy_storage_kind.
Require TezosOfOCaml.Proto_alpha.Michelson_v1_gas.
Require TezosOfOCaml.Proto_alpha.Michelson_v1_primitives.
Require TezosOfOCaml.Proto_alpha.Saturation_repr.
Require TezosOfOCaml.Proto_alpha.Script_comparable.
Require TezosOfOCaml.Proto_alpha.Script_expr_hash.
Require TezosOfOCaml.Proto_alpha.Script_int.
Require TezosOfOCaml.Proto_alpha.Script_ir_annot.
Require TezosOfOCaml.Proto_alpha.Script_ir_translator_config.
Require TezosOfOCaml.Proto_alpha.Script_ir_unparser.
Require TezosOfOCaml.Proto_alpha.Script_list.
Require TezosOfOCaml.Proto_alpha.Script_map.
Require TezosOfOCaml.Proto_alpha.Script_repr.
Require TezosOfOCaml.Proto_alpha.Script_set.
Require TezosOfOCaml.Proto_alpha.Script_string.
Require TezosOfOCaml.Proto_alpha.Script_tc_context.
Require TezosOfOCaml.Proto_alpha.Script_tc_errors.
Require TezosOfOCaml.Proto_alpha.Script_timestamp.
Require TezosOfOCaml.Proto_alpha.Script_typed_ir.
Require TezosOfOCaml.Proto_alpha.Script_typed_ir_size.
Require TezosOfOCaml.Proto_alpha.Script_typed_ir_size_costs.
Require TezosOfOCaml.Proto_alpha.Ticket_amount.
Require TezosOfOCaml.Proto_alpha.Tx_rollup_l2_address.
Module Typecheck_costs := Michelson_v1_gas.Cost_of.Typechecking.
Module Unparse_costs := Michelson_v1_gas.Cost_of.Unparsing.
Module Tc_context := Script_tc_context.
Definition elab_conf : Set := Script_ir_translator_config.elab_config.
Inductive ex_stack_ty : Set :=
| Ex_stack_ty : Script_typed_ir.stack_ty → ex_stack_ty.
Inductive eq : Set :=
| Eq : eq.
Module cinstr.
Record record : Set := Build {
apply : Script_typed_ir.kinstr → Script_typed_ir.kinstr;
}.
Definition with_apply apply (r : record) :=
Build apply.
End cinstr.
Definition cinstr := cinstr.record.
Module descr.
Record record : Set := Build {
loc : Alpha_context.Script.location;
bef : Script_typed_ir.stack_ty;
aft : Script_typed_ir.stack_ty;
instr : cinstr;
}.
Definition with_loc loc (r : record) :=
Build loc r.(bef) r.(aft) r.(instr).
Definition with_bef bef (r : record) :=
Build r.(loc) bef r.(aft) r.(instr).
Definition with_aft aft (r : record) :=
Build r.(loc) r.(bef) aft r.(instr).
Definition with_instr instr (r : record) :=
Build r.(loc) r.(bef) r.(aft) instr.
End descr.
Definition descr := descr.record.
Definition close_descr (function_parameter : descr) : Script_typed_ir.kdescr :=
let '{|
descr.loc := loc_value;
descr.bef := bef;
descr.aft := aft;
descr.instr := instr
|} := function_parameter in
let kinstr := instr.(cinstr.apply) (Script_typed_ir.IHalt loc_value) in
{| Script_typed_ir.kdescr.kloc := loc_value;
Script_typed_ir.kdescr.kbef := bef; Script_typed_ir.kdescr.kaft := aft;
Script_typed_ir.kdescr.kinstr := kinstr; |}.
Definition compose_descr
(loc_value : Alpha_context.Script.location) (d1 : descr) (d2 : descr)
: descr :=
{| descr.loc := loc_value; descr.bef := d1.(descr.bef);
descr.aft := d2.(descr.aft);
descr.instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
d1.(descr.instr).(cinstr.apply)
(d2.(descr.instr).(cinstr.apply) k_value); |}; |}.
Definition tc_context : Set := Tc_context.t.
Definition location {A B : Set} (function_parameter : Micheline.node A B) : A :=
match function_parameter with
|
(Micheline.Prim loc_value _ _ _ | Micheline.Int loc_value _ |
Micheline.String loc_value _ | Micheline.Bytes loc_value _ |
Micheline.Seq loc_value _) ⇒ loc_value
end.
Definition kind_equal
(a_value : Script_tc_errors.kind) (b_value : Script_tc_errors.kind) : bool :=
match (a_value, b_value) with
|
((Script_tc_errors.Int_kind, Script_tc_errors.Int_kind) |
(Script_tc_errors.String_kind, Script_tc_errors.String_kind) |
(Script_tc_errors.Bytes_kind, Script_tc_errors.Bytes_kind) |
(Script_tc_errors.Prim_kind, Script_tc_errors.Prim_kind) |
(Script_tc_errors.Seq_kind, Script_tc_errors.Seq_kind)) ⇒ true
| _ ⇒ false
end.
Definition kind_value {A B : Set} (function_parameter : Micheline.node A B)
: Script_tc_errors.kind :=
match function_parameter with
| Micheline.Int _ _ ⇒ Script_tc_errors.Int_kind
| Micheline.String _ _ ⇒ Script_tc_errors.String_kind
| Micheline.Bytes _ _ ⇒ Script_tc_errors.Bytes_kind
| Micheline.Prim _ _ _ _ ⇒ Script_tc_errors.Prim_kind
| Micheline.Seq _ _ ⇒ Script_tc_errors.Seq_kind
end.
Definition unexpected
(expr :
Micheline.node Alpha_context.Script.location Michelson_v1_primitives.prim)
(exp_kinds : list Script_tc_errors.kind)
(exp_ns : Michelson_v1_primitives.namespace)
(exp_prims : list Alpha_context.Script.prim) : Error_monad._error :=
match expr with
| Micheline.Int loc_value _ ⇒
Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, (cons Script_tc_errors.Prim_kind exp_kinds),
Script_tc_errors.Int_kind)
| Micheline.String loc_value _ ⇒
Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, (cons Script_tc_errors.Prim_kind exp_kinds),
Script_tc_errors.String_kind)
| Micheline.Bytes loc_value _ ⇒
Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, (cons Script_tc_errors.Prim_kind exp_kinds),
Script_tc_errors.Bytes_kind)
| Micheline.Seq loc_value _ ⇒
Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, (cons Script_tc_errors.Prim_kind exp_kinds),
Script_tc_errors.Seq_kind)
| Micheline.Prim loc_value name _ _ ⇒
match ((Michelson_v1_primitives.namespace_value name), exp_ns) with
|
((Michelson_v1_primitives.Type_namespace,
Michelson_v1_primitives.Type_namespace) |
(Michelson_v1_primitives.Instr_namespace,
Michelson_v1_primitives.Instr_namespace) |
(Michelson_v1_primitives.Constant_namespace,
Michelson_v1_primitives.Constant_namespace)) ⇒
Build_extensible "Invalid_primitive"
(Alpha_context.Script.location × list Alpha_context.Script.prim ×
Michelson_v1_primitives.prim) (loc_value, exp_prims, name)
| (ns, _) ⇒
Build_extensible "Invalid_namespace"
(Alpha_context.Script.location × Michelson_v1_primitives.prim ×
Michelson_v1_primitives.namespace × Michelson_v1_primitives.namespace)
(loc_value, name, exp_ns, ns)
end
end.
Definition check_kind {A : Set}
(kinds : list Script_tc_errors.kind)
(expr : Micheline.node Alpha_context.Script.location A) : M? unit :=
let kind_value := kind_value expr in
if List._exists (kind_equal kind_value) kinds then
Result.return_unit
else
let loc_value := location expr in
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind) (loc_value, kinds, kind_value)).
Definition check_comparable
(loc_value : Alpha_context.Script.location) (ty_value : Script_typed_ir.ty)
: M? eq :=
match Script_typed_ir.is_comparable ty_value with
| Dependent_bool.Yes ⇒ return? Eq
| Dependent_bool.No ⇒
let t_value := Script_ir_unparser.serialize_ty_for_error ty_value in
Error_monad.error_value
(Build_extensible "Comparable_type_expected"
(Alpha_context.Script.location × Alpha_context.Script.expr)
(loc_value, t_value))
end.
Definition pack_node {A : Set} (unparsed : Alpha_context.Script.expr) (ctxt : A)
: bytes × A :=
let bytes_value :=
Data_encoding.Binary.to_bytes_exn None
(Data_encoding.tup2 (Data_encoding.Fixed.string_value 1)
Alpha_context.Script.expr_encoding) ((String.String "005" ""), unparsed)
in
(bytes_value, ctxt).
Definition pack_comparable_data {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.comparable_ty)
(data : A) : M? (bytes × Alpha_context.context) :=
let? '(unparsed, ctxt) :=
Script_ir_unparser.unparse_comparable_data ctxt
Script_ir_unparser.Optimized_legacy ty_value data in
return? (pack_node unparsed ctxt).
Definition hash_bytes (ctxt : Alpha_context.context) (bytes_value : bytes)
: M? (Script_expr_hash.t × Alpha_context.context) :=
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.blake2b bytes_value) in
return? ((Script_expr_hash.hash_bytes None [ bytes_value ]), ctxt).
Definition hash_comparable_data {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.comparable_ty)
(data : A) : M? (Script_expr_hash.t × Alpha_context.context) :=
let? '(bytes_value, ctxt) := pack_comparable_data ctxt ty_value data in
hash_bytes ctxt bytes_value.
Definition check_dupable_comparable_ty
(function_parameter : Script_typed_ir.comparable_ty) : unit :=
match function_parameter with
|
(Script_typed_ir.Unit_t | Script_typed_ir.Never_t | Script_typed_ir.Int_t |
Script_typed_ir.Nat_t | Script_typed_ir.Signature_t |
Script_typed_ir.String_t | Script_typed_ir.Bytes_t | Script_typed_ir.Mutez_t
| Script_typed_ir.Bool_t | Script_typed_ir.Key_hash_t |
Script_typed_ir.Key_t | Script_typed_ir.Timestamp_t |
Script_typed_ir.Chain_id_t | Script_typed_ir.Address_t |
Script_typed_ir.Tx_rollup_l2_address_t | Script_typed_ir.Pair_t _ _ _ _ |
Script_typed_ir.Union_t _ _ _ _ | Script_typed_ir.Option_t _ _ _) ⇒ tt
| _ ⇒ unreachable_gadt_branch
end.
Definition check_dupable_ty
(ctxt : Alpha_context.context) (loc_value : Alpha_context.Script.location)
(ty_value : Script_typed_ir.ty) : M? Alpha_context.context :=
let fix aux
(loc_value : Alpha_context.Script.location) (ty_value : Script_typed_ir.ty)
: Gas_monad.t unit Error_monad._error :=
Gas_monad.Syntax.op_letstar
(Gas_monad.consume_gas Typecheck_costs.check_dupable_cycle)
(fun function_parameter ⇒
let '_ := function_parameter in
match ty_value with
| Script_typed_ir.Unit_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Int_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Nat_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Signature_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.String_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Bytes_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Mutez_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Key_hash_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Key_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Timestamp_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Address_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Tx_rollup_l2_address_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Bool_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Contract_t _ _ ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Operation_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Chain_id_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Never_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Bls12_381_g1_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Bls12_381_g2_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Bls12_381_fr_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Sapling_state_t _ ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Sapling_transaction_t _ ⇒
Gas_monad.Syntax.return_unit
| Script_typed_ir.Sapling_transaction_deprecated_t _ ⇒
Gas_monad.Syntax.return_unit
| Script_typed_ir.Chest_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Chest_key_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Ticket_t _ _ ⇒
Gas_monad.Syntax.fail
(Build_extensible "Unexpected_ticket" Alpha_context.Script.location
loc_value)
| Script_typed_ir.Pair_t ty_a ty_b _ _ ⇒
Gas_monad.Syntax.op_letstar (aux loc_value ty_a)
(fun function_parameter ⇒
let '_ := function_parameter in
aux loc_value ty_b)
| Script_typed_ir.Union_t ty_a ty_b _ _ ⇒
Gas_monad.Syntax.op_letstar (aux loc_value ty_a)
(fun function_parameter ⇒
let '_ := function_parameter in
aux loc_value ty_b)
| Script_typed_ir.Lambda_t _ _ _ ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Option_t ty_value _ _ ⇒ aux loc_value ty_value
| Script_typed_ir.List_t ty_value _ ⇒ aux loc_value ty_value
| Script_typed_ir.Set_t key_ty _ ⇒
let '_ := check_dupable_comparable_ty key_ty in
Gas_monad.Syntax.return_unit
| Script_typed_ir.Map_t key_ty val_ty _ ⇒
let '_ := check_dupable_comparable_ty key_ty in
aux loc_value val_ty
| Script_typed_ir.Big_map_t key_ty val_ty _ ⇒
let '_ := check_dupable_comparable_ty key_ty in
aux loc_value val_ty
end) in
let gas := aux loc_value ty_value in
let? '(res, ctxt) := Gas_monad.run ctxt gas in
match res with
| Pervasives.Ok _ ⇒ return? ctxt
| Pervasives.Error e_value ⇒ Error_monad.error_value e_value
end.
Definition type_metadata_eq {A error_trace : Set}
(error_details : Script_tc_errors.error_details A)
(function_parameter : Script_typed_ir.ty_metadata)
: Script_typed_ir.ty_metadata → Pervasives.result unit error_trace :=
let '{| Script_typed_ir.ty_metadata.size := size_a |} := function_parameter in
fun (function_parameter : Script_typed_ir.ty_metadata) ⇒
let '{| Script_typed_ir.ty_metadata.size := size_b |} := function_parameter
in
Script_typed_ir.Type_size.check_eq error_details size_a size_b.
Definition default_ty_eq_error
(loc_value : Alpha_context.Script.location) (ty1 : Script_typed_ir.ty)
(ty2 : Script_typed_ir.ty) : Error_monad._error :=
let ty1 := Script_ir_unparser.serialize_ty_for_error ty1 in
let ty2 := Script_ir_unparser.serialize_ty_for_error ty2 in
Build_extensible "Inconsistent_types"
(Alpha_context.Script.location × Alpha_context.Script.expr ×
Alpha_context.Script.expr) (loc_value, ty1, ty2).
Definition memo_size_eq {A error_trace : Set}
(error_details : Script_tc_errors.error_details A)
(ms1 : Alpha_context.Sapling.Memo_size.t)
(ms2 : Alpha_context.Sapling.Memo_size.t)
: Pervasives.result unit error_trace :=
if Alpha_context.Sapling.Memo_size.equal ms1 ms2 then
Result.return_unit
else
Pervasives.Error
match error_details with
| Script_tc_errors.Fast ⇒
cast error_trace Script_tc_errors.Inconsistent_types_fast
| Script_tc_errors.Informative _ ⇒
cast error_trace
(Error_monad.trace_of_error
(Build_extensible "Inconsistent_memo_sizes"
(Alpha_context.Sapling.Memo_size.t ×
Alpha_context.Sapling.Memo_size.t) (ms1, ms2)))
end.
Fixpoint ty_eq {error_trace : Set}
(error_details : Script_tc_errors.error_details Alpha_context.Script.location)
(ty1 : Script_typed_ir.ty) (ty2 : Script_typed_ir.ty)
: Gas_monad.t eq error_trace :=
let type_metadata_eq
(meta1 : Script_typed_ir.ty_metadata) (meta2 : Script_typed_ir.ty_metadata)
: Gas_monad.t unit error_trace :=
Gas_monad.record_trace_eval error_details
(fun (loc_value : Alpha_context.Script.location) ⇒
default_ty_eq_error loc_value ty1 ty2)
(Gas_monad.of_result (type_metadata_eq error_details meta1 meta2)) in
let memo_size_eq
(ms1 : Alpha_context.Sapling.Memo_size.t)
(ms2 : Alpha_context.Sapling.Memo_size.t) : Gas_monad.t unit error_trace :=
Gas_monad.of_result (memo_size_eq error_details ms1 ms2) in
let fix help (ty1 : Script_typed_ir.ty) (ty2 : Script_typed_ir.ty)
: Gas_monad.t eq error_trace :=
Gas_monad.Syntax.op_letstar
(Gas_monad.consume_gas Typecheck_costs.merge_cycle)
(fun function_parameter ⇒
let '_ := function_parameter in
let not_equal {B : Set} (function_parameter : unit)
: Gas_monad.t B error_trace :=
let '_ := function_parameter in
Gas_monad.of_result
(Pervasives.Error
match error_details with
| Script_tc_errors.Fast ⇒
cast error_trace Script_tc_errors.Inconsistent_types_fast
| Script_tc_errors.Informative loc_value ⇒
let loc_value := cast Alpha_context.Script.location loc_value in
cast error_trace
(Error_monad.trace_of_error
(default_ty_eq_error loc_value ty1 ty2))
end) in
Gas_monad.record_trace_eval error_details
(fun (loc_value : Alpha_context.Script.location) ⇒
default_ty_eq_error loc_value ty1 ty2)
match (ty1, ty2) with
| (Script_typed_ir.Unit_t, Script_typed_ir.Unit_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Unit_t, _) ⇒ not_equal tt
| (Script_typed_ir.Int_t, Script_typed_ir.Int_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Int_t, _) ⇒ not_equal tt
| (Script_typed_ir.Nat_t, Script_typed_ir.Nat_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Nat_t, _) ⇒ not_equal tt
| (Script_typed_ir.Key_t, Script_typed_ir.Key_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Key_t, _) ⇒ not_equal tt
| (Script_typed_ir.Key_hash_t, Script_typed_ir.Key_hash_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Key_hash_t, _) ⇒ not_equal tt
| (Script_typed_ir.String_t, Script_typed_ir.String_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.String_t, _) ⇒ not_equal tt
| (Script_typed_ir.Bytes_t, Script_typed_ir.Bytes_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Bytes_t, _) ⇒ not_equal tt
| (Script_typed_ir.Signature_t, Script_typed_ir.Signature_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Signature_t, _) ⇒ not_equal tt
| (Script_typed_ir.Mutez_t, Script_typed_ir.Mutez_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Mutez_t, _) ⇒ not_equal tt
| (Script_typed_ir.Timestamp_t, Script_typed_ir.Timestamp_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Timestamp_t, _) ⇒ not_equal tt
| (Script_typed_ir.Address_t, Script_typed_ir.Address_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Address_t, _) ⇒ not_equal tt
|
(Script_typed_ir.Tx_rollup_l2_address_t,
Script_typed_ir.Tx_rollup_l2_address_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Tx_rollup_l2_address_t, _) ⇒ not_equal tt
| (Script_typed_ir.Bool_t, Script_typed_ir.Bool_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Bool_t, _) ⇒ not_equal tt
| (Script_typed_ir.Chain_id_t, Script_typed_ir.Chain_id_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Chain_id_t, _) ⇒ not_equal tt
| (Script_typed_ir.Never_t, Script_typed_ir.Never_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Never_t, _) ⇒ not_equal tt
| (Script_typed_ir.Operation_t, Script_typed_ir.Operation_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Operation_t, _) ⇒ not_equal tt
| (Script_typed_ir.Bls12_381_g1_t, Script_typed_ir.Bls12_381_g1_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Bls12_381_g1_t, _) ⇒ not_equal tt
| (Script_typed_ir.Bls12_381_g2_t, Script_typed_ir.Bls12_381_g2_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Bls12_381_g2_t, _) ⇒ not_equal tt
| (Script_typed_ir.Bls12_381_fr_t, Script_typed_ir.Bls12_381_fr_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Bls12_381_fr_t, _) ⇒ not_equal tt
|
(Script_typed_ir.Map_t tal tar meta1,
Script_typed_ir.Map_t tbl tbr meta2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letstar (help tar tbr)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Gas_monad.Syntax.op_letplus (ty_eq error_details tal tbl)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq)))
| (Script_typed_ir.Map_t _ _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Big_map_t tal tar meta1,
Script_typed_ir.Big_map_t tbl tbr meta2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letstar (help tar tbr)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Gas_monad.Syntax.op_letplus (ty_eq error_details tal tbl)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq)))
| (Script_typed_ir.Big_map_t _ _ _, _) ⇒ not_equal tt
| (Script_typed_ir.Set_t ea meta1, Script_typed_ir.Set_t eb meta2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letplus (ty_eq error_details ea eb)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq))
| (Script_typed_ir.Set_t _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Ticket_t ea meta1,
Script_typed_ir.Ticket_t eb meta2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letplus (ty_eq error_details ea eb)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq))
| (Script_typed_ir.Ticket_t _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Pair_t tal tar meta1 cmp1,
Script_typed_ir.Pair_t tbl tbr meta2 cmp2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letstar (help tal tbl)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Gas_monad.Syntax.op_letplus (help tar tbr)
(fun function_parameter ⇒
let 'Eq := function_parameter in
let 'Dependent_bool.Eq :=
Dependent_bool.merge_dand cmp1 cmp2 in
Eq)))
| (Script_typed_ir.Pair_t _ _ _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Union_t tal tar meta1 cmp1,
Script_typed_ir.Union_t tbl tbr meta2 cmp2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letstar (help tal tbl)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Gas_monad.Syntax.op_letplus (help tar tbr)
(fun function_parameter ⇒
let 'Eq := function_parameter in
let 'Dependent_bool.Eq :=
Dependent_bool.merge_dand cmp1 cmp2 in
Eq)))
| (Script_typed_ir.Union_t _ _ _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Lambda_t tal tar meta1,
Script_typed_ir.Lambda_t tbl tbr meta2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letstar (help tal tbl)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Gas_monad.Syntax.op_letplus (help tar tbr)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq)))
| (Script_typed_ir.Lambda_t _ _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Contract_t tal meta1,
Script_typed_ir.Contract_t tbl meta2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letplus (help tal tbl)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq))
| (Script_typed_ir.Contract_t _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Option_t tva meta1 _,
Script_typed_ir.Option_t tvb meta2 _) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letplus (help tva tvb)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq))
| (Script_typed_ir.Option_t _ _ _, _) ⇒ not_equal tt
| (Script_typed_ir.List_t tva meta1, Script_typed_ir.List_t tvb meta2)
⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letplus (help tva tvb)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq))
| (Script_typed_ir.List_t _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Sapling_state_t ms1,
Script_typed_ir.Sapling_state_t ms2) ⇒
Gas_monad.Syntax.op_letplus (memo_size_eq ms1 ms2)
(fun function_parameter ⇒
let '_ := function_parameter in
Eq)
| (Script_typed_ir.Sapling_state_t _, _) ⇒ not_equal tt
|
(Script_typed_ir.Sapling_transaction_t ms1,
Script_typed_ir.Sapling_transaction_t ms2) ⇒
Gas_monad.Syntax.op_letplus (memo_size_eq ms1 ms2)
(fun function_parameter ⇒
let '_ := function_parameter in
Eq)
| (Script_typed_ir.Sapling_transaction_t _, _) ⇒ not_equal tt
|
(Script_typed_ir.Sapling_transaction_deprecated_t ms1,
Script_typed_ir.Sapling_transaction_deprecated_t ms2) ⇒
Gas_monad.Syntax.op_letplus (memo_size_eq ms1 ms2)
(fun function_parameter ⇒
let '_ := function_parameter in
Eq)
| (Script_typed_ir.Sapling_transaction_deprecated_t _, _) ⇒
not_equal tt
| (Script_typed_ir.Chest_t, Script_typed_ir.Chest_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Chest_t, _) ⇒ not_equal tt
| (Script_typed_ir.Chest_key_t, Script_typed_ir.Chest_key_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Chest_key_t, _) ⇒ not_equal tt
end) in
Gas_monad.record_trace_eval error_details
(fun (loc_value : Alpha_context.Script.location) ⇒
default_ty_eq_error loc_value ty1 ty2) (help ty1 ty2).
Fixpoint stack_eq
(loc_value : Alpha_context.Script.location) (ctxt : Alpha_context.context)
(lvl : int) (stack1 : Script_typed_ir.stack_ty)
(stack2 : Script_typed_ir.stack_ty) : M? (eq × Alpha_context.context) :=
match (stack1, stack2) with
| (Script_typed_ir.Bot_t, Script_typed_ir.Bot_t) ⇒ return? (Eq, ctxt)
| (Script_typed_ir.Item_t ty1 rest1, Script_typed_ir.Item_t ty2 rest2) ⇒
let? '(eq_value, ctxt) :=
Error_monad.record_trace (Build_extensible "Bad_stack_item" int lvl)
(Gas_monad.run ctxt
(ty_eq (Script_tc_errors.Informative loc_value) ty1 ty2)) in
let? 'Eq := eq_value in
let? '(Eq, ctxt) := stack_eq loc_value ctxt (lvl +i 1) rest1 rest2 in
return? (Eq, ctxt)
| (_, _) ⇒
Error_monad.error_value (Build_extensible "Bad_stack_length" unit tt)
end.
Require Import CoqOfOCaml.Settings.
Require Import TezosOfOCaml.Environment.V8.
Require TezosOfOCaml.Proto_alpha.Alpha_context.
Require TezosOfOCaml.Proto_alpha.Cache_memory_helpers.
Require TezosOfOCaml.Proto_alpha.Contract_hash.
Require TezosOfOCaml.Proto_alpha.Contract_repr.
Require TezosOfOCaml.Proto_alpha.Dependent_bool.
Require TezosOfOCaml.Proto_alpha.Entrypoint_repr.
Require TezosOfOCaml.Proto_alpha.Gas_limit_repr.
Require TezosOfOCaml.Proto_alpha.Gas_monad.
Require TezosOfOCaml.Proto_alpha.Lazy_storage_kind.
Require TezosOfOCaml.Proto_alpha.Michelson_v1_gas.
Require TezosOfOCaml.Proto_alpha.Michelson_v1_primitives.
Require TezosOfOCaml.Proto_alpha.Saturation_repr.
Require TezosOfOCaml.Proto_alpha.Script_comparable.
Require TezosOfOCaml.Proto_alpha.Script_expr_hash.
Require TezosOfOCaml.Proto_alpha.Script_int.
Require TezosOfOCaml.Proto_alpha.Script_ir_annot.
Require TezosOfOCaml.Proto_alpha.Script_ir_translator_config.
Require TezosOfOCaml.Proto_alpha.Script_ir_unparser.
Require TezosOfOCaml.Proto_alpha.Script_list.
Require TezosOfOCaml.Proto_alpha.Script_map.
Require TezosOfOCaml.Proto_alpha.Script_repr.
Require TezosOfOCaml.Proto_alpha.Script_set.
Require TezosOfOCaml.Proto_alpha.Script_string.
Require TezosOfOCaml.Proto_alpha.Script_tc_context.
Require TezosOfOCaml.Proto_alpha.Script_tc_errors.
Require TezosOfOCaml.Proto_alpha.Script_timestamp.
Require TezosOfOCaml.Proto_alpha.Script_typed_ir.
Require TezosOfOCaml.Proto_alpha.Script_typed_ir_size.
Require TezosOfOCaml.Proto_alpha.Script_typed_ir_size_costs.
Require TezosOfOCaml.Proto_alpha.Ticket_amount.
Require TezosOfOCaml.Proto_alpha.Tx_rollup_l2_address.
Module Typecheck_costs := Michelson_v1_gas.Cost_of.Typechecking.
Module Unparse_costs := Michelson_v1_gas.Cost_of.Unparsing.
Module Tc_context := Script_tc_context.
Definition elab_conf : Set := Script_ir_translator_config.elab_config.
Inductive ex_stack_ty : Set :=
| Ex_stack_ty : Script_typed_ir.stack_ty → ex_stack_ty.
Inductive eq : Set :=
| Eq : eq.
Module cinstr.
Record record : Set := Build {
apply : Script_typed_ir.kinstr → Script_typed_ir.kinstr;
}.
Definition with_apply apply (r : record) :=
Build apply.
End cinstr.
Definition cinstr := cinstr.record.
Module descr.
Record record : Set := Build {
loc : Alpha_context.Script.location;
bef : Script_typed_ir.stack_ty;
aft : Script_typed_ir.stack_ty;
instr : cinstr;
}.
Definition with_loc loc (r : record) :=
Build loc r.(bef) r.(aft) r.(instr).
Definition with_bef bef (r : record) :=
Build r.(loc) bef r.(aft) r.(instr).
Definition with_aft aft (r : record) :=
Build r.(loc) r.(bef) aft r.(instr).
Definition with_instr instr (r : record) :=
Build r.(loc) r.(bef) r.(aft) instr.
End descr.
Definition descr := descr.record.
Definition close_descr (function_parameter : descr) : Script_typed_ir.kdescr :=
let '{|
descr.loc := loc_value;
descr.bef := bef;
descr.aft := aft;
descr.instr := instr
|} := function_parameter in
let kinstr := instr.(cinstr.apply) (Script_typed_ir.IHalt loc_value) in
{| Script_typed_ir.kdescr.kloc := loc_value;
Script_typed_ir.kdescr.kbef := bef; Script_typed_ir.kdescr.kaft := aft;
Script_typed_ir.kdescr.kinstr := kinstr; |}.
Definition compose_descr
(loc_value : Alpha_context.Script.location) (d1 : descr) (d2 : descr)
: descr :=
{| descr.loc := loc_value; descr.bef := d1.(descr.bef);
descr.aft := d2.(descr.aft);
descr.instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
d1.(descr.instr).(cinstr.apply)
(d2.(descr.instr).(cinstr.apply) k_value); |}; |}.
Definition tc_context : Set := Tc_context.t.
Definition location {A B : Set} (function_parameter : Micheline.node A B) : A :=
match function_parameter with
|
(Micheline.Prim loc_value _ _ _ | Micheline.Int loc_value _ |
Micheline.String loc_value _ | Micheline.Bytes loc_value _ |
Micheline.Seq loc_value _) ⇒ loc_value
end.
Definition kind_equal
(a_value : Script_tc_errors.kind) (b_value : Script_tc_errors.kind) : bool :=
match (a_value, b_value) with
|
((Script_tc_errors.Int_kind, Script_tc_errors.Int_kind) |
(Script_tc_errors.String_kind, Script_tc_errors.String_kind) |
(Script_tc_errors.Bytes_kind, Script_tc_errors.Bytes_kind) |
(Script_tc_errors.Prim_kind, Script_tc_errors.Prim_kind) |
(Script_tc_errors.Seq_kind, Script_tc_errors.Seq_kind)) ⇒ true
| _ ⇒ false
end.
Definition kind_value {A B : Set} (function_parameter : Micheline.node A B)
: Script_tc_errors.kind :=
match function_parameter with
| Micheline.Int _ _ ⇒ Script_tc_errors.Int_kind
| Micheline.String _ _ ⇒ Script_tc_errors.String_kind
| Micheline.Bytes _ _ ⇒ Script_tc_errors.Bytes_kind
| Micheline.Prim _ _ _ _ ⇒ Script_tc_errors.Prim_kind
| Micheline.Seq _ _ ⇒ Script_tc_errors.Seq_kind
end.
Definition unexpected
(expr :
Micheline.node Alpha_context.Script.location Michelson_v1_primitives.prim)
(exp_kinds : list Script_tc_errors.kind)
(exp_ns : Michelson_v1_primitives.namespace)
(exp_prims : list Alpha_context.Script.prim) : Error_monad._error :=
match expr with
| Micheline.Int loc_value _ ⇒
Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, (cons Script_tc_errors.Prim_kind exp_kinds),
Script_tc_errors.Int_kind)
| Micheline.String loc_value _ ⇒
Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, (cons Script_tc_errors.Prim_kind exp_kinds),
Script_tc_errors.String_kind)
| Micheline.Bytes loc_value _ ⇒
Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, (cons Script_tc_errors.Prim_kind exp_kinds),
Script_tc_errors.Bytes_kind)
| Micheline.Seq loc_value _ ⇒
Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, (cons Script_tc_errors.Prim_kind exp_kinds),
Script_tc_errors.Seq_kind)
| Micheline.Prim loc_value name _ _ ⇒
match ((Michelson_v1_primitives.namespace_value name), exp_ns) with
|
((Michelson_v1_primitives.Type_namespace,
Michelson_v1_primitives.Type_namespace) |
(Michelson_v1_primitives.Instr_namespace,
Michelson_v1_primitives.Instr_namespace) |
(Michelson_v1_primitives.Constant_namespace,
Michelson_v1_primitives.Constant_namespace)) ⇒
Build_extensible "Invalid_primitive"
(Alpha_context.Script.location × list Alpha_context.Script.prim ×
Michelson_v1_primitives.prim) (loc_value, exp_prims, name)
| (ns, _) ⇒
Build_extensible "Invalid_namespace"
(Alpha_context.Script.location × Michelson_v1_primitives.prim ×
Michelson_v1_primitives.namespace × Michelson_v1_primitives.namespace)
(loc_value, name, exp_ns, ns)
end
end.
Definition check_kind {A : Set}
(kinds : list Script_tc_errors.kind)
(expr : Micheline.node Alpha_context.Script.location A) : M? unit :=
let kind_value := kind_value expr in
if List._exists (kind_equal kind_value) kinds then
Result.return_unit
else
let loc_value := location expr in
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind) (loc_value, kinds, kind_value)).
Definition check_comparable
(loc_value : Alpha_context.Script.location) (ty_value : Script_typed_ir.ty)
: M? eq :=
match Script_typed_ir.is_comparable ty_value with
| Dependent_bool.Yes ⇒ return? Eq
| Dependent_bool.No ⇒
let t_value := Script_ir_unparser.serialize_ty_for_error ty_value in
Error_monad.error_value
(Build_extensible "Comparable_type_expected"
(Alpha_context.Script.location × Alpha_context.Script.expr)
(loc_value, t_value))
end.
Definition pack_node {A : Set} (unparsed : Alpha_context.Script.expr) (ctxt : A)
: bytes × A :=
let bytes_value :=
Data_encoding.Binary.to_bytes_exn None
(Data_encoding.tup2 (Data_encoding.Fixed.string_value 1)
Alpha_context.Script.expr_encoding) ((String.String "005" ""), unparsed)
in
(bytes_value, ctxt).
Definition pack_comparable_data {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.comparable_ty)
(data : A) : M? (bytes × Alpha_context.context) :=
let? '(unparsed, ctxt) :=
Script_ir_unparser.unparse_comparable_data ctxt
Script_ir_unparser.Optimized_legacy ty_value data in
return? (pack_node unparsed ctxt).
Definition hash_bytes (ctxt : Alpha_context.context) (bytes_value : bytes)
: M? (Script_expr_hash.t × Alpha_context.context) :=
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.blake2b bytes_value) in
return? ((Script_expr_hash.hash_bytes None [ bytes_value ]), ctxt).
Definition hash_comparable_data {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.comparable_ty)
(data : A) : M? (Script_expr_hash.t × Alpha_context.context) :=
let? '(bytes_value, ctxt) := pack_comparable_data ctxt ty_value data in
hash_bytes ctxt bytes_value.
Definition check_dupable_comparable_ty
(function_parameter : Script_typed_ir.comparable_ty) : unit :=
match function_parameter with
|
(Script_typed_ir.Unit_t | Script_typed_ir.Never_t | Script_typed_ir.Int_t |
Script_typed_ir.Nat_t | Script_typed_ir.Signature_t |
Script_typed_ir.String_t | Script_typed_ir.Bytes_t | Script_typed_ir.Mutez_t
| Script_typed_ir.Bool_t | Script_typed_ir.Key_hash_t |
Script_typed_ir.Key_t | Script_typed_ir.Timestamp_t |
Script_typed_ir.Chain_id_t | Script_typed_ir.Address_t |
Script_typed_ir.Tx_rollup_l2_address_t | Script_typed_ir.Pair_t _ _ _ _ |
Script_typed_ir.Union_t _ _ _ _ | Script_typed_ir.Option_t _ _ _) ⇒ tt
| _ ⇒ unreachable_gadt_branch
end.
Definition check_dupable_ty
(ctxt : Alpha_context.context) (loc_value : Alpha_context.Script.location)
(ty_value : Script_typed_ir.ty) : M? Alpha_context.context :=
let fix aux
(loc_value : Alpha_context.Script.location) (ty_value : Script_typed_ir.ty)
: Gas_monad.t unit Error_monad._error :=
Gas_monad.Syntax.op_letstar
(Gas_monad.consume_gas Typecheck_costs.check_dupable_cycle)
(fun function_parameter ⇒
let '_ := function_parameter in
match ty_value with
| Script_typed_ir.Unit_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Int_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Nat_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Signature_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.String_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Bytes_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Mutez_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Key_hash_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Key_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Timestamp_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Address_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Tx_rollup_l2_address_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Bool_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Contract_t _ _ ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Operation_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Chain_id_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Never_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Bls12_381_g1_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Bls12_381_g2_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Bls12_381_fr_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Sapling_state_t _ ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Sapling_transaction_t _ ⇒
Gas_monad.Syntax.return_unit
| Script_typed_ir.Sapling_transaction_deprecated_t _ ⇒
Gas_monad.Syntax.return_unit
| Script_typed_ir.Chest_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Chest_key_t ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Ticket_t _ _ ⇒
Gas_monad.Syntax.fail
(Build_extensible "Unexpected_ticket" Alpha_context.Script.location
loc_value)
| Script_typed_ir.Pair_t ty_a ty_b _ _ ⇒
Gas_monad.Syntax.op_letstar (aux loc_value ty_a)
(fun function_parameter ⇒
let '_ := function_parameter in
aux loc_value ty_b)
| Script_typed_ir.Union_t ty_a ty_b _ _ ⇒
Gas_monad.Syntax.op_letstar (aux loc_value ty_a)
(fun function_parameter ⇒
let '_ := function_parameter in
aux loc_value ty_b)
| Script_typed_ir.Lambda_t _ _ _ ⇒ Gas_monad.Syntax.return_unit
| Script_typed_ir.Option_t ty_value _ _ ⇒ aux loc_value ty_value
| Script_typed_ir.List_t ty_value _ ⇒ aux loc_value ty_value
| Script_typed_ir.Set_t key_ty _ ⇒
let '_ := check_dupable_comparable_ty key_ty in
Gas_monad.Syntax.return_unit
| Script_typed_ir.Map_t key_ty val_ty _ ⇒
let '_ := check_dupable_comparable_ty key_ty in
aux loc_value val_ty
| Script_typed_ir.Big_map_t key_ty val_ty _ ⇒
let '_ := check_dupable_comparable_ty key_ty in
aux loc_value val_ty
end) in
let gas := aux loc_value ty_value in
let? '(res, ctxt) := Gas_monad.run ctxt gas in
match res with
| Pervasives.Ok _ ⇒ return? ctxt
| Pervasives.Error e_value ⇒ Error_monad.error_value e_value
end.
Definition type_metadata_eq {A error_trace : Set}
(error_details : Script_tc_errors.error_details A)
(function_parameter : Script_typed_ir.ty_metadata)
: Script_typed_ir.ty_metadata → Pervasives.result unit error_trace :=
let '{| Script_typed_ir.ty_metadata.size := size_a |} := function_parameter in
fun (function_parameter : Script_typed_ir.ty_metadata) ⇒
let '{| Script_typed_ir.ty_metadata.size := size_b |} := function_parameter
in
Script_typed_ir.Type_size.check_eq error_details size_a size_b.
Definition default_ty_eq_error
(loc_value : Alpha_context.Script.location) (ty1 : Script_typed_ir.ty)
(ty2 : Script_typed_ir.ty) : Error_monad._error :=
let ty1 := Script_ir_unparser.serialize_ty_for_error ty1 in
let ty2 := Script_ir_unparser.serialize_ty_for_error ty2 in
Build_extensible "Inconsistent_types"
(Alpha_context.Script.location × Alpha_context.Script.expr ×
Alpha_context.Script.expr) (loc_value, ty1, ty2).
Definition memo_size_eq {A error_trace : Set}
(error_details : Script_tc_errors.error_details A)
(ms1 : Alpha_context.Sapling.Memo_size.t)
(ms2 : Alpha_context.Sapling.Memo_size.t)
: Pervasives.result unit error_trace :=
if Alpha_context.Sapling.Memo_size.equal ms1 ms2 then
Result.return_unit
else
Pervasives.Error
match error_details with
| Script_tc_errors.Fast ⇒
cast error_trace Script_tc_errors.Inconsistent_types_fast
| Script_tc_errors.Informative _ ⇒
cast error_trace
(Error_monad.trace_of_error
(Build_extensible "Inconsistent_memo_sizes"
(Alpha_context.Sapling.Memo_size.t ×
Alpha_context.Sapling.Memo_size.t) (ms1, ms2)))
end.
Fixpoint ty_eq {error_trace : Set}
(error_details : Script_tc_errors.error_details Alpha_context.Script.location)
(ty1 : Script_typed_ir.ty) (ty2 : Script_typed_ir.ty)
: Gas_monad.t eq error_trace :=
let type_metadata_eq
(meta1 : Script_typed_ir.ty_metadata) (meta2 : Script_typed_ir.ty_metadata)
: Gas_monad.t unit error_trace :=
Gas_monad.record_trace_eval error_details
(fun (loc_value : Alpha_context.Script.location) ⇒
default_ty_eq_error loc_value ty1 ty2)
(Gas_monad.of_result (type_metadata_eq error_details meta1 meta2)) in
let memo_size_eq
(ms1 : Alpha_context.Sapling.Memo_size.t)
(ms2 : Alpha_context.Sapling.Memo_size.t) : Gas_monad.t unit error_trace :=
Gas_monad.of_result (memo_size_eq error_details ms1 ms2) in
let fix help (ty1 : Script_typed_ir.ty) (ty2 : Script_typed_ir.ty)
: Gas_monad.t eq error_trace :=
Gas_monad.Syntax.op_letstar
(Gas_monad.consume_gas Typecheck_costs.merge_cycle)
(fun function_parameter ⇒
let '_ := function_parameter in
let not_equal {B : Set} (function_parameter : unit)
: Gas_monad.t B error_trace :=
let '_ := function_parameter in
Gas_monad.of_result
(Pervasives.Error
match error_details with
| Script_tc_errors.Fast ⇒
cast error_trace Script_tc_errors.Inconsistent_types_fast
| Script_tc_errors.Informative loc_value ⇒
let loc_value := cast Alpha_context.Script.location loc_value in
cast error_trace
(Error_monad.trace_of_error
(default_ty_eq_error loc_value ty1 ty2))
end) in
Gas_monad.record_trace_eval error_details
(fun (loc_value : Alpha_context.Script.location) ⇒
default_ty_eq_error loc_value ty1 ty2)
match (ty1, ty2) with
| (Script_typed_ir.Unit_t, Script_typed_ir.Unit_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Unit_t, _) ⇒ not_equal tt
| (Script_typed_ir.Int_t, Script_typed_ir.Int_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Int_t, _) ⇒ not_equal tt
| (Script_typed_ir.Nat_t, Script_typed_ir.Nat_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Nat_t, _) ⇒ not_equal tt
| (Script_typed_ir.Key_t, Script_typed_ir.Key_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Key_t, _) ⇒ not_equal tt
| (Script_typed_ir.Key_hash_t, Script_typed_ir.Key_hash_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Key_hash_t, _) ⇒ not_equal tt
| (Script_typed_ir.String_t, Script_typed_ir.String_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.String_t, _) ⇒ not_equal tt
| (Script_typed_ir.Bytes_t, Script_typed_ir.Bytes_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Bytes_t, _) ⇒ not_equal tt
| (Script_typed_ir.Signature_t, Script_typed_ir.Signature_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Signature_t, _) ⇒ not_equal tt
| (Script_typed_ir.Mutez_t, Script_typed_ir.Mutez_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Mutez_t, _) ⇒ not_equal tt
| (Script_typed_ir.Timestamp_t, Script_typed_ir.Timestamp_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Timestamp_t, _) ⇒ not_equal tt
| (Script_typed_ir.Address_t, Script_typed_ir.Address_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Address_t, _) ⇒ not_equal tt
|
(Script_typed_ir.Tx_rollup_l2_address_t,
Script_typed_ir.Tx_rollup_l2_address_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Tx_rollup_l2_address_t, _) ⇒ not_equal tt
| (Script_typed_ir.Bool_t, Script_typed_ir.Bool_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Bool_t, _) ⇒ not_equal tt
| (Script_typed_ir.Chain_id_t, Script_typed_ir.Chain_id_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Chain_id_t, _) ⇒ not_equal tt
| (Script_typed_ir.Never_t, Script_typed_ir.Never_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Never_t, _) ⇒ not_equal tt
| (Script_typed_ir.Operation_t, Script_typed_ir.Operation_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Operation_t, _) ⇒ not_equal tt
| (Script_typed_ir.Bls12_381_g1_t, Script_typed_ir.Bls12_381_g1_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Bls12_381_g1_t, _) ⇒ not_equal tt
| (Script_typed_ir.Bls12_381_g2_t, Script_typed_ir.Bls12_381_g2_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Bls12_381_g2_t, _) ⇒ not_equal tt
| (Script_typed_ir.Bls12_381_fr_t, Script_typed_ir.Bls12_381_fr_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Bls12_381_fr_t, _) ⇒ not_equal tt
|
(Script_typed_ir.Map_t tal tar meta1,
Script_typed_ir.Map_t tbl tbr meta2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letstar (help tar tbr)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Gas_monad.Syntax.op_letplus (ty_eq error_details tal tbl)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq)))
| (Script_typed_ir.Map_t _ _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Big_map_t tal tar meta1,
Script_typed_ir.Big_map_t tbl tbr meta2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letstar (help tar tbr)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Gas_monad.Syntax.op_letplus (ty_eq error_details tal tbl)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq)))
| (Script_typed_ir.Big_map_t _ _ _, _) ⇒ not_equal tt
| (Script_typed_ir.Set_t ea meta1, Script_typed_ir.Set_t eb meta2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letplus (ty_eq error_details ea eb)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq))
| (Script_typed_ir.Set_t _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Ticket_t ea meta1,
Script_typed_ir.Ticket_t eb meta2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letplus (ty_eq error_details ea eb)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq))
| (Script_typed_ir.Ticket_t _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Pair_t tal tar meta1 cmp1,
Script_typed_ir.Pair_t tbl tbr meta2 cmp2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letstar (help tal tbl)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Gas_monad.Syntax.op_letplus (help tar tbr)
(fun function_parameter ⇒
let 'Eq := function_parameter in
let 'Dependent_bool.Eq :=
Dependent_bool.merge_dand cmp1 cmp2 in
Eq)))
| (Script_typed_ir.Pair_t _ _ _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Union_t tal tar meta1 cmp1,
Script_typed_ir.Union_t tbl tbr meta2 cmp2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letstar (help tal tbl)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Gas_monad.Syntax.op_letplus (help tar tbr)
(fun function_parameter ⇒
let 'Eq := function_parameter in
let 'Dependent_bool.Eq :=
Dependent_bool.merge_dand cmp1 cmp2 in
Eq)))
| (Script_typed_ir.Union_t _ _ _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Lambda_t tal tar meta1,
Script_typed_ir.Lambda_t tbl tbr meta2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letstar (help tal tbl)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Gas_monad.Syntax.op_letplus (help tar tbr)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq)))
| (Script_typed_ir.Lambda_t _ _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Contract_t tal meta1,
Script_typed_ir.Contract_t tbl meta2) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letplus (help tal tbl)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq))
| (Script_typed_ir.Contract_t _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Option_t tva meta1 _,
Script_typed_ir.Option_t tvb meta2 _) ⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letplus (help tva tvb)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq))
| (Script_typed_ir.Option_t _ _ _, _) ⇒ not_equal tt
| (Script_typed_ir.List_t tva meta1, Script_typed_ir.List_t tvb meta2)
⇒
Gas_monad.Syntax.op_letstar (type_metadata_eq meta1 meta2)
(fun function_parameter ⇒
let '_ := function_parameter in
Gas_monad.Syntax.op_letplus (help tva tvb)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Eq))
| (Script_typed_ir.List_t _ _, _) ⇒ not_equal tt
|
(Script_typed_ir.Sapling_state_t ms1,
Script_typed_ir.Sapling_state_t ms2) ⇒
Gas_monad.Syntax.op_letplus (memo_size_eq ms1 ms2)
(fun function_parameter ⇒
let '_ := function_parameter in
Eq)
| (Script_typed_ir.Sapling_state_t _, _) ⇒ not_equal tt
|
(Script_typed_ir.Sapling_transaction_t ms1,
Script_typed_ir.Sapling_transaction_t ms2) ⇒
Gas_monad.Syntax.op_letplus (memo_size_eq ms1 ms2)
(fun function_parameter ⇒
let '_ := function_parameter in
Eq)
| (Script_typed_ir.Sapling_transaction_t _, _) ⇒ not_equal tt
|
(Script_typed_ir.Sapling_transaction_deprecated_t ms1,
Script_typed_ir.Sapling_transaction_deprecated_t ms2) ⇒
Gas_monad.Syntax.op_letplus (memo_size_eq ms1 ms2)
(fun function_parameter ⇒
let '_ := function_parameter in
Eq)
| (Script_typed_ir.Sapling_transaction_deprecated_t _, _) ⇒
not_equal tt
| (Script_typed_ir.Chest_t, Script_typed_ir.Chest_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Chest_t, _) ⇒ not_equal tt
| (Script_typed_ir.Chest_key_t, Script_typed_ir.Chest_key_t) ⇒
Gas_monad.Syntax._return Eq
| (Script_typed_ir.Chest_key_t, _) ⇒ not_equal tt
end) in
Gas_monad.record_trace_eval error_details
(fun (loc_value : Alpha_context.Script.location) ⇒
default_ty_eq_error loc_value ty1 ty2) (help ty1 ty2).
Fixpoint stack_eq
(loc_value : Alpha_context.Script.location) (ctxt : Alpha_context.context)
(lvl : int) (stack1 : Script_typed_ir.stack_ty)
(stack2 : Script_typed_ir.stack_ty) : M? (eq × Alpha_context.context) :=
match (stack1, stack2) with
| (Script_typed_ir.Bot_t, Script_typed_ir.Bot_t) ⇒ return? (Eq, ctxt)
| (Script_typed_ir.Item_t ty1 rest1, Script_typed_ir.Item_t ty2 rest2) ⇒
let? '(eq_value, ctxt) :=
Error_monad.record_trace (Build_extensible "Bad_stack_item" int lvl)
(Gas_monad.run ctxt
(ty_eq (Script_tc_errors.Informative loc_value) ty1 ty2)) in
let? 'Eq := eq_value in
let? '(Eq, ctxt) := stack_eq loc_value ctxt (lvl +i 1) rest1 rest2 in
return? (Eq, ctxt)
| (_, _) ⇒
Error_monad.error_value (Build_extensible "Bad_stack_length" unit tt)
end.
Records for the constructor parameters
Module ConstructorRecords_judgement.
Module judgement.
Module Failed.
Record record {descr : Set} : Set := Build {
descr : descr;
}.
Arguments record : clear implicits.
Definition with_descr {t_descr} descr (r : record t_descr) :=
Build t_descr descr.
End Failed.
Definition Failed_skeleton := Failed.record.
End judgement.
End ConstructorRecords_judgement.
Import ConstructorRecords_judgement.
Reserved Notation "'judgement.Failed".
Inductive judgement : Set :=
| Typed : descr → judgement
| Failed : 'judgement.Failed → judgement
where "'judgement.Failed" :=
(judgement.Failed_skeleton (Script_typed_ir.stack_ty → descr)).
Module judgement.
Include ConstructorRecords_judgement.judgement.
Definition Failed := 'judgement.Failed.
End judgement.
Module branch.
Record record : Set := Build {
branch : descr → descr → descr;
}.
Definition with_branch branch (r : record) :=
Build branch.
End branch.
Definition branch := branch.record.
Definition merge_branches
(ctxt : Alpha_context.context) (loc_value : Alpha_context.Script.location)
(btr : judgement) (bfr : judgement) (function_parameter : branch)
: M? (judgement × Alpha_context.context) :=
let '{| branch.branch := branch |} := function_parameter in
match (btr, bfr) with
|
(Typed ({| descr.aft := aftbt |} as dbt),
Typed ({| descr.aft := aftbf |} as dbf)) ⇒
let unmatched_branches (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aftbt := Script_ir_unparser.serialize_stack_for_error ctxt aftbt in
let aftbf := Script_ir_unparser.serialize_stack_for_error ctxt aftbf in
Build_extensible "Unmatched_branches"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Script_tc_errors.unparsed_stack_ty) (loc_value, aftbt, aftbf) in
Error_monad.record_trace_eval unmatched_branches
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 aftbt aftbf in
return? ((Typed (branch dbt dbf)), ctxt))
|
(Failed {| judgement.Failed.descr := descrt |},
Failed {| judgement.Failed.descr := descrf |}) ⇒
let descr_value (ret_value : Script_typed_ir.stack_ty) : descr :=
branch (descrt ret_value) (descrf ret_value) in
return? ((Failed {| judgement.Failed.descr := descr_value; |}), ctxt)
| (Typed dbt, Failed {| judgement.Failed.descr := descrf |}) ⇒
return? ((Typed (branch dbt (descrf dbt.(descr.aft)))), ctxt)
| (Failed {| judgement.Failed.descr := descrt |}, Typed dbf) ⇒
return? ((Typed (branch (descrt dbf.(descr.aft)) dbf)), ctxt)
end.
Definition parse_memo_size
(n_value :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
: M? Alpha_context.Sapling.Memo_size.t :=
match n_value with
| Micheline.Int _ z_value ⇒
match Alpha_context.Sapling.Memo_size.parse_z z_value with
| Pervasives.Ok memo_size ⇒ Pervasives.Ok memo_size
| Pervasives.Error msg ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
((location n_value), (Micheline.strip_locations n_value), msg))
end
| _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location n_value), [ Script_tc_errors.Int_kind ], (kind_value n_value)))
end.
Inductive ex_comparable_ty : Set :=
| Ex_comparable_ty : Script_typed_ir.comparable_ty → ex_comparable_ty.
Module judgement.
Module Failed.
Record record {descr : Set} : Set := Build {
descr : descr;
}.
Arguments record : clear implicits.
Definition with_descr {t_descr} descr (r : record t_descr) :=
Build t_descr descr.
End Failed.
Definition Failed_skeleton := Failed.record.
End judgement.
End ConstructorRecords_judgement.
Import ConstructorRecords_judgement.
Reserved Notation "'judgement.Failed".
Inductive judgement : Set :=
| Typed : descr → judgement
| Failed : 'judgement.Failed → judgement
where "'judgement.Failed" :=
(judgement.Failed_skeleton (Script_typed_ir.stack_ty → descr)).
Module judgement.
Include ConstructorRecords_judgement.judgement.
Definition Failed := 'judgement.Failed.
End judgement.
Module branch.
Record record : Set := Build {
branch : descr → descr → descr;
}.
Definition with_branch branch (r : record) :=
Build branch.
End branch.
Definition branch := branch.record.
Definition merge_branches
(ctxt : Alpha_context.context) (loc_value : Alpha_context.Script.location)
(btr : judgement) (bfr : judgement) (function_parameter : branch)
: M? (judgement × Alpha_context.context) :=
let '{| branch.branch := branch |} := function_parameter in
match (btr, bfr) with
|
(Typed ({| descr.aft := aftbt |} as dbt),
Typed ({| descr.aft := aftbf |} as dbf)) ⇒
let unmatched_branches (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aftbt := Script_ir_unparser.serialize_stack_for_error ctxt aftbt in
let aftbf := Script_ir_unparser.serialize_stack_for_error ctxt aftbf in
Build_extensible "Unmatched_branches"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Script_tc_errors.unparsed_stack_ty) (loc_value, aftbt, aftbf) in
Error_monad.record_trace_eval unmatched_branches
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 aftbt aftbf in
return? ((Typed (branch dbt dbf)), ctxt))
|
(Failed {| judgement.Failed.descr := descrt |},
Failed {| judgement.Failed.descr := descrf |}) ⇒
let descr_value (ret_value : Script_typed_ir.stack_ty) : descr :=
branch (descrt ret_value) (descrf ret_value) in
return? ((Failed {| judgement.Failed.descr := descr_value; |}), ctxt)
| (Typed dbt, Failed {| judgement.Failed.descr := descrf |}) ⇒
return? ((Typed (branch dbt (descrf dbt.(descr.aft)))), ctxt)
| (Failed {| judgement.Failed.descr := descrt |}, Typed dbf) ⇒
return? ((Typed (branch (descrt dbf.(descr.aft)) dbf)), ctxt)
end.
Definition parse_memo_size
(n_value :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
: M? Alpha_context.Sapling.Memo_size.t :=
match n_value with
| Micheline.Int _ z_value ⇒
match Alpha_context.Sapling.Memo_size.parse_z z_value with
| Pervasives.Ok memo_size ⇒ Pervasives.Ok memo_size
| Pervasives.Error msg ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
((location n_value), (Micheline.strip_locations n_value), msg))
end
| _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location n_value), [ Script_tc_errors.Int_kind ], (kind_value n_value)))
end.
Inductive ex_comparable_ty : Set :=
| Ex_comparable_ty : Script_typed_ir.comparable_ty → ex_comparable_ty.
Records for the constructor parameters
Module ConstructorRecords_ex_parameter_ty_and_entrypoints_node.
Module ex_parameter_ty_and_entrypoints_node.
Module Ex_parameter_ty_and_entrypoints_node.
Record record {arg_type entrypoints : Set} : Set := Build {
arg_type : arg_type;
entrypoints : entrypoints;
}.
Arguments record : clear implicits.
Definition with_arg_type {t_arg_type t_entrypoints} arg_type
(r : record t_arg_type t_entrypoints) :=
Build t_arg_type t_entrypoints arg_type r.(entrypoints).
Definition with_entrypoints {t_arg_type t_entrypoints} entrypoints
(r : record t_arg_type t_entrypoints) :=
Build t_arg_type t_entrypoints r.(arg_type) entrypoints.
End Ex_parameter_ty_and_entrypoints_node.
Definition Ex_parameter_ty_and_entrypoints_node_skeleton :=
Ex_parameter_ty_and_entrypoints_node.record.
End ex_parameter_ty_and_entrypoints_node.
End ConstructorRecords_ex_parameter_ty_and_entrypoints_node.
Import ConstructorRecords_ex_parameter_ty_and_entrypoints_node.
Reserved Notation
"'ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node".
Inductive ex_parameter_ty_and_entrypoints_node : Set :=
| Ex_parameter_ty_and_entrypoints_node :
'ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node →
ex_parameter_ty_and_entrypoints_node
where "'ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node"
:=
(ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node_skeleton
Script_typed_ir.ty Script_typed_ir.entrypoints_node).
Module ex_parameter_ty_and_entrypoints_node.
Include ConstructorRecords_ex_parameter_ty_and_entrypoints_node.ex_parameter_ty_and_entrypoints_node.
Definition Ex_parameter_ty_and_entrypoints_node :=
'ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.
End ex_parameter_ty_and_entrypoints_node.
Module ex_parameter_ty_and_entrypoints_node.
Module Ex_parameter_ty_and_entrypoints_node.
Record record {arg_type entrypoints : Set} : Set := Build {
arg_type : arg_type;
entrypoints : entrypoints;
}.
Arguments record : clear implicits.
Definition with_arg_type {t_arg_type t_entrypoints} arg_type
(r : record t_arg_type t_entrypoints) :=
Build t_arg_type t_entrypoints arg_type r.(entrypoints).
Definition with_entrypoints {t_arg_type t_entrypoints} entrypoints
(r : record t_arg_type t_entrypoints) :=
Build t_arg_type t_entrypoints r.(arg_type) entrypoints.
End Ex_parameter_ty_and_entrypoints_node.
Definition Ex_parameter_ty_and_entrypoints_node_skeleton :=
Ex_parameter_ty_and_entrypoints_node.record.
End ex_parameter_ty_and_entrypoints_node.
End ConstructorRecords_ex_parameter_ty_and_entrypoints_node.
Import ConstructorRecords_ex_parameter_ty_and_entrypoints_node.
Reserved Notation
"'ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node".
Inductive ex_parameter_ty_and_entrypoints_node : Set :=
| Ex_parameter_ty_and_entrypoints_node :
'ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node →
ex_parameter_ty_and_entrypoints_node
where "'ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node"
:=
(ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node_skeleton
Script_typed_ir.ty Script_typed_ir.entrypoints_node).
Module ex_parameter_ty_and_entrypoints_node.
Include ConstructorRecords_ex_parameter_ty_and_entrypoints_node.ex_parameter_ty_and_entrypoints_node.
Definition Ex_parameter_ty_and_entrypoints_node :=
'ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.
End ex_parameter_ty_and_entrypoints_node.
[parse_ty_aux] can be used to parse regular types as well as parameter types
together with their entrypoints.
In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty_aux] will
return an [ex_ty].
In the second case, use [~ret:Parse_entrypoints], [parse_ty_aux] will return
an [ex_parameter_ty_and_entrypoints_node].
Inductive parse_ty_ret : Set :=
| Don't_parse_entrypoints : parse_ty_ret
| Parse_entrypoints : parse_ty_ret.
#[bypass_check(guard)]
Fixpoint parse_ty_aux {ret : Set}
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(allow_lazy_storage : bool) (allow_operation : bool) (allow_contract : bool)
(allow_ticket : bool) (ret_value : parse_ty_ret)
(node_value : Alpha_context.Script.node) {struct node_value}
: M? (ret × Alpha_context.context) :=
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.parse_type_cycle
in
if stack_depth >i 10000 then
Error_monad.error_value
(Build_extensible "Typechecking_too_many_recursive_calls" unit tt)
else
let? '(node_value, name) :=
match ret_value with
| Don't_parse_entrypoints ⇒ return? (node_value, None)
| Parse_entrypoints ⇒ Script_ir_annot.extract_entrypoint_annot node_value
end in
let _return (ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty)
: ret × Alpha_context.context :=
match (ret_value, name) with
| (Don't_parse_entrypoints, _) ⇒
cast (ret × Alpha_context.context)
((Script_typed_ir.Ex_ty ty_value), ctxt)
| (Parse_entrypoints, name) ⇒
let name := cast (option Alpha_context.Entrypoint.t) name in
cast (ret × Alpha_context.context)
(let at_node :=
Option.map
(fun (name : Alpha_context.Entrypoint.t) ⇒
{| Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr :=
node_value; |}) name in
((Ex_parameter_ty_and_entrypoints_node
{|
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.arg_type
:= ty_value;
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.entrypoints
:=
{| Script_typed_ir.entrypoints_node.at_node := at_node;
Script_typed_ir.entrypoints_node.nested :=
Script_typed_ir.Entrypoints_None; |}; |}), ctxt))
end in
match
(node_value,
match node_value with
| Micheline.Prim loc_value Michelson_v1_primitives.T_big_map args annot
⇒ allow_lazy_storage
| _ ⇒ false
end,
match node_value with
|
Micheline.Prim loc_value Michelson_v1_primitives.T_sapling_state
(cons memo_size []) annot ⇒ allow_lazy_storage
| _ ⇒ false
end) with
| (Micheline.Prim loc_value Michelson_v1_primitives.T_unit [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.unit_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_int [] annot, _, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.int_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_nat [] annot, _, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.nat_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_string [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.string_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_bytes [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.bytes_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_mutez [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.mutez_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_bool [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.bool_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_key [] annot, _, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.key_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_key_hash [] annot, _,
_) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.key_hash_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_chest_key [] annot, _,
_) ⇒
if legacy then
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.chest_key_t)
else
Error_monad.error_value
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.T_chest_key)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_chest [] annot, _, _)
⇒
if legacy then
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.chest_t)
else
Error_monad.error_value
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.T_chest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_timestamp [] annot, _,
_) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.timestamp_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_address [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.address_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_tx_rollup_l2_address
[] annot, _, _) ⇒
if Alpha_context.Constants.tx_rollup_enable ctxt then
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.tx_rollup_l2_address_t)
else
Error_monad.error_value
(Build_extensible "Tx_rollup_addresses_disabled"
Alpha_context.Script.location loc_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_signature [] annot, _,
_) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.signature_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_operation [] annot, _,
_) ⇒
if allow_operation then
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.operation_t)
else
Error_monad.error_value
(Build_extensible "Unexpected_operation" Alpha_context.Script.location
loc_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_chain_id [] annot, _,
_) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.chain_id_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_never [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.never_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_bls12_381_g1 [] annot,
_, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.bls12_381_g1_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_bls12_381_g2 [] annot,
_, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.bls12_381_g2_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_bls12_381_fr [] annot,
_, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.bls12_381_fr_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_contract (cons utl [])
annot, _, _) ⇒
if allow_contract then
let? '(Script_typed_ir.Ex_ty tl, ctxt) :=
parse_passable_ty_aux_with_ret ctxt (stack_depth +i 1) legacy
Don't_parse_entrypoints utl in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? ty_value := Script_typed_ir.contract_t loc_value tl in
return? (_return ctxt ty_value)
else
Error_monad.error_value
(Build_extensible "Unexpected_contract" Alpha_context.Script.location
loc_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_pair (cons utl utr)
annot, _, _) ⇒
let? utl := Script_ir_annot.remove_field_annot utl in
let? '(Script_typed_ir.Ex_ty tl, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket Don't_parse_entrypoints
utl in
let? utr :=
match utr with
| cons utr [] ⇒ Script_ir_annot.remove_field_annot utr
| utr ⇒
return?
(Micheline.Prim loc_value Michelson_v1_primitives.T_pair utr nil)
end in
let? '(Script_typed_ir.Ex_ty tr, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket Don't_parse_entrypoints
utr in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.pair_t loc_value tl tr in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_or
(cons utl (cons utr [])) annot, _, _) ⇒
let? '(utl, utr) :=
match ret_value with
| Don't_parse_entrypoints ⇒
let? utl := Script_ir_annot.remove_field_annot utl in
let? utr := Script_ir_annot.remove_field_annot utr in
return? (utl, utr)
| Parse_entrypoints ⇒ return? (utl, utr)
end in
let? '(parsed_l, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket ret_value utl in
let? '(parsed_r, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket ret_value utr in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
match (ret_value, parsed_l, parsed_r, name) with
| (Don't_parse_entrypoints, _, _, _) ⇒
cast (M? (ret × Alpha_context.context))
(let 'Script_typed_ir.Ex_ty tl := parsed_l in
let 'Script_typed_ir.Ex_ty tr := parsed_r in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.union_t loc_value tl tr in
return? ((Script_typed_ir.Ex_ty ty_value), ctxt))
| (Parse_entrypoints, parsed_l, parsed_r, name) ⇒
let '[name, parsed_r, parsed_l] :=
cast
[option Alpha_context.Entrypoint.t **
ex_parameter_ty_and_entrypoints_node **
ex_parameter_ty_and_entrypoints_node] [name, parsed_r, parsed_l]
in
cast (M? (ret × Alpha_context.context))
(let
'Ex_parameter_ty_and_entrypoints_node {|
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.arg_type
:= tl;
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.entrypoints
:= _left
|} := parsed_l in
let
'Ex_parameter_ty_and_entrypoints_node {|
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.arg_type
:= tr;
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.entrypoints
:= _right
|} := parsed_r in
let? 'Script_typed_ir.Ty_ex_c arg_type :=
Script_typed_ir.union_t loc_value tl tr in
let entrypoints :=
let at_node :=
Option.map
(fun (name : Alpha_context.Entrypoint.t) ⇒
{| Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr :=
node_value; |}) name in
{| Script_typed_ir.entrypoints_node.at_node := at_node;
Script_typed_ir.entrypoints_node.nested :=
Script_typed_ir.Entrypoints_Union
{|
Script_typed_ir.nested_entrypoints.Entrypoints_Union._left :=
_left;
Script_typed_ir.nested_entrypoints.Entrypoints_Union._right :=
_right; |}; |} in
return?
((Ex_parameter_ty_and_entrypoints_node
{|
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.arg_type
:= arg_type;
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.entrypoints
:= entrypoints; |}), ctxt))
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_lambda
(cons uta (cons utr [])) annot, _, _) ⇒
let? '(Script_typed_ir.Ex_ty ta, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy uta in
let? '(Script_typed_ir.Ex_ty tr, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy utr in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? ty_value := Script_typed_ir.lambda_t loc_value ta tr in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_option (cons ut [])
annot, _, _) ⇒
let? ut :=
if legacy then
let? ut := Script_ir_annot.remove_field_annot ut in
let? '_ := Script_ir_annot.check_composed_type_annot loc_value annot
in
return? ut
else
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? ut in
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket Don't_parse_entrypoints ut
in
let? ty_value := Script_typed_ir.option_t loc_value t_value in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_list (cons ut [])
annot, _, _) ⇒
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket Don't_parse_entrypoints ut
in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? ty_value := Script_typed_ir.list_t loc_value t_value in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_ticket (cons ut [])
annot, _, _) ⇒
if allow_ticket then
let? '(Ex_comparable_ty t_value, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) ut in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? ty_value := Script_typed_ir.ticket_t loc_value t_value in
return? (_return ctxt ty_value)
else
Error_monad.error_value
(Build_extensible "Unexpected_ticket" Alpha_context.Script.location
loc_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_set (cons ut []) annot,
_, _) ⇒
let? '(Ex_comparable_ty t_value, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) ut in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? ty_value := Script_typed_ir.set_t loc_value t_value in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_map
(cons uta (cons utr [])) annot, _, _) ⇒
let? '(Ex_comparable_ty ta, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) uta in
let? '(Script_typed_ir.Ex_ty tr, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket Don't_parse_entrypoints
utr in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? ty_value := Script_typed_ir.map_t loc_value ta tr in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_sapling_transaction
(cons memo_size []) annot, _, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? memo_size := parse_memo_size memo_size in
return? (_return ctxt (Script_typed_ir.sapling_transaction_t memo_size))
|
(Micheline.Prim loc_value
Michelson_v1_primitives.T_sapling_transaction_deprecated
(cons memo_size []) annot, _, _) ⇒
if legacy then
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? memo_size := parse_memo_size memo_size in
return?
(_return ctxt
(Script_typed_ir.sapling_transaction_deprecated_t memo_size))
else
Error_monad.error_value
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.T_sapling_transaction_deprecated)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_big_map args annot,
true, _) ⇒
let? '(Script_typed_ir.Ex_ty ty_value, ctxt) :=
parse_big_map_ty ctxt (stack_depth +i 1) legacy loc_value args annot in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_sapling_state
(cons memo_size []) annot, _, true) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? memo_size := parse_memo_size memo_size in
return? (_return ctxt (Script_typed_ir.sapling_state_t memo_size))
|
(Micheline.Prim loc_value
(Michelson_v1_primitives.T_big_map |
Michelson_v1_primitives.T_sapling_state) _ _, _, _) ⇒
Error_monad.error_value
(Build_extensible "Unexpected_lazy_storage"
Alpha_context.Script.location loc_value)
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.T_unit | Michelson_v1_primitives.T_signature |
Michelson_v1_primitives.T_int | Michelson_v1_primitives.T_nat |
Michelson_v1_primitives.T_string | Michelson_v1_primitives.T_bytes |
Michelson_v1_primitives.T_mutez | Michelson_v1_primitives.T_bool |
Michelson_v1_primitives.T_key | Michelson_v1_primitives.T_key_hash |
Michelson_v1_primitives.T_timestamp | Michelson_v1_primitives.T_address
| Michelson_v1_primitives.T_tx_rollup_l2_address |
Michelson_v1_primitives.T_chain_id | Michelson_v1_primitives.T_operation
| Michelson_v1_primitives.T_never) as prim) l_value _, _, _) ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, prim, 0, (List.length l_value)))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.T_set | Michelson_v1_primitives.T_list |
Michelson_v1_primitives.T_option | Michelson_v1_primitives.T_contract |
Michelson_v1_primitives.T_ticket) as prim) l_value _, _, _) ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, prim, 1, (List.length l_value)))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.T_pair | Michelson_v1_primitives.T_or |
Michelson_v1_primitives.T_map | Michelson_v1_primitives.T_lambda) as
prim) l_value _, _, _) ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, prim, 2, (List.length l_value)))
| (expr, _, _) ⇒
Error_monad.error_value
(unexpected expr nil Michelson_v1_primitives.Type_namespace
[
Michelson_v1_primitives.T_bls12_381_fr;
Michelson_v1_primitives.T_bls12_381_g1;
Michelson_v1_primitives.T_bls12_381_g2;
Michelson_v1_primitives.T_bool;
Michelson_v1_primitives.T_bytes;
Michelson_v1_primitives.T_chain_id;
Michelson_v1_primitives.T_contract;
Michelson_v1_primitives.T_int;
Michelson_v1_primitives.T_key;
Michelson_v1_primitives.T_key_hash;
Michelson_v1_primitives.T_lambda;
Michelson_v1_primitives.T_list;
Michelson_v1_primitives.T_map;
Michelson_v1_primitives.T_mutez;
Michelson_v1_primitives.T_nat;
Michelson_v1_primitives.T_never;
Michelson_v1_primitives.T_operation;
Michelson_v1_primitives.T_option;
Michelson_v1_primitives.T_or;
Michelson_v1_primitives.T_pair;
Michelson_v1_primitives.T_set;
Michelson_v1_primitives.T_signature;
Michelson_v1_primitives.T_string;
Michelson_v1_primitives.T_ticket;
Michelson_v1_primitives.T_timestamp;
Michelson_v1_primitives.T_tx_rollup_l2_address;
Michelson_v1_primitives.T_unit
])
end
with parse_comparable_ty_aux
(ctxt : Alpha_context.context) (stack_depth : int)
(node_value : Alpha_context.Script.node) {struct stack_depth}
: M? (ex_comparable_ty × Alpha_context.context) :=
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) false false false false false
Don't_parse_entrypoints node_value in
match Script_typed_ir.is_comparable t_value with
| Dependent_bool.Yes ⇒ return? ((Ex_comparable_ty t_value), ctxt)
| Dependent_bool.No ⇒
Error_monad.error_value
(Build_extensible "Comparable_type_expected"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
((location node_value), (Micheline.strip_locations node_value)))
end
with parse_passable_ty_aux_with_ret {ret : Set}
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
{struct stack_depth}
: parse_ty_ret → Alpha_context.Script.node →
M? (ret × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy true false true true
with parse_any_ty_aux
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
{struct stack_depth}
: Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy true true true true
Don't_parse_entrypoints
with parse_big_map_ty
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(big_map_loc : Alpha_context.Script.location)
(args :
list
(Micheline.node Alpha_context.Script.location Alpha_context.Script.prim))
(map_annot : Micheline.annot) {struct args}
: M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.parse_type_cycle
in
match args with
| cons key_ty (cons value_ty []) ⇒
let? '(Ex_comparable_ty key_ty, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) key_ty in
let? '(Script_typed_ir.Ex_ty value_ty, ctxt) :=
parse_big_map_value_ty_aux ctxt (stack_depth +i 1) legacy value_ty in
let? '_ := Script_ir_annot.check_type_annot big_map_loc map_annot in
let? big_map_ty := Script_typed_ir.big_map_t big_map_loc key_ty value_ty in
return? ((Script_typed_ir.Ex_ty big_map_ty), ctxt)
| args ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(big_map_loc, Michelson_v1_primitives.T_big_map, 2, (List.length args)))
end
with parse_big_map_value_ty_aux
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(value_ty :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
{struct stack_depth} : M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy false false legacy true
Don't_parse_entrypoints value_ty.
Definition parse_packable_ty_aux
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(node_value : Alpha_context.Script.node)
: M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy false false legacy false
Don't_parse_entrypoints node_value.
Definition parse_view_input_ty
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(node_value : Alpha_context.Script.node)
: M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy false false true false
Don't_parse_entrypoints node_value.
Definition parse_view_output_ty
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(node_value : Alpha_context.Script.node)
: M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy false false true false
Don't_parse_entrypoints node_value.
Definition parse_normal_storage_ty
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(node_value : Alpha_context.Script.node)
: M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy true false legacy true
Don't_parse_entrypoints node_value.
Definition parse_storage_ty
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(node_value : Alpha_context.Script.node)
: M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
match
(node_value,
match node_value with
|
Micheline.Prim loc_value Michelson_v1_primitives.T_pair
(cons
(Micheline.Prim big_map_loc Michelson_v1_primitives.T_big_map args
map_annot) (cons remaining_storage [])) storage_annot ⇒ legacy
| _ ⇒ false
end) with
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_pair
(cons
(Micheline.Prim big_map_loc Michelson_v1_primitives.T_big_map args
map_annot) (cons remaining_storage [])) storage_annot, true) ⇒
match
(storage_annot,
match storage_annot with
| cons single [] ⇒
((String.length single) >i 0) &&
(Compare.Char.(Compare.S.op_eq) (String.get single 0) "%" % char)
| _ ⇒ false
end) with
| ([], _) ⇒ parse_normal_storage_ty ctxt stack_depth legacy node_value
| (cons single [], true) ⇒
parse_normal_storage_ty ctxt stack_depth legacy node_value
| (_, _) ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.parse_type_cycle in
let? '(Script_typed_ir.Ex_ty big_map_ty, ctxt) :=
parse_big_map_ty ctxt (stack_depth +i 1) legacy big_map_loc args
map_annot in
let? '(Script_typed_ir.Ex_ty remaining_storage, ctxt) :=
parse_normal_storage_ty ctxt (stack_depth +i 1) legacy remaining_storage
in
let? '_ :=
Script_ir_annot.check_composed_type_annot loc_value storage_annot in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.pair_t loc_value big_map_ty remaining_storage in
return? ((Script_typed_ir.Ex_ty ty_value), ctxt)
end
| (_, _) ⇒ parse_normal_storage_ty ctxt stack_depth legacy node_value
end.
Definition check_packable
(legacy : bool) (loc_value : Alpha_context.Script.location)
(root_value : Script_typed_ir.ty) : M? unit :=
let fix check (function_parameter : Script_typed_ir.ty) : M? unit :=
match
(function_parameter,
match function_parameter with
| Script_typed_ir.Contract_t _ _ ⇒ legacy
| _ ⇒ false
end) with
| (Script_typed_ir.Big_map_t _ _ _, _) ⇒
Error_monad.error_value
(Build_extensible "Unexpected_lazy_storage"
Alpha_context.Script.location loc_value)
| (Script_typed_ir.Sapling_state_t _, _) ⇒
Error_monad.error_value
(Build_extensible "Unexpected_lazy_storage"
Alpha_context.Script.location loc_value)
| (Script_typed_ir.Operation_t, _) ⇒
Error_monad.error_value
(Build_extensible "Unexpected_operation" Alpha_context.Script.location
loc_value)
| (Script_typed_ir.Unit_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Int_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Nat_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Signature_t, _) ⇒ Result.return_unit
| (Script_typed_ir.String_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Bytes_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Mutez_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Key_hash_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Key_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Timestamp_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Address_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Tx_rollup_l2_address_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Bool_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Chain_id_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Never_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Set_t _ _, _) ⇒ Result.return_unit
| (Script_typed_ir.Ticket_t _ _, _) ⇒
Error_monad.error_value
(Build_extensible "Unexpected_ticket" Alpha_context.Script.location
loc_value)
| (Script_typed_ir.Lambda_t _ _ _, _) ⇒ Result.return_unit
| (Script_typed_ir.Bls12_381_g1_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Bls12_381_g2_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Bls12_381_fr_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Pair_t l_ty r_ty _ _, _) ⇒
let? '_ := check l_ty in
check r_ty
| (Script_typed_ir.Union_t l_ty r_ty _ _, _) ⇒
let? '_ := check l_ty in
check r_ty
| (Script_typed_ir.Option_t v_ty _ _, _) ⇒ check v_ty
| (Script_typed_ir.List_t elt_ty _, _) ⇒ check elt_ty
| (Script_typed_ir.Map_t _ elt_ty _, _) ⇒ check elt_ty
| (Script_typed_ir.Contract_t _ _, true) ⇒ Result.return_unit
| (Script_typed_ir.Contract_t _ _, _) ⇒
Error_monad.error_value
(Build_extensible "Unexpected_contract" Alpha_context.Script.location
loc_value)
| (Script_typed_ir.Sapling_transaction_t _, _) ⇒ return? tt
| (Script_typed_ir.Sapling_transaction_deprecated_t _, _) ⇒ return? tt
| (Script_typed_ir.Chest_key_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Chest_t, _) ⇒ Result.return_unit
end in
check root_value.
Module toplevel.
Record record : Set := Build {
code_field : Alpha_context.Script.node;
arg_type : Alpha_context.Script.node;
storage_type : Alpha_context.Script.node;
views : Script_typed_ir.view_map;
}.
Definition with_code_field code_field (r : record) :=
Build code_field r.(arg_type) r.(storage_type) r.(views).
Definition with_arg_type arg_type (r : record) :=
Build r.(code_field) arg_type r.(storage_type) r.(views).
Definition with_storage_type storage_type (r : record) :=
Build r.(code_field) r.(arg_type) storage_type r.(views).
Definition with_views views (r : record) :=
Build r.(code_field) r.(arg_type) r.(storage_type) views.
End toplevel.
Definition toplevel := toplevel.record.
| Don't_parse_entrypoints : parse_ty_ret
| Parse_entrypoints : parse_ty_ret.
#[bypass_check(guard)]
Fixpoint parse_ty_aux {ret : Set}
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(allow_lazy_storage : bool) (allow_operation : bool) (allow_contract : bool)
(allow_ticket : bool) (ret_value : parse_ty_ret)
(node_value : Alpha_context.Script.node) {struct node_value}
: M? (ret × Alpha_context.context) :=
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.parse_type_cycle
in
if stack_depth >i 10000 then
Error_monad.error_value
(Build_extensible "Typechecking_too_many_recursive_calls" unit tt)
else
let? '(node_value, name) :=
match ret_value with
| Don't_parse_entrypoints ⇒ return? (node_value, None)
| Parse_entrypoints ⇒ Script_ir_annot.extract_entrypoint_annot node_value
end in
let _return (ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty)
: ret × Alpha_context.context :=
match (ret_value, name) with
| (Don't_parse_entrypoints, _) ⇒
cast (ret × Alpha_context.context)
((Script_typed_ir.Ex_ty ty_value), ctxt)
| (Parse_entrypoints, name) ⇒
let name := cast (option Alpha_context.Entrypoint.t) name in
cast (ret × Alpha_context.context)
(let at_node :=
Option.map
(fun (name : Alpha_context.Entrypoint.t) ⇒
{| Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr :=
node_value; |}) name in
((Ex_parameter_ty_and_entrypoints_node
{|
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.arg_type
:= ty_value;
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.entrypoints
:=
{| Script_typed_ir.entrypoints_node.at_node := at_node;
Script_typed_ir.entrypoints_node.nested :=
Script_typed_ir.Entrypoints_None; |}; |}), ctxt))
end in
match
(node_value,
match node_value with
| Micheline.Prim loc_value Michelson_v1_primitives.T_big_map args annot
⇒ allow_lazy_storage
| _ ⇒ false
end,
match node_value with
|
Micheline.Prim loc_value Michelson_v1_primitives.T_sapling_state
(cons memo_size []) annot ⇒ allow_lazy_storage
| _ ⇒ false
end) with
| (Micheline.Prim loc_value Michelson_v1_primitives.T_unit [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.unit_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_int [] annot, _, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.int_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_nat [] annot, _, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.nat_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_string [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.string_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_bytes [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.bytes_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_mutez [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.mutez_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_bool [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.bool_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_key [] annot, _, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.key_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_key_hash [] annot, _,
_) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.key_hash_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_chest_key [] annot, _,
_) ⇒
if legacy then
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.chest_key_t)
else
Error_monad.error_value
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.T_chest_key)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_chest [] annot, _, _)
⇒
if legacy then
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.chest_t)
else
Error_monad.error_value
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.T_chest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_timestamp [] annot, _,
_) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.timestamp_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_address [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.address_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_tx_rollup_l2_address
[] annot, _, _) ⇒
if Alpha_context.Constants.tx_rollup_enable ctxt then
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.tx_rollup_l2_address_t)
else
Error_monad.error_value
(Build_extensible "Tx_rollup_addresses_disabled"
Alpha_context.Script.location loc_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_signature [] annot, _,
_) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.signature_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_operation [] annot, _,
_) ⇒
if allow_operation then
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.operation_t)
else
Error_monad.error_value
(Build_extensible "Unexpected_operation" Alpha_context.Script.location
loc_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_chain_id [] annot, _,
_) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.chain_id_t)
| (Micheline.Prim loc_value Michelson_v1_primitives.T_never [] annot, _, _)
⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.never_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_bls12_381_g1 [] annot,
_, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.bls12_381_g1_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_bls12_381_g2 [] annot,
_, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.bls12_381_g2_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_bls12_381_fr [] annot,
_, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? (_return ctxt Script_typed_ir.bls12_381_fr_t)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_contract (cons utl [])
annot, _, _) ⇒
if allow_contract then
let? '(Script_typed_ir.Ex_ty tl, ctxt) :=
parse_passable_ty_aux_with_ret ctxt (stack_depth +i 1) legacy
Don't_parse_entrypoints utl in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? ty_value := Script_typed_ir.contract_t loc_value tl in
return? (_return ctxt ty_value)
else
Error_monad.error_value
(Build_extensible "Unexpected_contract" Alpha_context.Script.location
loc_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_pair (cons utl utr)
annot, _, _) ⇒
let? utl := Script_ir_annot.remove_field_annot utl in
let? '(Script_typed_ir.Ex_ty tl, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket Don't_parse_entrypoints
utl in
let? utr :=
match utr with
| cons utr [] ⇒ Script_ir_annot.remove_field_annot utr
| utr ⇒
return?
(Micheline.Prim loc_value Michelson_v1_primitives.T_pair utr nil)
end in
let? '(Script_typed_ir.Ex_ty tr, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket Don't_parse_entrypoints
utr in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.pair_t loc_value tl tr in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_or
(cons utl (cons utr [])) annot, _, _) ⇒
let? '(utl, utr) :=
match ret_value with
| Don't_parse_entrypoints ⇒
let? utl := Script_ir_annot.remove_field_annot utl in
let? utr := Script_ir_annot.remove_field_annot utr in
return? (utl, utr)
| Parse_entrypoints ⇒ return? (utl, utr)
end in
let? '(parsed_l, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket ret_value utl in
let? '(parsed_r, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket ret_value utr in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
match (ret_value, parsed_l, parsed_r, name) with
| (Don't_parse_entrypoints, _, _, _) ⇒
cast (M? (ret × Alpha_context.context))
(let 'Script_typed_ir.Ex_ty tl := parsed_l in
let 'Script_typed_ir.Ex_ty tr := parsed_r in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.union_t loc_value tl tr in
return? ((Script_typed_ir.Ex_ty ty_value), ctxt))
| (Parse_entrypoints, parsed_l, parsed_r, name) ⇒
let '[name, parsed_r, parsed_l] :=
cast
[option Alpha_context.Entrypoint.t **
ex_parameter_ty_and_entrypoints_node **
ex_parameter_ty_and_entrypoints_node] [name, parsed_r, parsed_l]
in
cast (M? (ret × Alpha_context.context))
(let
'Ex_parameter_ty_and_entrypoints_node {|
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.arg_type
:= tl;
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.entrypoints
:= _left
|} := parsed_l in
let
'Ex_parameter_ty_and_entrypoints_node {|
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.arg_type
:= tr;
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.entrypoints
:= _right
|} := parsed_r in
let? 'Script_typed_ir.Ty_ex_c arg_type :=
Script_typed_ir.union_t loc_value tl tr in
let entrypoints :=
let at_node :=
Option.map
(fun (name : Alpha_context.Entrypoint.t) ⇒
{| Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr :=
node_value; |}) name in
{| Script_typed_ir.entrypoints_node.at_node := at_node;
Script_typed_ir.entrypoints_node.nested :=
Script_typed_ir.Entrypoints_Union
{|
Script_typed_ir.nested_entrypoints.Entrypoints_Union._left :=
_left;
Script_typed_ir.nested_entrypoints.Entrypoints_Union._right :=
_right; |}; |} in
return?
((Ex_parameter_ty_and_entrypoints_node
{|
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.arg_type
:= arg_type;
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.entrypoints
:= entrypoints; |}), ctxt))
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_lambda
(cons uta (cons utr [])) annot, _, _) ⇒
let? '(Script_typed_ir.Ex_ty ta, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy uta in
let? '(Script_typed_ir.Ex_ty tr, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy utr in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? ty_value := Script_typed_ir.lambda_t loc_value ta tr in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_option (cons ut [])
annot, _, _) ⇒
let? ut :=
if legacy then
let? ut := Script_ir_annot.remove_field_annot ut in
let? '_ := Script_ir_annot.check_composed_type_annot loc_value annot
in
return? ut
else
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
return? ut in
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket Don't_parse_entrypoints ut
in
let? ty_value := Script_typed_ir.option_t loc_value t_value in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_list (cons ut [])
annot, _, _) ⇒
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket Don't_parse_entrypoints ut
in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? ty_value := Script_typed_ir.list_t loc_value t_value in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_ticket (cons ut [])
annot, _, _) ⇒
if allow_ticket then
let? '(Ex_comparable_ty t_value, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) ut in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? ty_value := Script_typed_ir.ticket_t loc_value t_value in
return? (_return ctxt ty_value)
else
Error_monad.error_value
(Build_extensible "Unexpected_ticket" Alpha_context.Script.location
loc_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_set (cons ut []) annot,
_, _) ⇒
let? '(Ex_comparable_ty t_value, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) ut in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? ty_value := Script_typed_ir.set_t loc_value t_value in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_map
(cons uta (cons utr [])) annot, _, _) ⇒
let? '(Ex_comparable_ty ta, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) uta in
let? '(Script_typed_ir.Ex_ty tr, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) legacy allow_lazy_storage
allow_operation allow_contract allow_ticket Don't_parse_entrypoints
utr in
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? ty_value := Script_typed_ir.map_t loc_value ta tr in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_sapling_transaction
(cons memo_size []) annot, _, _) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? memo_size := parse_memo_size memo_size in
return? (_return ctxt (Script_typed_ir.sapling_transaction_t memo_size))
|
(Micheline.Prim loc_value
Michelson_v1_primitives.T_sapling_transaction_deprecated
(cons memo_size []) annot, _, _) ⇒
if legacy then
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? memo_size := parse_memo_size memo_size in
return?
(_return ctxt
(Script_typed_ir.sapling_transaction_deprecated_t memo_size))
else
Error_monad.error_value
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.T_sapling_transaction_deprecated)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_big_map args annot,
true, _) ⇒
let? '(Script_typed_ir.Ex_ty ty_value, ctxt) :=
parse_big_map_ty ctxt (stack_depth +i 1) legacy loc_value args annot in
return? (_return ctxt ty_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_sapling_state
(cons memo_size []) annot, _, true) ⇒
let? '_ := Script_ir_annot.check_type_annot loc_value annot in
let? memo_size := parse_memo_size memo_size in
return? (_return ctxt (Script_typed_ir.sapling_state_t memo_size))
|
(Micheline.Prim loc_value
(Michelson_v1_primitives.T_big_map |
Michelson_v1_primitives.T_sapling_state) _ _, _, _) ⇒
Error_monad.error_value
(Build_extensible "Unexpected_lazy_storage"
Alpha_context.Script.location loc_value)
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.T_unit | Michelson_v1_primitives.T_signature |
Michelson_v1_primitives.T_int | Michelson_v1_primitives.T_nat |
Michelson_v1_primitives.T_string | Michelson_v1_primitives.T_bytes |
Michelson_v1_primitives.T_mutez | Michelson_v1_primitives.T_bool |
Michelson_v1_primitives.T_key | Michelson_v1_primitives.T_key_hash |
Michelson_v1_primitives.T_timestamp | Michelson_v1_primitives.T_address
| Michelson_v1_primitives.T_tx_rollup_l2_address |
Michelson_v1_primitives.T_chain_id | Michelson_v1_primitives.T_operation
| Michelson_v1_primitives.T_never) as prim) l_value _, _, _) ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, prim, 0, (List.length l_value)))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.T_set | Michelson_v1_primitives.T_list |
Michelson_v1_primitives.T_option | Michelson_v1_primitives.T_contract |
Michelson_v1_primitives.T_ticket) as prim) l_value _, _, _) ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, prim, 1, (List.length l_value)))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.T_pair | Michelson_v1_primitives.T_or |
Michelson_v1_primitives.T_map | Michelson_v1_primitives.T_lambda) as
prim) l_value _, _, _) ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, prim, 2, (List.length l_value)))
| (expr, _, _) ⇒
Error_monad.error_value
(unexpected expr nil Michelson_v1_primitives.Type_namespace
[
Michelson_v1_primitives.T_bls12_381_fr;
Michelson_v1_primitives.T_bls12_381_g1;
Michelson_v1_primitives.T_bls12_381_g2;
Michelson_v1_primitives.T_bool;
Michelson_v1_primitives.T_bytes;
Michelson_v1_primitives.T_chain_id;
Michelson_v1_primitives.T_contract;
Michelson_v1_primitives.T_int;
Michelson_v1_primitives.T_key;
Michelson_v1_primitives.T_key_hash;
Michelson_v1_primitives.T_lambda;
Michelson_v1_primitives.T_list;
Michelson_v1_primitives.T_map;
Michelson_v1_primitives.T_mutez;
Michelson_v1_primitives.T_nat;
Michelson_v1_primitives.T_never;
Michelson_v1_primitives.T_operation;
Michelson_v1_primitives.T_option;
Michelson_v1_primitives.T_or;
Michelson_v1_primitives.T_pair;
Michelson_v1_primitives.T_set;
Michelson_v1_primitives.T_signature;
Michelson_v1_primitives.T_string;
Michelson_v1_primitives.T_ticket;
Michelson_v1_primitives.T_timestamp;
Michelson_v1_primitives.T_tx_rollup_l2_address;
Michelson_v1_primitives.T_unit
])
end
with parse_comparable_ty_aux
(ctxt : Alpha_context.context) (stack_depth : int)
(node_value : Alpha_context.Script.node) {struct stack_depth}
: M? (ex_comparable_ty × Alpha_context.context) :=
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_ty_aux ctxt (stack_depth +i 1) false false false false false
Don't_parse_entrypoints node_value in
match Script_typed_ir.is_comparable t_value with
| Dependent_bool.Yes ⇒ return? ((Ex_comparable_ty t_value), ctxt)
| Dependent_bool.No ⇒
Error_monad.error_value
(Build_extensible "Comparable_type_expected"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
((location node_value), (Micheline.strip_locations node_value)))
end
with parse_passable_ty_aux_with_ret {ret : Set}
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
{struct stack_depth}
: parse_ty_ret → Alpha_context.Script.node →
M? (ret × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy true false true true
with parse_any_ty_aux
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
{struct stack_depth}
: Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy true true true true
Don't_parse_entrypoints
with parse_big_map_ty
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(big_map_loc : Alpha_context.Script.location)
(args :
list
(Micheline.node Alpha_context.Script.location Alpha_context.Script.prim))
(map_annot : Micheline.annot) {struct args}
: M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.parse_type_cycle
in
match args with
| cons key_ty (cons value_ty []) ⇒
let? '(Ex_comparable_ty key_ty, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) key_ty in
let? '(Script_typed_ir.Ex_ty value_ty, ctxt) :=
parse_big_map_value_ty_aux ctxt (stack_depth +i 1) legacy value_ty in
let? '_ := Script_ir_annot.check_type_annot big_map_loc map_annot in
let? big_map_ty := Script_typed_ir.big_map_t big_map_loc key_ty value_ty in
return? ((Script_typed_ir.Ex_ty big_map_ty), ctxt)
| args ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(big_map_loc, Michelson_v1_primitives.T_big_map, 2, (List.length args)))
end
with parse_big_map_value_ty_aux
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(value_ty :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
{struct stack_depth} : M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy false false legacy true
Don't_parse_entrypoints value_ty.
Definition parse_packable_ty_aux
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(node_value : Alpha_context.Script.node)
: M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy false false legacy false
Don't_parse_entrypoints node_value.
Definition parse_view_input_ty
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(node_value : Alpha_context.Script.node)
: M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy false false true false
Don't_parse_entrypoints node_value.
Definition parse_view_output_ty
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(node_value : Alpha_context.Script.node)
: M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy false false true false
Don't_parse_entrypoints node_value.
Definition parse_normal_storage_ty
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(node_value : Alpha_context.Script.node)
: M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
parse_ty_aux ctxt stack_depth legacy true false legacy true
Don't_parse_entrypoints node_value.
Definition parse_storage_ty
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(node_value : Alpha_context.Script.node)
: M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
match
(node_value,
match node_value with
|
Micheline.Prim loc_value Michelson_v1_primitives.T_pair
(cons
(Micheline.Prim big_map_loc Michelson_v1_primitives.T_big_map args
map_annot) (cons remaining_storage [])) storage_annot ⇒ legacy
| _ ⇒ false
end) with
|
(Micheline.Prim loc_value Michelson_v1_primitives.T_pair
(cons
(Micheline.Prim big_map_loc Michelson_v1_primitives.T_big_map args
map_annot) (cons remaining_storage [])) storage_annot, true) ⇒
match
(storage_annot,
match storage_annot with
| cons single [] ⇒
((String.length single) >i 0) &&
(Compare.Char.(Compare.S.op_eq) (String.get single 0) "%" % char)
| _ ⇒ false
end) with
| ([], _) ⇒ parse_normal_storage_ty ctxt stack_depth legacy node_value
| (cons single [], true) ⇒
parse_normal_storage_ty ctxt stack_depth legacy node_value
| (_, _) ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.parse_type_cycle in
let? '(Script_typed_ir.Ex_ty big_map_ty, ctxt) :=
parse_big_map_ty ctxt (stack_depth +i 1) legacy big_map_loc args
map_annot in
let? '(Script_typed_ir.Ex_ty remaining_storage, ctxt) :=
parse_normal_storage_ty ctxt (stack_depth +i 1) legacy remaining_storage
in
let? '_ :=
Script_ir_annot.check_composed_type_annot loc_value storage_annot in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.pair_t loc_value big_map_ty remaining_storage in
return? ((Script_typed_ir.Ex_ty ty_value), ctxt)
end
| (_, _) ⇒ parse_normal_storage_ty ctxt stack_depth legacy node_value
end.
Definition check_packable
(legacy : bool) (loc_value : Alpha_context.Script.location)
(root_value : Script_typed_ir.ty) : M? unit :=
let fix check (function_parameter : Script_typed_ir.ty) : M? unit :=
match
(function_parameter,
match function_parameter with
| Script_typed_ir.Contract_t _ _ ⇒ legacy
| _ ⇒ false
end) with
| (Script_typed_ir.Big_map_t _ _ _, _) ⇒
Error_monad.error_value
(Build_extensible "Unexpected_lazy_storage"
Alpha_context.Script.location loc_value)
| (Script_typed_ir.Sapling_state_t _, _) ⇒
Error_monad.error_value
(Build_extensible "Unexpected_lazy_storage"
Alpha_context.Script.location loc_value)
| (Script_typed_ir.Operation_t, _) ⇒
Error_monad.error_value
(Build_extensible "Unexpected_operation" Alpha_context.Script.location
loc_value)
| (Script_typed_ir.Unit_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Int_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Nat_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Signature_t, _) ⇒ Result.return_unit
| (Script_typed_ir.String_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Bytes_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Mutez_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Key_hash_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Key_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Timestamp_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Address_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Tx_rollup_l2_address_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Bool_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Chain_id_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Never_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Set_t _ _, _) ⇒ Result.return_unit
| (Script_typed_ir.Ticket_t _ _, _) ⇒
Error_monad.error_value
(Build_extensible "Unexpected_ticket" Alpha_context.Script.location
loc_value)
| (Script_typed_ir.Lambda_t _ _ _, _) ⇒ Result.return_unit
| (Script_typed_ir.Bls12_381_g1_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Bls12_381_g2_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Bls12_381_fr_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Pair_t l_ty r_ty _ _, _) ⇒
let? '_ := check l_ty in
check r_ty
| (Script_typed_ir.Union_t l_ty r_ty _ _, _) ⇒
let? '_ := check l_ty in
check r_ty
| (Script_typed_ir.Option_t v_ty _ _, _) ⇒ check v_ty
| (Script_typed_ir.List_t elt_ty _, _) ⇒ check elt_ty
| (Script_typed_ir.Map_t _ elt_ty _, _) ⇒ check elt_ty
| (Script_typed_ir.Contract_t _ _, true) ⇒ Result.return_unit
| (Script_typed_ir.Contract_t _ _, _) ⇒
Error_monad.error_value
(Build_extensible "Unexpected_contract" Alpha_context.Script.location
loc_value)
| (Script_typed_ir.Sapling_transaction_t _, _) ⇒ return? tt
| (Script_typed_ir.Sapling_transaction_deprecated_t _, _) ⇒ return? tt
| (Script_typed_ir.Chest_key_t, _) ⇒ Result.return_unit
| (Script_typed_ir.Chest_t, _) ⇒ Result.return_unit
end in
check root_value.
Module toplevel.
Record record : Set := Build {
code_field : Alpha_context.Script.node;
arg_type : Alpha_context.Script.node;
storage_type : Alpha_context.Script.node;
views : Script_typed_ir.view_map;
}.
Definition with_code_field code_field (r : record) :=
Build code_field r.(arg_type) r.(storage_type) r.(views).
Definition with_arg_type arg_type (r : record) :=
Build r.(code_field) arg_type r.(storage_type) r.(views).
Definition with_storage_type storage_type (r : record) :=
Build r.(code_field) r.(arg_type) storage_type r.(views).
Definition with_views views (r : record) :=
Build r.(code_field) r.(arg_type) r.(storage_type) views.
End toplevel.
Definition toplevel := toplevel.record.
Records for the constructor parameters
Module ConstructorRecords_code.
Module code.
Module Code.
Record record {code arg_type storage_type views entrypoints code_size :
Set} : Set := Build {
code : code;
arg_type : arg_type;
storage_type : storage_type;
views : views;
entrypoints : entrypoints;
code_size : code_size;
}.
Arguments record : clear implicits.
Definition with_code
{t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size}
code
(r :
record t_code t_arg_type t_storage_type t_views t_entrypoints
t_code_size) :=
Build t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size
code r.(arg_type) r.(storage_type) r.(views) r.(entrypoints)
r.(code_size).
Definition with_arg_type
{t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size}
arg_type
(r :
record t_code t_arg_type t_storage_type t_views t_entrypoints
t_code_size) :=
Build t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size
r.(code) arg_type r.(storage_type) r.(views) r.(entrypoints)
r.(code_size).
Definition with_storage_type
{t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size}
storage_type
(r :
record t_code t_arg_type t_storage_type t_views t_entrypoints
t_code_size) :=
Build t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size
r.(code) r.(arg_type) storage_type r.(views) r.(entrypoints)
r.(code_size).
Definition with_views
{t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size}
views
(r :
record t_code t_arg_type t_storage_type t_views t_entrypoints
t_code_size) :=
Build t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size
r.(code) r.(arg_type) r.(storage_type) views r.(entrypoints)
r.(code_size).
Definition with_entrypoints
{t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size}
entrypoints
(r :
record t_code t_arg_type t_storage_type t_views t_entrypoints
t_code_size) :=
Build t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size
r.(code) r.(arg_type) r.(storage_type) r.(views) entrypoints
r.(code_size).
Definition with_code_size
{t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size}
code_size
(r :
record t_code t_arg_type t_storage_type t_views t_entrypoints
t_code_size) :=
Build t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size
r.(code) r.(arg_type) r.(storage_type) r.(views) r.(entrypoints)
code_size.
End Code.
Definition Code_skeleton := Code.record.
End code.
End ConstructorRecords_code.
Import ConstructorRecords_code.
Reserved Notation "'code.Code".
Inductive code : Set :=
| Code : 'code.Code → code
where "'code.Code" :=
(code.Code_skeleton Script_typed_ir.lambda Script_typed_ir.ty
Script_typed_ir.ty Script_typed_ir.view_map Script_typed_ir.entrypoints
Cache_memory_helpers.sint).
Module code.
Include ConstructorRecords_code.code.
Definition Code := 'code.Code.
End code.
Inductive ex_script : Set :=
| Ex_script : ∀ {c : Set}, Script_typed_ir.script c → ex_script.
Inductive ex_code : Set :=
| Ex_code : code → ex_code.
Module code.
Module Code.
Record record {code arg_type storage_type views entrypoints code_size :
Set} : Set := Build {
code : code;
arg_type : arg_type;
storage_type : storage_type;
views : views;
entrypoints : entrypoints;
code_size : code_size;
}.
Arguments record : clear implicits.
Definition with_code
{t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size}
code
(r :
record t_code t_arg_type t_storage_type t_views t_entrypoints
t_code_size) :=
Build t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size
code r.(arg_type) r.(storage_type) r.(views) r.(entrypoints)
r.(code_size).
Definition with_arg_type
{t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size}
arg_type
(r :
record t_code t_arg_type t_storage_type t_views t_entrypoints
t_code_size) :=
Build t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size
r.(code) arg_type r.(storage_type) r.(views) r.(entrypoints)
r.(code_size).
Definition with_storage_type
{t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size}
storage_type
(r :
record t_code t_arg_type t_storage_type t_views t_entrypoints
t_code_size) :=
Build t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size
r.(code) r.(arg_type) storage_type r.(views) r.(entrypoints)
r.(code_size).
Definition with_views
{t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size}
views
(r :
record t_code t_arg_type t_storage_type t_views t_entrypoints
t_code_size) :=
Build t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size
r.(code) r.(arg_type) r.(storage_type) views r.(entrypoints)
r.(code_size).
Definition with_entrypoints
{t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size}
entrypoints
(r :
record t_code t_arg_type t_storage_type t_views t_entrypoints
t_code_size) :=
Build t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size
r.(code) r.(arg_type) r.(storage_type) r.(views) entrypoints
r.(code_size).
Definition with_code_size
{t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size}
code_size
(r :
record t_code t_arg_type t_storage_type t_views t_entrypoints
t_code_size) :=
Build t_code t_arg_type t_storage_type t_views t_entrypoints t_code_size
r.(code) r.(arg_type) r.(storage_type) r.(views) r.(entrypoints)
code_size.
End Code.
Definition Code_skeleton := Code.record.
End code.
End ConstructorRecords_code.
Import ConstructorRecords_code.
Reserved Notation "'code.Code".
Inductive code : Set :=
| Code : 'code.Code → code
where "'code.Code" :=
(code.Code_skeleton Script_typed_ir.lambda Script_typed_ir.ty
Script_typed_ir.ty Script_typed_ir.view_map Script_typed_ir.entrypoints
Cache_memory_helpers.sint).
Module code.
Include ConstructorRecords_code.code.
Definition Code := 'code.Code.
End code.
Inductive ex_script : Set :=
| Ex_script : ∀ {c : Set}, Script_typed_ir.script c → ex_script.
Inductive ex_code : Set :=
| Ex_code : code → ex_code.
Records for the constructor parameters
Module ConstructorRecords_typed_view.
Module typed_view.
Module Typed_view.
Record record {input_ty output_ty kinstr original_code_expr : Set} : Set := Build {
input_ty : input_ty;
output_ty : output_ty;
kinstr : kinstr;
original_code_expr : original_code_expr;
}.
Arguments record : clear implicits.
Definition with_input_ty
{t_input_ty t_output_ty t_kinstr t_original_code_expr} input_ty
(r : record t_input_ty t_output_ty t_kinstr t_original_code_expr) :=
Build t_input_ty t_output_ty t_kinstr t_original_code_expr input_ty
r.(output_ty) r.(kinstr) r.(original_code_expr).
Definition with_output_ty
{t_input_ty t_output_ty t_kinstr t_original_code_expr} output_ty
(r : record t_input_ty t_output_ty t_kinstr t_original_code_expr) :=
Build t_input_ty t_output_ty t_kinstr t_original_code_expr r.(input_ty)
output_ty r.(kinstr) r.(original_code_expr).
Definition with_kinstr
{t_input_ty t_output_ty t_kinstr t_original_code_expr} kinstr
(r : record t_input_ty t_output_ty t_kinstr t_original_code_expr) :=
Build t_input_ty t_output_ty t_kinstr t_original_code_expr r.(input_ty)
r.(output_ty) kinstr r.(original_code_expr).
Definition with_original_code_expr
{t_input_ty t_output_ty t_kinstr t_original_code_expr}
original_code_expr
(r : record t_input_ty t_output_ty t_kinstr t_original_code_expr) :=
Build t_input_ty t_output_ty t_kinstr t_original_code_expr r.(input_ty)
r.(output_ty) r.(kinstr) original_code_expr.
End Typed_view.
Definition Typed_view_skeleton := Typed_view.record.
End typed_view.
End ConstructorRecords_typed_view.
Import ConstructorRecords_typed_view.
Reserved Notation "'typed_view.Typed_view".
Inductive typed_view : Set :=
| Typed_view : 'typed_view.Typed_view → typed_view
where "'typed_view.Typed_view" :=
(typed_view.Typed_view_skeleton Script_typed_ir.ty Script_typed_ir.ty
Script_typed_ir.kinstr Alpha_context.Script.node).
Module typed_view.
Include ConstructorRecords_typed_view.typed_view.
Definition Typed_view := 'typed_view.Typed_view.
End typed_view.
Definition typed_view_map : Set :=
Script_typed_ir.map Script_string.t typed_view.
Inductive dig_proof_argument : Set :=
| Dig_proof_argument :
Script_typed_ir.stack_prefix_preservation_witness → Script_typed_ir.ty →
Script_typed_ir.stack_ty → dig_proof_argument.
Inductive dug_proof_argument : Set :=
| Dug_proof_argument :
Script_typed_ir.stack_prefix_preservation_witness × Script_typed_ir.stack_ty
→ dug_proof_argument.
Inductive dipn_proof_argument : Set :=
| Dipn_proof_argument :
Script_typed_ir.stack_prefix_preservation_witness → Alpha_context.context →
descr → Script_typed_ir.stack_ty → dipn_proof_argument.
Inductive dropn_proof_argument : Set :=
| Dropn_proof_argument :
Script_typed_ir.stack_prefix_preservation_witness →
Script_typed_ir.stack_ty → dropn_proof_argument.
Inductive comb_proof_argument : Set :=
| Comb_proof_argument :
Script_typed_ir.comb_gadt_witness → Script_typed_ir.stack_ty →
comb_proof_argument.
Inductive uncomb_proof_argument : Set :=
| Uncomb_proof_argument :
Script_typed_ir.uncomb_gadt_witness → Script_typed_ir.stack_ty →
uncomb_proof_argument.
Inductive comb_get_proof_argument : Set :=
| Comb_get_proof_argument :
Script_typed_ir.comb_get_gadt_witness → Script_typed_ir.ty →
comb_get_proof_argument.
Inductive comb_set_proof_argument : Set :=
| Comb_set_proof_argument :
Script_typed_ir.comb_set_gadt_witness → Script_typed_ir.ty →
comb_set_proof_argument.
Inductive dup_n_proof_argument : Set :=
| Dup_n_proof_argument :
Script_typed_ir.dup_n_gadt_witness → Script_typed_ir.ty →
dup_n_proof_argument.
Fixpoint make_dug_proof_argument
(loc_value : Alpha_context.Script.location) (n_value : int)
(x_value : Script_typed_ir.ty) (stk : Script_typed_ir.stack_ty)
: option dug_proof_argument :=
match (n_value, stk) with
| (0, rest) ⇒
Some
(Dug_proof_argument
(Script_typed_ir.KRest, (Script_typed_ir.Item_t x_value rest)))
| (n_value, Script_typed_ir.Item_t v_value rest) ⇒
Option.map
(fun (function_parameter : dug_proof_argument) ⇒
let 'Dug_proof_argument (n', aft') := function_parameter in
Dug_proof_argument
((Script_typed_ir.KPrefix loc_value v_value n'),
(Script_typed_ir.Item_t v_value aft')))
(make_dug_proof_argument loc_value (n_value -i 1) x_value rest)
| (_, _) ⇒ None
end.
Fixpoint make_comb_get_proof_argument
(n_value : int) (ty_value : Script_typed_ir.ty)
: option comb_get_proof_argument :=
match (n_value, ty_value) with
| (0, value_ty) ⇒
Some (Comb_get_proof_argument Script_typed_ir.Comb_get_zero value_ty)
| (1, Script_typed_ir.Pair_t hd_ty _ _annot _) ⇒
Some (Comb_get_proof_argument Script_typed_ir.Comb_get_one hd_ty)
| (n_value, Script_typed_ir.Pair_t _ tl_ty _annot _) ⇒
Option.map
(fun (function_parameter : comb_get_proof_argument) ⇒
let 'Comb_get_proof_argument comb_get_left_witness ty' :=
function_parameter in
Comb_get_proof_argument
(Script_typed_ir.Comb_get_plus_two comb_get_left_witness) ty')
(make_comb_get_proof_argument (n_value -i 2) tl_ty)
| _ ⇒ None
end.
Fixpoint make_comb_set_proof_argument
(ctxt : Alpha_context.context) (stack_ty : Script_typed_ir.stack_ty)
(loc_value : Alpha_context.Script.location) (n_value : int)
(value_ty : Script_typed_ir.ty) (ty_value : Script_typed_ir.ty)
: M? comb_set_proof_argument :=
match (n_value, ty_value) with
| (0, _) ⇒
return? (Comb_set_proof_argument Script_typed_ir.Comb_set_zero value_ty)
| (1, Script_typed_ir.Pair_t _hd_ty tl_ty _ _) ⇒
let? 'Script_typed_ir.Ty_ex_c after_ty :=
Script_typed_ir.pair_t loc_value value_ty tl_ty in
return? (Comb_set_proof_argument Script_typed_ir.Comb_set_one after_ty)
| (n_value, Script_typed_ir.Pair_t hd_ty tl_ty _ _) ⇒
let? 'Comb_set_proof_argument comb_set_left_witness tl_ty' :=
make_comb_set_proof_argument ctxt stack_ty loc_value (n_value -i 2)
value_ty tl_ty in
let? 'Script_typed_ir.Ty_ex_c after_ty :=
Script_typed_ir.pair_t loc_value hd_ty tl_ty' in
return?
(Comb_set_proof_argument
(Script_typed_ir.Comb_set_plus_two comb_set_left_witness) after_ty)
| _ ⇒
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_ty in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_UPDATE, 2, whole_stack))
end.
Module typed_view.
Module Typed_view.
Record record {input_ty output_ty kinstr original_code_expr : Set} : Set := Build {
input_ty : input_ty;
output_ty : output_ty;
kinstr : kinstr;
original_code_expr : original_code_expr;
}.
Arguments record : clear implicits.
Definition with_input_ty
{t_input_ty t_output_ty t_kinstr t_original_code_expr} input_ty
(r : record t_input_ty t_output_ty t_kinstr t_original_code_expr) :=
Build t_input_ty t_output_ty t_kinstr t_original_code_expr input_ty
r.(output_ty) r.(kinstr) r.(original_code_expr).
Definition with_output_ty
{t_input_ty t_output_ty t_kinstr t_original_code_expr} output_ty
(r : record t_input_ty t_output_ty t_kinstr t_original_code_expr) :=
Build t_input_ty t_output_ty t_kinstr t_original_code_expr r.(input_ty)
output_ty r.(kinstr) r.(original_code_expr).
Definition with_kinstr
{t_input_ty t_output_ty t_kinstr t_original_code_expr} kinstr
(r : record t_input_ty t_output_ty t_kinstr t_original_code_expr) :=
Build t_input_ty t_output_ty t_kinstr t_original_code_expr r.(input_ty)
r.(output_ty) kinstr r.(original_code_expr).
Definition with_original_code_expr
{t_input_ty t_output_ty t_kinstr t_original_code_expr}
original_code_expr
(r : record t_input_ty t_output_ty t_kinstr t_original_code_expr) :=
Build t_input_ty t_output_ty t_kinstr t_original_code_expr r.(input_ty)
r.(output_ty) r.(kinstr) original_code_expr.
End Typed_view.
Definition Typed_view_skeleton := Typed_view.record.
End typed_view.
End ConstructorRecords_typed_view.
Import ConstructorRecords_typed_view.
Reserved Notation "'typed_view.Typed_view".
Inductive typed_view : Set :=
| Typed_view : 'typed_view.Typed_view → typed_view
where "'typed_view.Typed_view" :=
(typed_view.Typed_view_skeleton Script_typed_ir.ty Script_typed_ir.ty
Script_typed_ir.kinstr Alpha_context.Script.node).
Module typed_view.
Include ConstructorRecords_typed_view.typed_view.
Definition Typed_view := 'typed_view.Typed_view.
End typed_view.
Definition typed_view_map : Set :=
Script_typed_ir.map Script_string.t typed_view.
Inductive dig_proof_argument : Set :=
| Dig_proof_argument :
Script_typed_ir.stack_prefix_preservation_witness → Script_typed_ir.ty →
Script_typed_ir.stack_ty → dig_proof_argument.
Inductive dug_proof_argument : Set :=
| Dug_proof_argument :
Script_typed_ir.stack_prefix_preservation_witness × Script_typed_ir.stack_ty
→ dug_proof_argument.
Inductive dipn_proof_argument : Set :=
| Dipn_proof_argument :
Script_typed_ir.stack_prefix_preservation_witness → Alpha_context.context →
descr → Script_typed_ir.stack_ty → dipn_proof_argument.
Inductive dropn_proof_argument : Set :=
| Dropn_proof_argument :
Script_typed_ir.stack_prefix_preservation_witness →
Script_typed_ir.stack_ty → dropn_proof_argument.
Inductive comb_proof_argument : Set :=
| Comb_proof_argument :
Script_typed_ir.comb_gadt_witness → Script_typed_ir.stack_ty →
comb_proof_argument.
Inductive uncomb_proof_argument : Set :=
| Uncomb_proof_argument :
Script_typed_ir.uncomb_gadt_witness → Script_typed_ir.stack_ty →
uncomb_proof_argument.
Inductive comb_get_proof_argument : Set :=
| Comb_get_proof_argument :
Script_typed_ir.comb_get_gadt_witness → Script_typed_ir.ty →
comb_get_proof_argument.
Inductive comb_set_proof_argument : Set :=
| Comb_set_proof_argument :
Script_typed_ir.comb_set_gadt_witness → Script_typed_ir.ty →
comb_set_proof_argument.
Inductive dup_n_proof_argument : Set :=
| Dup_n_proof_argument :
Script_typed_ir.dup_n_gadt_witness → Script_typed_ir.ty →
dup_n_proof_argument.
Fixpoint make_dug_proof_argument
(loc_value : Alpha_context.Script.location) (n_value : int)
(x_value : Script_typed_ir.ty) (stk : Script_typed_ir.stack_ty)
: option dug_proof_argument :=
match (n_value, stk) with
| (0, rest) ⇒
Some
(Dug_proof_argument
(Script_typed_ir.KRest, (Script_typed_ir.Item_t x_value rest)))
| (n_value, Script_typed_ir.Item_t v_value rest) ⇒
Option.map
(fun (function_parameter : dug_proof_argument) ⇒
let 'Dug_proof_argument (n', aft') := function_parameter in
Dug_proof_argument
((Script_typed_ir.KPrefix loc_value v_value n'),
(Script_typed_ir.Item_t v_value aft')))
(make_dug_proof_argument loc_value (n_value -i 1) x_value rest)
| (_, _) ⇒ None
end.
Fixpoint make_comb_get_proof_argument
(n_value : int) (ty_value : Script_typed_ir.ty)
: option comb_get_proof_argument :=
match (n_value, ty_value) with
| (0, value_ty) ⇒
Some (Comb_get_proof_argument Script_typed_ir.Comb_get_zero value_ty)
| (1, Script_typed_ir.Pair_t hd_ty _ _annot _) ⇒
Some (Comb_get_proof_argument Script_typed_ir.Comb_get_one hd_ty)
| (n_value, Script_typed_ir.Pair_t _ tl_ty _annot _) ⇒
Option.map
(fun (function_parameter : comb_get_proof_argument) ⇒
let 'Comb_get_proof_argument comb_get_left_witness ty' :=
function_parameter in
Comb_get_proof_argument
(Script_typed_ir.Comb_get_plus_two comb_get_left_witness) ty')
(make_comb_get_proof_argument (n_value -i 2) tl_ty)
| _ ⇒ None
end.
Fixpoint make_comb_set_proof_argument
(ctxt : Alpha_context.context) (stack_ty : Script_typed_ir.stack_ty)
(loc_value : Alpha_context.Script.location) (n_value : int)
(value_ty : Script_typed_ir.ty) (ty_value : Script_typed_ir.ty)
: M? comb_set_proof_argument :=
match (n_value, ty_value) with
| (0, _) ⇒
return? (Comb_set_proof_argument Script_typed_ir.Comb_set_zero value_ty)
| (1, Script_typed_ir.Pair_t _hd_ty tl_ty _ _) ⇒
let? 'Script_typed_ir.Ty_ex_c after_ty :=
Script_typed_ir.pair_t loc_value value_ty tl_ty in
return? (Comb_set_proof_argument Script_typed_ir.Comb_set_one after_ty)
| (n_value, Script_typed_ir.Pair_t hd_ty tl_ty _ _) ⇒
let? 'Comb_set_proof_argument comb_set_left_witness tl_ty' :=
make_comb_set_proof_argument ctxt stack_ty loc_value (n_value -i 2)
value_ty tl_ty in
let? 'Script_typed_ir.Ty_ex_c after_ty :=
Script_typed_ir.pair_t loc_value hd_ty tl_ty' in
return?
(Comb_set_proof_argument
(Script_typed_ir.Comb_set_plus_two comb_set_left_witness) after_ty)
| _ ⇒
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_ty in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_UPDATE, 2, whole_stack))
end.
Records for the constructor parameters
Module ConstructorRecords_ex_ty_cstr.
Module ex_ty_cstr.
Module Ex_ty_cstr.
Record record {ty construct original_type_expr : Set} : Set := Build {
ty : ty;
construct : construct;
original_type_expr : original_type_expr;
}.
Arguments record : clear implicits.
Definition with_ty {t_ty t_construct t_original_type_expr} ty
(r : record t_ty t_construct t_original_type_expr) :=
Build t_ty t_construct t_original_type_expr ty r.(construct)
r.(original_type_expr).
Definition with_construct {t_ty t_construct t_original_type_expr}
construct (r : record t_ty t_construct t_original_type_expr) :=
Build t_ty t_construct t_original_type_expr r.(ty) construct
r.(original_type_expr).
Definition with_original_type_expr {t_ty t_construct t_original_type_expr}
original_type_expr (r : record t_ty t_construct t_original_type_expr) :=
Build t_ty t_construct t_original_type_expr r.(ty) r.(construct)
original_type_expr.
End Ex_ty_cstr.
Definition Ex_ty_cstr_skeleton := Ex_ty_cstr.record.
End ex_ty_cstr.
End ConstructorRecords_ex_ty_cstr.
Import ConstructorRecords_ex_ty_cstr.
Reserved Notation "'ex_ty_cstr.Ex_ty_cstr".
Inductive ex_ty_cstr (a : Set) : Set :=
| Ex_ty_cstr : ∀ {b : Set}, 'ex_ty_cstr.Ex_ty_cstr a b → ex_ty_cstr a
where "'ex_ty_cstr.Ex_ty_cstr" :=
(fun (t_a t_b : Set) ⇒ ex_ty_cstr.Ex_ty_cstr_skeleton Script_typed_ir.ty
(t_b → t_a) Alpha_context.Script.node).
Module ex_ty_cstr.
Include ConstructorRecords_ex_ty_cstr.ex_ty_cstr.
Definition Ex_ty_cstr := 'ex_ty_cstr.Ex_ty_cstr.
End ex_ty_cstr.
Arguments Ex_ty_cstr {_ _}.
#[bypass_check(guard)]
Definition find_entrypoint {error_context full error_trace : Set}
(error_details : Script_tc_errors.error_details error_context)
(full_value : Script_typed_ir.ty) (entrypoints : Script_typed_ir.entrypoints)
(entrypoint : Alpha_context.Entrypoint.t)
: Gas_monad.t (ex_ty_cstr full) error_trace :=
let fix find_entrypoint {t : Set}
(ty_value : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints_node)
(entrypoint : Alpha_context.Entrypoint.t) {struct ty_value}
: Gas_monad.t (ex_ty_cstr t) unit :=
Gas_monad.Syntax.op_letstar
(Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle)
(fun function_parameter ⇒
let '_ := function_parameter in
match
((ty_value, entrypoints),
match (ty_value, entrypoints) with
|
(_, {|
Script_typed_ir.entrypoints_node.at_node :=
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr
:=
original_type_expr
|}
|}) ⇒ Alpha_context.Entrypoint.op_eq name entrypoint
| _ ⇒ false
end) with
|
((_, {|
Script_typed_ir.entrypoints_node.at_node :=
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr
:=
original_type_expr
|}
|}), true) ⇒
let '[original_type_expr, name] :=
cast [Alpha_context.Script.node ** Alpha_context.Entrypoint.t]
[original_type_expr, name] in
Gas_monad.Syntax._return
(Ex_ty_cstr
{| ex_ty_cstr.Ex_ty_cstr.ty := ty_value;
ex_ty_cstr.Ex_ty_cstr.construct := fun (e_value : t) ⇒ e_value;
ex_ty_cstr.Ex_ty_cstr.original_type_expr := original_type_expr;
|})
|
((Script_typed_ir.Union_t tl tr _ _, {|
Script_typed_ir.entrypoints_node.nested :=
Script_typed_ir.Entrypoints_Union {|
Script_typed_ir.nested_entrypoints.Entrypoints_Union._left := _left;
Script_typed_ir.nested_entrypoints.Entrypoints_Union._right
:= _right
|}
|}), _) ⇒
let 'existT _ [__1, __0] [_right, _left, tr, tl] :=
cast_exists (Es := [Set ** Set])
(fun '[__1, __0] ⇒
[Script_typed_ir.entrypoints_node **
Script_typed_ir.entrypoints_node ** Script_typed_ir.ty **
Script_typed_ir.ty]) [_right, _left, tr, tl] in
cast (Gas_monad.t (ex_ty_cstr t) unit)
(Gas_monad.bind_recover (find_entrypoint tl _left entrypoint)
(fun (function_parameter :
Pervasives.result (ex_ty_cstr __0) unit) ⇒
match function_parameter with
|
Pervasives.Ok
(Ex_ty_cstr {|
ex_ty_cstr.Ex_ty_cstr.ty := ty_value;
ex_ty_cstr.Ex_ty_cstr.construct := construct;
ex_ty_cstr.Ex_ty_cstr.original_type_expr :=
original_type_expr
|}) ⇒
let 'existT _ __Ex_ty_cstr_'b
[original_type_expr, construct, ty_value] :=
cast_exists (Es := Set)
(fun __Ex_ty_cstr_'b ⇒
[Alpha_context.Script.node ** __Ex_ty_cstr_'b → __0 **
Script_typed_ir.ty])
[original_type_expr, construct, ty_value] in
Gas_monad.Syntax._return
(Ex_ty_cstr
{| ex_ty_cstr.Ex_ty_cstr.ty := ty_value;
ex_ty_cstr.Ex_ty_cstr.construct :=
fun (e_value : __Ex_ty_cstr_'b) ⇒
Script_typed_ir.L (construct e_value);
ex_ty_cstr.Ex_ty_cstr.original_type_expr :=
original_type_expr; |})
| Pervasives.Error _ ⇒
Gas_monad.Syntax.op_letplus
((find_entrypoint tr _right entrypoint) :
Gas_monad.t (ex_ty_cstr __1) unit)
(fun x_value ⇒
let
'Ex_ty_cstr {|
ex_ty_cstr.Ex_ty_cstr.ty := ty_value;
ex_ty_cstr.Ex_ty_cstr.construct := construct;
ex_ty_cstr.Ex_ty_cstr.original_type_expr :=
original_type_expr
|} := x_value in
let 'existT _ __Ex_ty_cstr_'b1
[original_type_expr, construct, ty_value] :=
cast_exists (Es := Set)
(fun __Ex_ty_cstr_'b1 ⇒
[Alpha_context.Script.node **
__Ex_ty_cstr_'b1 → __1 ** Script_typed_ir.ty])
[original_type_expr, construct, ty_value] in
Ex_ty_cstr
{| ex_ty_cstr.Ex_ty_cstr.ty := ty_value;
ex_ty_cstr.Ex_ty_cstr.construct :=
fun (e_value : __Ex_ty_cstr_'b1) ⇒
Script_typed_ir.R (construct e_value);
ex_ty_cstr.Ex_ty_cstr.original_type_expr :=
original_type_expr; |})
end))
|
((_, {|
Script_typed_ir.entrypoints_node.nested := Script_typed_ir.Entrypoints_None
|}), _) ⇒ Gas_monad.of_result (Pervasives.Error tt)
| _ ⇒ unreachable_gadt_branch
end) in
let '{|
Script_typed_ir.entrypoints.root := root_value;
Script_typed_ir.entrypoints.original_type_expr := original_type_expr
|} := entrypoints in
Gas_monad.bind_recover (find_entrypoint full_value root_value entrypoint)
(fun (function_parameter : Pervasives.result (ex_ty_cstr full) unit) ⇒
match function_parameter with
| Pervasives.Ok f_t ⇒ Gas_monad.Syntax._return f_t
| Pervasives.Error _ ⇒
if Alpha_context.Entrypoint.is_default entrypoint then
Gas_monad.Syntax._return
(Ex_ty_cstr
{| ex_ty_cstr.Ex_ty_cstr.ty := full_value;
ex_ty_cstr.Ex_ty_cstr.construct :=
fun (e_value : full) ⇒ e_value;
ex_ty_cstr.Ex_ty_cstr.original_type_expr := original_type_expr;
|})
else
Gas_monad.of_result
(Pervasives.Error
match error_details with
| Script_tc_errors.Fast ⇒
cast error_trace Script_tc_errors.Inconsistent_types_fast
| Script_tc_errors.Informative _ ⇒
cast error_trace
(Error_monad.trace_of_error
(Build_extensible "No_such_entrypoint"
Alpha_context.Entrypoint.t entrypoint))
end)
end).
Definition find_entrypoint_for_type {full : Set} {error_trace : Set}
(error_details : Script_tc_errors.error_details Alpha_context.Script.location)
(full_value : Script_typed_ir.ty) (expected : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints)
(entrypoint : Alpha_context.Entrypoint.t)
: Gas_monad.t (Alpha_context.Entrypoint.t × Script_typed_ir.ty) error_trace :=
Gas_monad.Syntax.op_letstar
((find_entrypoint error_details full_value entrypoints entrypoint) :
Gas_monad.t (ex_ty_cstr full) error_trace)
(fun res ⇒
let 'Ex_ty_cstr {| ex_ty_cstr.Ex_ty_cstr.ty := ty_value |} := res in
match
(entrypoints.(Script_typed_ir.entrypoints.root).(Script_typed_ir.entrypoints_node.at_node),
match
entrypoints.(Script_typed_ir.entrypoints.root).(Script_typed_ir.entrypoints_node.at_node)
with
|
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr := _
|} ⇒
(Alpha_context.Entrypoint.is_root name) &&
(Alpha_context.Entrypoint.is_default entrypoint)
| _ ⇒ false
end) with
|
(Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr := _
|}, true) ⇒
Gas_monad.bind_recover (ty_eq Script_tc_errors.Fast ty_value expected)
(fun (function_parameter :
Pervasives.result eq Script_tc_errors.inconsistent_types_fast_error)
⇒
match function_parameter with
| Pervasives.Ok Eq ⇒
Gas_monad.Syntax._return
(Alpha_context.Entrypoint.default, ty_value)
| Pervasives.Error Script_tc_errors.Inconsistent_types_fast ⇒
Gas_monad.Syntax.op_letplus
(ty_eq error_details full_value expected)
(fun function_parameter ⇒
let 'Eq := function_parameter in
(Alpha_context.Entrypoint.root_value, full_value))
end)
| (_, _) ⇒
Gas_monad.Syntax.op_letplus (ty_eq error_details ty_value expected)
(fun function_parameter ⇒
let 'Eq := function_parameter in
(entrypoint, ty_value))
end).
Definition well_formed_entrypoints
(full_value : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints_node) : M? unit :=
let merge {A : Set}
(path : list A) (ty_value : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints_node) (reachable : bool)
(function_parameter : option (list A) × Entrypoint_repr._Set.(_Set.S.t))
: M? ((option (list A) × Entrypoint_repr._Set.(_Set.S.t)) × bool) :=
let '(first_unreachable, all) as acc_value := function_parameter in
match entrypoints.(Script_typed_ir.entrypoints_node.at_node) with
| None ⇒
return?
((if reachable then
acc_value
else
match ty_value with
| Script_typed_ir.Union_t _ _ _ _ ⇒ acc_value
| _ ⇒
match first_unreachable with
| None ⇒ ((Some (List.rev path)), all)
| Some _ ⇒ acc_value
end
end), reachable)
|
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr := _
|} ⇒
if Alpha_context.Entrypoint._Set.(_Set.S.mem) name all then
Error_monad.error_value
(Build_extensible "Duplicate_entrypoint" Alpha_context.Entrypoint.t
name)
else
return?
((first_unreachable,
(Alpha_context.Entrypoint._Set.(_Set.S.add) name all)), true)
end in
let fix check
(t_value : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints_node)
(path : list Alpha_context.Script.prim) (reachable : bool)
(acc_value :
option (list Alpha_context.Script.prim) × Entrypoint_repr._Set.(_Set.S.t))
: M?
(option (list Alpha_context.Script.prim) × Entrypoint_repr._Set.(_Set.S.t)) :=
match (t_value, entrypoints) with
|
(Script_typed_ir.Union_t tl tr _ _, {|
Script_typed_ir.entrypoints_node.nested :=
Script_typed_ir.Entrypoints_Union {|
Script_typed_ir.nested_entrypoints.Entrypoints_Union._left := _left;
Script_typed_ir.nested_entrypoints.Entrypoints_Union._right
:= _right
|}
|}) ⇒
let? '(acc_value, l_reachable) :=
merge (cons Michelson_v1_primitives.D_Left path) tl _left reachable
acc_value in
let? '(acc_value, r_reachable) :=
merge (cons Michelson_v1_primitives.D_Right path) tr _right reachable
acc_value in
let? acc_value :=
check tl _left (cons Michelson_v1_primitives.D_Left path) l_reachable
acc_value in
check tr _right (cons Michelson_v1_primitives.D_Right path) r_reachable
acc_value
| _ ⇒ return? acc_value
end in
let '(init_value, reachable) :=
match entrypoints.(Script_typed_ir.entrypoints_node.at_node) with
| None ⇒ (Alpha_context.Entrypoint._Set.(_Set.S.empty), false)
|
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr := _
|} ⇒ ((Alpha_context.Entrypoint._Set.(_Set.S.singleton) name), true)
end in
let? '(first_unreachable, all) :=
check full_value entrypoints nil reachable (None, init_value) in
if
Pervasives.not
(Alpha_context.Entrypoint._Set.(_Set.S.mem)
Alpha_context.Entrypoint.default all)
then
Result.return_unit
else
match first_unreachable with
| None ⇒ Result.return_unit
| Some path ⇒
Error_monad.error_value
(Build_extensible "Unreachable_entrypoint"
(list Alpha_context.Script.prim) path)
end.
Module ex_ty_cstr.
Module Ex_ty_cstr.
Record record {ty construct original_type_expr : Set} : Set := Build {
ty : ty;
construct : construct;
original_type_expr : original_type_expr;
}.
Arguments record : clear implicits.
Definition with_ty {t_ty t_construct t_original_type_expr} ty
(r : record t_ty t_construct t_original_type_expr) :=
Build t_ty t_construct t_original_type_expr ty r.(construct)
r.(original_type_expr).
Definition with_construct {t_ty t_construct t_original_type_expr}
construct (r : record t_ty t_construct t_original_type_expr) :=
Build t_ty t_construct t_original_type_expr r.(ty) construct
r.(original_type_expr).
Definition with_original_type_expr {t_ty t_construct t_original_type_expr}
original_type_expr (r : record t_ty t_construct t_original_type_expr) :=
Build t_ty t_construct t_original_type_expr r.(ty) r.(construct)
original_type_expr.
End Ex_ty_cstr.
Definition Ex_ty_cstr_skeleton := Ex_ty_cstr.record.
End ex_ty_cstr.
End ConstructorRecords_ex_ty_cstr.
Import ConstructorRecords_ex_ty_cstr.
Reserved Notation "'ex_ty_cstr.Ex_ty_cstr".
Inductive ex_ty_cstr (a : Set) : Set :=
| Ex_ty_cstr : ∀ {b : Set}, 'ex_ty_cstr.Ex_ty_cstr a b → ex_ty_cstr a
where "'ex_ty_cstr.Ex_ty_cstr" :=
(fun (t_a t_b : Set) ⇒ ex_ty_cstr.Ex_ty_cstr_skeleton Script_typed_ir.ty
(t_b → t_a) Alpha_context.Script.node).
Module ex_ty_cstr.
Include ConstructorRecords_ex_ty_cstr.ex_ty_cstr.
Definition Ex_ty_cstr := 'ex_ty_cstr.Ex_ty_cstr.
End ex_ty_cstr.
Arguments Ex_ty_cstr {_ _}.
#[bypass_check(guard)]
Definition find_entrypoint {error_context full error_trace : Set}
(error_details : Script_tc_errors.error_details error_context)
(full_value : Script_typed_ir.ty) (entrypoints : Script_typed_ir.entrypoints)
(entrypoint : Alpha_context.Entrypoint.t)
: Gas_monad.t (ex_ty_cstr full) error_trace :=
let fix find_entrypoint {t : Set}
(ty_value : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints_node)
(entrypoint : Alpha_context.Entrypoint.t) {struct ty_value}
: Gas_monad.t (ex_ty_cstr t) unit :=
Gas_monad.Syntax.op_letstar
(Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle)
(fun function_parameter ⇒
let '_ := function_parameter in
match
((ty_value, entrypoints),
match (ty_value, entrypoints) with
|
(_, {|
Script_typed_ir.entrypoints_node.at_node :=
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr
:=
original_type_expr
|}
|}) ⇒ Alpha_context.Entrypoint.op_eq name entrypoint
| _ ⇒ false
end) with
|
((_, {|
Script_typed_ir.entrypoints_node.at_node :=
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr
:=
original_type_expr
|}
|}), true) ⇒
let '[original_type_expr, name] :=
cast [Alpha_context.Script.node ** Alpha_context.Entrypoint.t]
[original_type_expr, name] in
Gas_monad.Syntax._return
(Ex_ty_cstr
{| ex_ty_cstr.Ex_ty_cstr.ty := ty_value;
ex_ty_cstr.Ex_ty_cstr.construct := fun (e_value : t) ⇒ e_value;
ex_ty_cstr.Ex_ty_cstr.original_type_expr := original_type_expr;
|})
|
((Script_typed_ir.Union_t tl tr _ _, {|
Script_typed_ir.entrypoints_node.nested :=
Script_typed_ir.Entrypoints_Union {|
Script_typed_ir.nested_entrypoints.Entrypoints_Union._left := _left;
Script_typed_ir.nested_entrypoints.Entrypoints_Union._right
:= _right
|}
|}), _) ⇒
let 'existT _ [__1, __0] [_right, _left, tr, tl] :=
cast_exists (Es := [Set ** Set])
(fun '[__1, __0] ⇒
[Script_typed_ir.entrypoints_node **
Script_typed_ir.entrypoints_node ** Script_typed_ir.ty **
Script_typed_ir.ty]) [_right, _left, tr, tl] in
cast (Gas_monad.t (ex_ty_cstr t) unit)
(Gas_monad.bind_recover (find_entrypoint tl _left entrypoint)
(fun (function_parameter :
Pervasives.result (ex_ty_cstr __0) unit) ⇒
match function_parameter with
|
Pervasives.Ok
(Ex_ty_cstr {|
ex_ty_cstr.Ex_ty_cstr.ty := ty_value;
ex_ty_cstr.Ex_ty_cstr.construct := construct;
ex_ty_cstr.Ex_ty_cstr.original_type_expr :=
original_type_expr
|}) ⇒
let 'existT _ __Ex_ty_cstr_'b
[original_type_expr, construct, ty_value] :=
cast_exists (Es := Set)
(fun __Ex_ty_cstr_'b ⇒
[Alpha_context.Script.node ** __Ex_ty_cstr_'b → __0 **
Script_typed_ir.ty])
[original_type_expr, construct, ty_value] in
Gas_monad.Syntax._return
(Ex_ty_cstr
{| ex_ty_cstr.Ex_ty_cstr.ty := ty_value;
ex_ty_cstr.Ex_ty_cstr.construct :=
fun (e_value : __Ex_ty_cstr_'b) ⇒
Script_typed_ir.L (construct e_value);
ex_ty_cstr.Ex_ty_cstr.original_type_expr :=
original_type_expr; |})
| Pervasives.Error _ ⇒
Gas_monad.Syntax.op_letplus
((find_entrypoint tr _right entrypoint) :
Gas_monad.t (ex_ty_cstr __1) unit)
(fun x_value ⇒
let
'Ex_ty_cstr {|
ex_ty_cstr.Ex_ty_cstr.ty := ty_value;
ex_ty_cstr.Ex_ty_cstr.construct := construct;
ex_ty_cstr.Ex_ty_cstr.original_type_expr :=
original_type_expr
|} := x_value in
let 'existT _ __Ex_ty_cstr_'b1
[original_type_expr, construct, ty_value] :=
cast_exists (Es := Set)
(fun __Ex_ty_cstr_'b1 ⇒
[Alpha_context.Script.node **
__Ex_ty_cstr_'b1 → __1 ** Script_typed_ir.ty])
[original_type_expr, construct, ty_value] in
Ex_ty_cstr
{| ex_ty_cstr.Ex_ty_cstr.ty := ty_value;
ex_ty_cstr.Ex_ty_cstr.construct :=
fun (e_value : __Ex_ty_cstr_'b1) ⇒
Script_typed_ir.R (construct e_value);
ex_ty_cstr.Ex_ty_cstr.original_type_expr :=
original_type_expr; |})
end))
|
((_, {|
Script_typed_ir.entrypoints_node.nested := Script_typed_ir.Entrypoints_None
|}), _) ⇒ Gas_monad.of_result (Pervasives.Error tt)
| _ ⇒ unreachable_gadt_branch
end) in
let '{|
Script_typed_ir.entrypoints.root := root_value;
Script_typed_ir.entrypoints.original_type_expr := original_type_expr
|} := entrypoints in
Gas_monad.bind_recover (find_entrypoint full_value root_value entrypoint)
(fun (function_parameter : Pervasives.result (ex_ty_cstr full) unit) ⇒
match function_parameter with
| Pervasives.Ok f_t ⇒ Gas_monad.Syntax._return f_t
| Pervasives.Error _ ⇒
if Alpha_context.Entrypoint.is_default entrypoint then
Gas_monad.Syntax._return
(Ex_ty_cstr
{| ex_ty_cstr.Ex_ty_cstr.ty := full_value;
ex_ty_cstr.Ex_ty_cstr.construct :=
fun (e_value : full) ⇒ e_value;
ex_ty_cstr.Ex_ty_cstr.original_type_expr := original_type_expr;
|})
else
Gas_monad.of_result
(Pervasives.Error
match error_details with
| Script_tc_errors.Fast ⇒
cast error_trace Script_tc_errors.Inconsistent_types_fast
| Script_tc_errors.Informative _ ⇒
cast error_trace
(Error_monad.trace_of_error
(Build_extensible "No_such_entrypoint"
Alpha_context.Entrypoint.t entrypoint))
end)
end).
Definition find_entrypoint_for_type {full : Set} {error_trace : Set}
(error_details : Script_tc_errors.error_details Alpha_context.Script.location)
(full_value : Script_typed_ir.ty) (expected : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints)
(entrypoint : Alpha_context.Entrypoint.t)
: Gas_monad.t (Alpha_context.Entrypoint.t × Script_typed_ir.ty) error_trace :=
Gas_monad.Syntax.op_letstar
((find_entrypoint error_details full_value entrypoints entrypoint) :
Gas_monad.t (ex_ty_cstr full) error_trace)
(fun res ⇒
let 'Ex_ty_cstr {| ex_ty_cstr.Ex_ty_cstr.ty := ty_value |} := res in
match
(entrypoints.(Script_typed_ir.entrypoints.root).(Script_typed_ir.entrypoints_node.at_node),
match
entrypoints.(Script_typed_ir.entrypoints.root).(Script_typed_ir.entrypoints_node.at_node)
with
|
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr := _
|} ⇒
(Alpha_context.Entrypoint.is_root name) &&
(Alpha_context.Entrypoint.is_default entrypoint)
| _ ⇒ false
end) with
|
(Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr := _
|}, true) ⇒
Gas_monad.bind_recover (ty_eq Script_tc_errors.Fast ty_value expected)
(fun (function_parameter :
Pervasives.result eq Script_tc_errors.inconsistent_types_fast_error)
⇒
match function_parameter with
| Pervasives.Ok Eq ⇒
Gas_monad.Syntax._return
(Alpha_context.Entrypoint.default, ty_value)
| Pervasives.Error Script_tc_errors.Inconsistent_types_fast ⇒
Gas_monad.Syntax.op_letplus
(ty_eq error_details full_value expected)
(fun function_parameter ⇒
let 'Eq := function_parameter in
(Alpha_context.Entrypoint.root_value, full_value))
end)
| (_, _) ⇒
Gas_monad.Syntax.op_letplus (ty_eq error_details ty_value expected)
(fun function_parameter ⇒
let 'Eq := function_parameter in
(entrypoint, ty_value))
end).
Definition well_formed_entrypoints
(full_value : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints_node) : M? unit :=
let merge {A : Set}
(path : list A) (ty_value : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints_node) (reachable : bool)
(function_parameter : option (list A) × Entrypoint_repr._Set.(_Set.S.t))
: M? ((option (list A) × Entrypoint_repr._Set.(_Set.S.t)) × bool) :=
let '(first_unreachable, all) as acc_value := function_parameter in
match entrypoints.(Script_typed_ir.entrypoints_node.at_node) with
| None ⇒
return?
((if reachable then
acc_value
else
match ty_value with
| Script_typed_ir.Union_t _ _ _ _ ⇒ acc_value
| _ ⇒
match first_unreachable with
| None ⇒ ((Some (List.rev path)), all)
| Some _ ⇒ acc_value
end
end), reachable)
|
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr := _
|} ⇒
if Alpha_context.Entrypoint._Set.(_Set.S.mem) name all then
Error_monad.error_value
(Build_extensible "Duplicate_entrypoint" Alpha_context.Entrypoint.t
name)
else
return?
((first_unreachable,
(Alpha_context.Entrypoint._Set.(_Set.S.add) name all)), true)
end in
let fix check
(t_value : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints_node)
(path : list Alpha_context.Script.prim) (reachable : bool)
(acc_value :
option (list Alpha_context.Script.prim) × Entrypoint_repr._Set.(_Set.S.t))
: M?
(option (list Alpha_context.Script.prim) × Entrypoint_repr._Set.(_Set.S.t)) :=
match (t_value, entrypoints) with
|
(Script_typed_ir.Union_t tl tr _ _, {|
Script_typed_ir.entrypoints_node.nested :=
Script_typed_ir.Entrypoints_Union {|
Script_typed_ir.nested_entrypoints.Entrypoints_Union._left := _left;
Script_typed_ir.nested_entrypoints.Entrypoints_Union._right
:= _right
|}
|}) ⇒
let? '(acc_value, l_reachable) :=
merge (cons Michelson_v1_primitives.D_Left path) tl _left reachable
acc_value in
let? '(acc_value, r_reachable) :=
merge (cons Michelson_v1_primitives.D_Right path) tr _right reachable
acc_value in
let? acc_value :=
check tl _left (cons Michelson_v1_primitives.D_Left path) l_reachable
acc_value in
check tr _right (cons Michelson_v1_primitives.D_Right path) r_reachable
acc_value
| _ ⇒ return? acc_value
end in
let '(init_value, reachable) :=
match entrypoints.(Script_typed_ir.entrypoints_node.at_node) with
| None ⇒ (Alpha_context.Entrypoint._Set.(_Set.S.empty), false)
|
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr := _
|} ⇒ ((Alpha_context.Entrypoint._Set.(_Set.S.singleton) name), true)
end in
let? '(first_unreachable, all) :=
check full_value entrypoints nil reachable (None, init_value) in
if
Pervasives.not
(Alpha_context.Entrypoint._Set.(_Set.S.mem)
Alpha_context.Entrypoint.default all)
then
Result.return_unit
else
match first_unreachable with
| None ⇒ Result.return_unit
| Some path ⇒
Error_monad.error_value
(Build_extensible "Unreachable_entrypoint"
(list Alpha_context.Script.prim) path)
end.
Records for the constructor parameters
Module ConstructorRecords_ex_parameter_ty_and_entrypoints.
Module ex_parameter_ty_and_entrypoints.
Module Ex_parameter_ty_and_entrypoints.
Record record {arg_type entrypoints : Set} : Set := Build {
arg_type : arg_type;
entrypoints : entrypoints;
}.
Arguments record : clear implicits.
Definition with_arg_type {t_arg_type t_entrypoints} arg_type
(r : record t_arg_type t_entrypoints) :=
Build t_arg_type t_entrypoints arg_type r.(entrypoints).
Definition with_entrypoints {t_arg_type t_entrypoints} entrypoints
(r : record t_arg_type t_entrypoints) :=
Build t_arg_type t_entrypoints r.(arg_type) entrypoints.
End Ex_parameter_ty_and_entrypoints.
Definition Ex_parameter_ty_and_entrypoints_skeleton :=
Ex_parameter_ty_and_entrypoints.record.
End ex_parameter_ty_and_entrypoints.
End ConstructorRecords_ex_parameter_ty_and_entrypoints.
Import ConstructorRecords_ex_parameter_ty_and_entrypoints.
Reserved Notation
"'ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints".
Inductive ex_parameter_ty_and_entrypoints : Set :=
| Ex_parameter_ty_and_entrypoints :
'ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints →
ex_parameter_ty_and_entrypoints
where "'ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints" :=
(ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints_skeleton
Script_typed_ir.ty Script_typed_ir.entrypoints).
Module ex_parameter_ty_and_entrypoints.
Include ConstructorRecords_ex_parameter_ty_and_entrypoints.ex_parameter_ty_and_entrypoints.
Definition Ex_parameter_ty_and_entrypoints :=
'ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.
End ex_parameter_ty_and_entrypoints.
Definition parse_parameter_ty_and_entrypoints_aux
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(node_value : Alpha_context.Script.node)
: M? (ex_parameter_ty_and_entrypoints × Alpha_context.context) :=
let?
'(Ex_parameter_ty_and_entrypoints_node {|
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.arg_type
:= arg_type;
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.entrypoints
:= entrypoints
|}, ctxt) :=
parse_passable_ty_aux_with_ret ctxt (stack_depth +i 1) legacy
Parse_entrypoints node_value in
let? '_ :=
if legacy then
Result.return_unit
else
well_formed_entrypoints arg_type entrypoints in
let entrypoints :=
{| Script_typed_ir.entrypoints.root := entrypoints;
Script_typed_ir.entrypoints.original_type_expr := node_value; |} in
return?
((Ex_parameter_ty_and_entrypoints
{|
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.arg_type
:= arg_type;
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.entrypoints
:= entrypoints; |}), ctxt).
Definition parse_passable_ty_aux
: Alpha_context.context → int → bool → Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
fun x_1 x_2 x_3 ⇒
parse_passable_ty_aux_with_ret x_1 x_2 x_3 Don't_parse_entrypoints.
Definition parse_uint (nb_bits : int)
: Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? int :=
if (nb_bits ≥i 0) && (nb_bits ≤i 30) then
let max_int := (Pervasives.lsl 1 nb_bits) -i 1 in
let max_z := Z.of_int max_int in
fun (function_parameter :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim) ⇒
match
(function_parameter,
match function_parameter with
| Micheline.Int _ n_value ⇒
(Z.zero ≤Z n_value) && (n_value ≤Z max_z)
| _ ⇒ false
end) with
| (Micheline.Int _ n_value, true) ⇒ return? (Z.to_int n_value)
| (node_value, _) ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
((location node_value), (Micheline.strip_locations node_value),
(Pervasives.op_caret "a positive "
(Pervasives.op_caret (Pervasives.string_of_int nb_bits)
(Pervasives.op_caret "-bit integer (between 0 and "
(Pervasives.op_caret (Pervasives.string_of_int max_int) ")"))))))
end
else
fun (function_parameter :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim) ⇒
let '_ := function_parameter in
Error_monad.error_value (Build_extensible "Asserted" unit tt).
Definition parse_uint10
: Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? int := parse_uint 10.
Definition parse_uint11
: Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? int := parse_uint 11.
Definition opened_ticket_type
(loc_value : Alpha_context.Script.location)
(ty_value : Script_typed_ir.comparable_ty)
: M? Script_typed_ir.comparable_ty :=
Script_typed_ir.comparable_pair_3_t loc_value Script_typed_ir.address_t
ty_value Script_typed_ir.nat_t.
Definition parse_unit
(ctxt : Alpha_context.context) (legacy : bool)
(function_parameter :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
: M? (unit × Alpha_context.context) :=
match function_parameter with
| Micheline.Prim loc_value Michelson_v1_primitives.D_Unit [] annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.unit_value in
return? (tt, ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_Unit l_value _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.D_Unit, 0, (List.length l_value)))
| expr ⇒
Error_monad.error_value
(unexpected expr nil Michelson_v1_primitives.Constant_namespace
[ Michelson_v1_primitives.D_Unit ])
end.
Definition parse_bool
(ctxt : Alpha_context.context) (legacy : bool)
(function_parameter :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
: M? (bool × Alpha_context.context) :=
match function_parameter with
| Micheline.Prim loc_value Michelson_v1_primitives.D_True [] annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.bool_value in
return? (true, ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_False [] annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.bool_value in
return? (false, ctxt)
|
Micheline.Prim loc_value
((Michelson_v1_primitives.D_True | Michelson_v1_primitives.D_False) as
c_value) l_value _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, c_value, 0, (List.length l_value)))
| expr ⇒
Error_monad.error_value
(unexpected expr nil Michelson_v1_primitives.Constant_namespace
[ Michelson_v1_primitives.D_True; Michelson_v1_primitives.D_False ])
end.
Definition parse_string
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_string.t × Alpha_context.context) :=
match function_parameter with
| (Micheline.String loc_value v_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.check_printable v_value)
in
Error_monad.record_trace
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a printable ascii string"))
(let? s_value := Script_string.of_string v_value in
return? (s_value, ctxt))
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.String_kind ], (kind_value expr)))
end.
Definition parse_bytes {A B : Set}
(ctxt : A)
(function_parameter : Micheline.node Alpha_context.Script.location B)
: M? (bytes × A) :=
match function_parameter with
| Micheline.Bytes _ v_value ⇒ return? (v_value, ctxt)
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr)))
end.
Definition parse_int {A B : Set}
(ctxt : A)
(function_parameter : Micheline.node Alpha_context.Script.location B)
: M? (Script_int.num × A) :=
match function_parameter with
| Micheline.Int _ v_value ⇒ return? ((Script_int.of_zint v_value), ctxt)
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Int_kind ], (kind_value expr)))
end.
Definition parse_nat
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_int.num × Alpha_context.context) :=
match function_parameter with
| (Micheline.Int loc_value v_value) as expr ⇒
let v_value := Script_int.of_zint v_value in
match Script_int.is_nat v_value with
| Some nat ⇒ return? (nat, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a non-negative integer"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Int_kind ], (kind_value expr)))
end.
Definition parse_mutez
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Alpha_context.Tez.t × Alpha_context.context) :=
match function_parameter with
| (Micheline.Int loc_value v_value) as expr ⇒
match
Option.bind
(Option.catch None
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
Z.to_int64 v_value)) Alpha_context.Tez.of_mutez with
| Some tez ⇒ Pervasives.Ok (tez, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid mutez amount"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Int_kind ], (kind_value expr)))
end.
Definition parse_timestamp
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_timestamp.t × Alpha_context.context) :=
match function_parameter with
| Micheline.Int _ v_value ⇒
return? ((Script_timestamp.of_zint v_value), ctxt)
| (Micheline.String loc_value s_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Typecheck_costs.timestamp_readable s_value) in
match Script_timestamp.of_string s_value with
| Some v_value ⇒ return? (v_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid timestamp"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Int_kind ],
(kind_value expr)))
end.
Definition parse_key
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Alpha_context.public_key × Alpha_context.context) :=
match function_parameter with
| (Micheline.Bytes loc_value bytes_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.public_key_optimized in
match
Data_encoding.Binary.of_bytes_opt
Signature.Public_key.(S.SIGNATURE_PUBLIC_KEY.encoding) bytes_value with
| Some k_value ⇒ return? (k_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid public key"))
end
| (Micheline.String loc_value s_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.public_key_readable in
match Signature.Public_key.(S.SIGNATURE_PUBLIC_KEY.of_b58check_opt) s_value
with
| Some k_value ⇒ return? (k_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid public key"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Bytes_kind ],
(kind_value expr)))
end.
Definition parse_key_hash
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Alpha_context.public_key_hash × Alpha_context.context) :=
match function_parameter with
| (Micheline.Bytes loc_value bytes_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.key_hash_optimized in
match
Data_encoding.Binary.of_bytes_opt
Signature.Public_key_hash.(S.SIGNATURE_PUBLIC_KEY_HASH.encoding)
bytes_value with
| Some k_value ⇒ return? (k_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid key hash"))
end
| (Micheline.String loc_value s_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.key_hash_readable in
match
Signature.Public_key_hash.(S.SIGNATURE_PUBLIC_KEY_HASH.of_b58check_opt)
s_value with
| Some k_value ⇒ return? (k_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid key hash"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Bytes_kind ],
(kind_value expr)))
end.
Definition parse_signature
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_typed_ir.signature × Alpha_context.context) :=
match function_parameter with
| (Micheline.Bytes loc_value bytes_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.signature_optimized in
match
Data_encoding.Binary.of_bytes_opt
Script_typed_ir.Script_signature.encoding bytes_value with
| Some k_value ⇒ return? (k_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid signature"))
end
| (Micheline.String loc_value s_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.signature_readable in
match Script_typed_ir.Script_signature.of_b58check_opt s_value with
| Some s_value ⇒ return? (s_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid signature"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Bytes_kind ],
(kind_value expr)))
end.
Definition parse_chain_id
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_typed_ir.Script_chain_id.t × Alpha_context.context) :=
match function_parameter with
| (Micheline.Bytes loc_value bytes_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.chain_id_optimized in
match
Data_encoding.Binary.of_bytes_opt Script_typed_ir.Script_chain_id.encoding
bytes_value with
| Some k_value ⇒ return? (k_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid chain id"))
end
| (Micheline.String loc_value s_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.chain_id_readable in
match Script_typed_ir.Script_chain_id.of_b58check_opt s_value with
| Some s_value ⇒ return? (s_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid chain id"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Bytes_kind ],
(kind_value expr)))
end.
Definition parse_address (ctxt : Alpha_context.context)
: Alpha_context.Script.node →
M? (Script_typed_ir.address × Alpha_context.context) :=
let destination_allowed
(loc_value : Alpha_context.Script.location)
(function_parameter : Script_typed_ir.address)
: Alpha_context.context →
M? (Script_typed_ir.address × Alpha_context.context) :=
let '{|
Script_typed_ir.address.destination := destination;
Script_typed_ir.address.entrypoint := entrypoint
|} := function_parameter in
fun (ctxt : Alpha_context.context) ⇒
match
(destination,
match destination with
| Alpha_context.Destination.Tx_rollup _ ⇒
Pervasives.not (Alpha_context.Constants.tx_rollup_enable ctxt)
| _ ⇒ false
end,
match destination with
| Alpha_context.Destination.Sc_rollup _ ⇒
Pervasives.not (Alpha_context.Constants.sc_rollup_enable ctxt)
| _ ⇒ false
end,
match destination with
| Alpha_context.Destination.Zk_rollup _ ⇒
Pervasives.not (Alpha_context.Constants.zk_rollup_enable ctxt)
| _ ⇒ false
end) with
| (Alpha_context.Destination.Tx_rollup _, true, _, _) ⇒
Error_monad.error_value
(Build_extensible "Tx_rollup_addresses_disabled"
Alpha_context.Script.location loc_value)
| (Alpha_context.Destination.Sc_rollup _, _, true, _) ⇒
Error_monad.error_value
(Build_extensible "Sc_rollup_disabled" Alpha_context.Script.location
loc_value)
| (Alpha_context.Destination.Zk_rollup _, _, _, true) ⇒
Error_monad.error_value
(Build_extensible "Zk_rollup_disabled" Alpha_context.Script.location
loc_value)
| (_, _, _, _) ⇒
Pervasives.Ok
({| Script_typed_ir.address.destination := destination;
Script_typed_ir.address.entrypoint := entrypoint; |}, ctxt)
end in
fun (function_parameter : Alpha_context.Script.node) ⇒
match function_parameter with
| (Micheline.Bytes loc_value bytes_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.contract_optimized in
match
Data_encoding.Binary.of_bytes_opt
(Data_encoding.tup2 Alpha_context.Destination.encoding
Alpha_context.Entrypoint.value_encoding) bytes_value with
| Some (destination, entrypoint) ⇒
destination_allowed loc_value
{| Script_typed_ir.address.destination := destination;
Script_typed_ir.address.entrypoint := entrypoint; |} ctxt
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid address"))
end
| Micheline.String loc_value s_value ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.contract_readable in
let? '(addr, entrypoint) :=
match String.index_opt s_value "%" % char with
| None ⇒ return? (s_value, Alpha_context.Entrypoint.default)
| Some pos ⇒
let len := ((String.length s_value) -i pos) -i 1 in
let name := String.sub s_value (pos +i 1) len in
let? entrypoint :=
Alpha_context.Entrypoint.of_string_strict loc_value name in
return? ((String.sub s_value 0 pos), entrypoint)
end in
let? destination := Alpha_context.Destination.of_b58check addr in
destination_allowed loc_value
{| Script_typed_ir.address.destination := destination;
Script_typed_ir.address.entrypoint := entrypoint; |} ctxt
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Bytes_kind ],
(kind_value expr)))
end.
Definition parse_tx_rollup_l2_address
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_typed_ir.tx_rollup_l2_address × Alpha_context.context) :=
match function_parameter with
| (Micheline.Bytes loc_value bytes_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.tx_rollup_l2_address in
match Tx_rollup_l2_address.of_bytes_opt bytes_value with
| Some txa ⇒
return? ((Tx_rollup_l2_address.Indexable.value_value txa), ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr),
"a valid transaction rollup L2 address"))
end
| (Micheline.String loc_value str) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.tx_rollup_l2_address in
match Tx_rollup_l2_address.of_b58check_opt str with
| Some txa ⇒
return? ((Tx_rollup_l2_address.Indexable.value_value txa), ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr),
"a valid transaction rollup L2 address"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Bytes_kind ],
(kind_value expr)))
end.
Definition parse_never {A : Set}
(expr : Micheline.node Alpha_context.Script.location A)
: M? (Script_typed_ir.never × Alpha_context.context) :=
Error_monad.error_value
(Build_extensible "Invalid_never_expr" Alpha_context.Script.location
(location expr)).
Definition parse_pair {A B C D E : Set}
(parse_l :
A →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? (B × C))
(parse_r :
C →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? (D × E)) (ctxt : A) (legacy : bool)
(r_comb_witness : Script_ir_unparser.comb_witness)
(expr : Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
: M? ((B × D) × E) :=
let parse_comb
(loc_value : Alpha_context.Script.location)
(l_value :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
(rs :
list
(Micheline.node Alpha_context.Script.location Alpha_context.Script.prim))
: M? ((B × D) × E) :=
let? '(l_value, ctxt) := parse_l ctxt l_value in
let? r_value :=
match (rs, r_comb_witness) with
| (cons r_value [], _) ⇒ return? r_value
| ([], _) ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
int) (loc_value, Michelson_v1_primitives.D_Pair, 2, 1))
| (cons _ _, Script_ir_unparser.Comb_Pair _) ⇒
return? (Micheline.Prim loc_value Michelson_v1_primitives.D_Pair rs nil)
| _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
int)
(loc_value, Michelson_v1_primitives.D_Pair, 2,
(1 +i (List.length rs))))
end in
let? '(r_value, ctxt) := parse_r ctxt r_value in
return? ((l_value, r_value), ctxt) in
match expr with
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Pair (cons l_value rs)
annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
parse_comb loc_value l_value rs
| Micheline.Prim loc_value Michelson_v1_primitives.D_Pair l_value _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.D_Pair, 2, (List.length l_value)))
| Micheline.Seq loc_value (cons l_value ((cons _ _) as rs)) ⇒
parse_comb loc_value l_value rs
| Micheline.Seq loc_value l_value ⇒
Error_monad.tzfail
(Build_extensible "Invalid_seq_arity"
(Alpha_context.Script.location × int × int)
(loc_value, 2, (List.length l_value)))
| expr ⇒
Error_monad.tzfail
(unexpected expr nil Michelson_v1_primitives.Constant_namespace
[ Michelson_v1_primitives.D_Pair ])
end.
Definition parse_union {A B C D : Set}
(parse_l :
A →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? (B × C))
(parse_r :
A →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? (D × C)) (ctxt : A) (legacy : bool)
(function_parameter :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
: M? (Script_typed_ir.union B D × C) :=
match function_parameter with
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Left (cons v_value [])
annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(v_value, ctxt) := parse_l ctxt v_value in
return? ((Script_typed_ir.L v_value), ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_Left l_value _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.D_Left, 1, (List.length l_value)))
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Right (cons v_value [])
annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(v_value, ctxt) := parse_r ctxt v_value in
return? ((Script_typed_ir.R v_value), ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_Right l_value _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.D_Right, 1, (List.length l_value)))
| expr ⇒
Error_monad.tzfail
(unexpected expr nil Michelson_v1_primitives.Constant_namespace
[ Michelson_v1_primitives.D_Left; Michelson_v1_primitives.D_Right ])
end.
Definition parse_option {A B : Set}
(parse_v :
A →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? (B × A)) (ctxt : A) (legacy : bool)
(function_parameter :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
: M? (option B × A) :=
match function_parameter with
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Some (cons v_value [])
annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(v_value, ctxt) := parse_v ctxt v_value in
return? ((Some v_value), ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_Some l_value _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.D_Some, 1, (List.length l_value)))
| Micheline.Prim loc_value Michelson_v1_primitives.D_None [] annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
return? (None, ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_None l_value _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.D_None, 0, (List.length l_value)))
| expr ⇒
Error_monad.tzfail
(unexpected expr nil Michelson_v1_primitives.Constant_namespace
[ Michelson_v1_primitives.D_Some; Michelson_v1_primitives.D_None ])
end.
Definition comb_witness1 (function_parameter : Script_typed_ir.ty)
: Script_ir_unparser.comb_witness :=
match function_parameter with
| Script_typed_ir.Pair_t _ _ _ _ ⇒
Script_ir_unparser.Comb_Pair Script_ir_unparser.Comb_Any
| _ ⇒ Script_ir_unparser.Comb_Any
end.
#[bypass_check(guard)]
Definition parse_view_name
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_string.t × Alpha_context.context) :=
match function_parameter with
| (Micheline.String loc_value v_value) as expr ⇒
if (String.length v_value) >i 31 then
Error_monad.error_value
(Build_extensible "View_name_too_long" string v_value)
else
let fix check_char (i_value : int) {struct i_value} : M? string :=
if i_value <i 0 then
return? v_value
else
if Script_ir_annot.is_allowed_char (String.get v_value i_value) then
check_char (i_value -i 1)
else
Error_monad.error_value
(Build_extensible "Bad_view_name" Alpha_context.Script.location
loc_value) in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.check_printable v_value)
in
Error_monad.record_trace
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr),
"string [a-zA-Z0-9_.%@] and the maximum string length of 31 characters"))
(let? v_value := check_char ((String.length v_value) -i 1) in
let? s_value := Script_string.of_string v_value in
return? (s_value, ctxt))
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.String_kind ], (kind_value expr)))
end.
Definition parse_toplevel_aux
(ctxt : Alpha_context.context) (legacy : bool)
(toplevel_value : Alpha_context.Script.expr)
: M? (toplevel × Alpha_context.context) :=
Error_monad.record_trace
(Build_extensible "Ill_typed_contract"
(Alpha_context.Script.expr × Script_tc_errors.type_map)
(toplevel_value, nil))
match Micheline.root_value toplevel_value with
| Micheline.Int loc_value _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Micheline.canonical_location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Seq_kind ], Script_tc_errors.Int_kind))
| Micheline.String loc_value _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Micheline.canonical_location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Seq_kind ],
Script_tc_errors.String_kind))
| Micheline.Bytes loc_value _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Micheline.canonical_location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Seq_kind ], Script_tc_errors.Bytes_kind))
| Micheline.Prim loc_value _ _ _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Micheline.canonical_location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Seq_kind ], Script_tc_errors.Prim_kind))
| Micheline.Seq _ fields ⇒
let fix find_fields
(ctxt : Alpha_context.context)
(p_value :
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim × Alpha_context.Script.location ×
Micheline.annot))
(s_value :
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim × Alpha_context.Script.location ×
Micheline.annot))
(c_value :
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim × Alpha_context.Script.location ×
Micheline.annot)) (views : Script_typed_ir.view_map)
(fields :
list
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim))
: M?
(Alpha_context.context ×
(option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim × Alpha_context.Script.location ×
Micheline.annot) ×
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim × Alpha_context.Script.location ×
Micheline.annot) ×
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim × Alpha_context.Script.location ×
Micheline.annot) × Script_typed_ir.view_map)) :=
match fields with
| [] ⇒ return? (ctxt, (p_value, s_value, c_value, views))
| cons (Micheline.Int loc_value _) _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Prim_kind ],
Script_tc_errors.Int_kind))
| cons (Micheline.String loc_value _) _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Prim_kind ],
Script_tc_errors.String_kind))
| cons (Micheline.Bytes loc_value _) _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Prim_kind ],
Script_tc_errors.Bytes_kind))
| cons (Micheline.Seq loc_value _) _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Prim_kind ],
Script_tc_errors.Seq_kind))
|
cons
(Micheline.Prim loc_value Michelson_v1_primitives.K_parameter
(cons arg []) annot) rest ⇒
match p_value with
| None ⇒
find_fields ctxt (Some (arg, loc_value, annot)) s_value c_value
views rest
| Some _ ⇒
Error_monad.error_value
(Build_extensible "Duplicate_field"
(Alpha_context.Script.location × Alpha_context.Script.prim)
(loc_value, Michelson_v1_primitives.K_parameter))
end
|
cons
(Micheline.Prim loc_value Michelson_v1_primitives.K_storage
(cons arg []) annot) rest ⇒
match s_value with
| None ⇒
find_fields ctxt p_value (Some (arg, loc_value, annot)) c_value
views rest
| Some _ ⇒
Error_monad.error_value
(Build_extensible "Duplicate_field"
(Alpha_context.Script.location × Alpha_context.Script.prim)
(loc_value, Michelson_v1_primitives.K_storage))
end
|
cons
(Micheline.Prim loc_value Michelson_v1_primitives.K_code
(cons arg []) annot) rest ⇒
match c_value with
| None ⇒
find_fields ctxt p_value s_value (Some (arg, loc_value, annot))
views rest
| Some _ ⇒
Error_monad.error_value
(Build_extensible "Duplicate_field"
(Alpha_context.Script.location × Alpha_context.Script.prim)
(loc_value, Michelson_v1_primitives.K_code))
end
|
cons
(Micheline.Prim loc_value
((Michelson_v1_primitives.K_parameter |
Michelson_v1_primitives.K_storage | Michelson_v1_primitives.K_code)
as name) args _) _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
int) (loc_value, name, 1, (List.length args)))
|
cons
(Micheline.Prim loc_value Michelson_v1_primitives.K_view
(cons name (cons input_ty (cons output_ty (cons view_code [])))) _)
rest ⇒
let? '(str, ctxt) := parse_view_name ctxt name in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.view_update str views) in
if Script_map.mem str views then
Error_monad.error_value
(Build_extensible "Duplicated_view_name"
Alpha_context.Script.location loc_value)
else
let views' :=
Script_map.update str
(Some
{| Script_typed_ir.view.input_ty := input_ty;
Script_typed_ir.view.output_ty := output_ty;
Script_typed_ir.view.view_code := view_code; |}) views in
find_fields ctxt p_value s_value c_value views' rest
|
cons (Micheline.Prim loc_value Michelson_v1_primitives.K_view args _)
_ ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
int)
(loc_value, Michelson_v1_primitives.K_view, 4, (List.length args)))
| cons (Micheline.Prim loc_value name _ _) _ ⇒
let allowed :=
[
Michelson_v1_primitives.K_parameter;
Michelson_v1_primitives.K_storage;
Michelson_v1_primitives.K_code;
Michelson_v1_primitives.K_view
] in
Error_monad.error_value
(Build_extensible "Invalid_primitive"
(Alpha_context.Script.location × list Alpha_context.Script.prim ×
Alpha_context.Script.prim) (loc_value, allowed, name))
end in
let? '(ctxt, toplevel_value) :=
find_fields ctxt None None None
(Script_map.empty Script_typed_ir.string_t) fields in
match toplevel_value with
| (None, _, _, _) ⇒
Error_monad.error_value
(Build_extensible "Missing_field" Alpha_context.Script.prim
Michelson_v1_primitives.K_parameter)
| (Some _, None, _, _) ⇒
Error_monad.error_value
(Build_extensible "Missing_field" Alpha_context.Script.prim
Michelson_v1_primitives.K_storage)
| (Some _, Some _, None, _) ⇒
Error_monad.error_value
(Build_extensible "Missing_field" Alpha_context.Script.prim
Michelson_v1_primitives.K_code)
|
(Some (p_value, ploc, pannot), Some (s_value, sloc, sannot),
Some (c_value, cloc, cannot), views) ⇒
let p_pannot :=
let? function_parameter := Script_ir_annot.has_field_annot p_value in
match function_parameter with
| true ⇒ return? (p_value, pannot)
| false ⇒
match
(pannot,
match pannot with
| cons single [] ⇒ legacy
| _ ⇒ false
end) with
| (cons single [], true) ⇒
let? is_field_annot := Script_ir_annot.is_field_annot ploc single
in
match (is_field_annot, p_value) with
| (true, Micheline.Prim loc_value prim args annots) ⇒
return?
((Micheline.Prim loc_value prim args (cons single annots)),
nil)
| _ ⇒ return? (p_value, nil)
end
| (_, _) ⇒ return? (p_value, pannot)
end
end in
let? '(arg_type, pannot) := p_pannot in
let? '_ := Script_ir_annot.error_unexpected_annot ploc pannot in
let? '_ := Script_ir_annot.error_unexpected_annot cloc cannot in
let? '_ := Script_ir_annot.error_unexpected_annot sloc sannot in
return?
({| toplevel.code_field := c_value; toplevel.arg_type := arg_type;
toplevel.storage_type := s_value; toplevel.views := views; |}, ctxt)
end
end.
Reserved Notation "'parse_views".
Reserved Notation "'parse_kdescr".
Reserved Notation "'parse_lam_rec".
Reserved Notation "'parse_contract".
Reserved Notation "'parse_contract_data_aux".
#[bypass_check(guard)]
Fixpoint parse_data_aux {a : Set}
(elab_conf : elab_conf) (stack_depth : int) (ctxt : Alpha_context.context)
(allow_forged : bool) (ty_value : Script_typed_ir.ty)
(script_data : Alpha_context.Script.node) {struct ctxt}
: M? (a × Alpha_context.context) :=
let parse_kdescr := 'parse_kdescr in
let parse_lam_rec := 'parse_lam_rec in
let parse_contract_data_aux := 'parse_contract_data_aux in
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.parse_data_cycle
in
let non_terminal_recursion {B : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty)
(script_data : Alpha_context.Script.node)
: M? (B × Alpha_context.context) :=
if stack_depth >i 10000 then
Error_monad.tzfail
(Build_extensible "Typechecking_too_many_recursive_calls" unit tt)
else
parse_data_aux elab_conf (stack_depth +i 1) ctxt allow_forged ty_value
script_data in
let parse_data_error (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let ty_value := Script_ir_unparser.serialize_ty_for_error ty_value in
Build_extensible "Invalid_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim ×
Alpha_context.Script.expr)
((location script_data), (Micheline.strip_locations script_data), ty_value)
in
let fail_parse_data {B : Set} (function_parameter : unit) : M? B :=
let '_ := function_parameter in
Error_monad.tzfail (parse_data_error tt) in
let traced_no_lwt {B : Set} (body : M? B) : M? B :=
Error_monad.record_trace_eval parse_data_error body in
let traced {B : Set} (body : M? B) : M? B :=
Error_monad.trace_eval parse_data_error body in
let traced_fail {B : Set} (err : Error_monad._error) : M? B :=
traced_no_lwt (Error_monad.error_value err) in
let parse_items {B C D E : Set}
(ctxt : Alpha_context.context)
(expr : Micheline.node B Alpha_context.Script.prim)
(key_type : Script_typed_ir.ty) (value_type : Script_typed_ir.ty)
(items :
list
(Micheline.node Alpha_context.Script.location Alpha_context.Script.prim))
(item_wrapper : C → D)
: M? (Script_typed_ir.map E D × Alpha_context.context) :=
let? '(_, items, ctxt) :=
traced
(List.fold_left_es
(fun (function_parameter :
option E × Script_typed_ir.map E D × Alpha_context.context) ⇒
let '(last_value, map, ctxt) := function_parameter in
fun (item :
Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim) ⇒
match item with
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Elt
(cons k_value (cons v_value [])) annot ⇒
let? '_ :=
if
elab_conf.(Script_ir_translator_config.elab_config.legacy)
then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(k_value, ctxt) :=
non_terminal_recursion ctxt key_type k_value in
let? '(v_value, ctxt) :=
non_terminal_recursion ctxt value_type v_value in
let? ctxt :=
match last_value with
| Some value_value ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.compare key_type
value_value k_value) in
let c_value :=
Script_comparable.compare_comparable key_type value_value
k_value in
if 0 ≤i c_value then
if 0 =i c_value then
Error_monad.error_value
(Build_extensible "Duplicate_map_keys"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
Error_monad.error_value
(Build_extensible "Unordered_map_keys"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
return? ctxt
| None ⇒ return? ctxt
end in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.map_update k_value map)
in
return?
((Some k_value),
(Script_map.update k_value (Some (item_wrapper v_value)) map),
ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_Elt l_value _
⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim ×
int × int)
(loc_value, Michelson_v1_primitives.D_Elt, 2,
(List.length l_value)))
| Micheline.Prim loc_value name _ _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_primitive"
(Alpha_context.Script.location ×
list Alpha_context.Script.prim × Alpha_context.Script.prim)
(loc_value, [ Michelson_v1_primitives.D_Elt ], name))
|
(Micheline.Int _ _ | Micheline.String _ _ | Micheline.Bytes _ _
| Micheline.Seq _ _) ⇒ fail_parse_data tt
end) (None, (Script_map.empty key_type), ctxt) items) in
return? (items, ctxt) in
let parse_big_map_items {B C D t : Set}
(ctxt : Alpha_context.context)
(expr : Micheline.node B Alpha_context.Script.prim)
(key_type : Script_typed_ir.comparable_ty) (value_type : Script_typed_ir.ty)
(items :
list
(Micheline.node Alpha_context.Script.location Alpha_context.Script.prim))
(item_wrapper : C → option D)
: M? (Script_typed_ir.big_map_overlay t D × Alpha_context.context) :=
let? '(_, map, ctxt) :=
traced
(List.fold_left_es
(fun (function_parameter :
option t × Script_typed_ir.big_map_overlay t D ×
Alpha_context.context) ⇒
let
'(last_key, {|
Script_typed_ir.big_map_overlay.map := map;
Script_typed_ir.big_map_overlay.size := size_value
|}, ctxt) := function_parameter in
fun (item :
Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim) ⇒
match item with
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Elt
(cons k_value (cons v_value [])) annot ⇒
let? '_ :=
if
elab_conf.(Script_ir_translator_config.elab_config.legacy)
then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(k_value, ctxt) :=
non_terminal_recursion ctxt key_type k_value in
let? '(key_hash, ctxt) :=
hash_comparable_data ctxt key_type k_value in
let? '(v_value, ctxt) :=
non_terminal_recursion ctxt value_type v_value in
let? ctxt :=
match last_key with
| Some last_key ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.compare key_type
last_key k_value) in
let c_value :=
Script_comparable.compare_comparable key_type last_key
k_value in
if 0 ≤i c_value then
if 0 =i c_value then
Error_monad.error_value
(Build_extensible "Duplicate_map_keys"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
Error_monad.error_value
(Build_extensible "Unordered_map_keys"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
return? ctxt
| None ⇒ return? ctxt
end in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.big_map_update
{| Script_typed_ir.big_map_overlay.map := map;
Script_typed_ir.big_map_overlay.size := size_value; |})
in
if
Script_typed_ir.Big_map_overlay.(Map.S.mem) key_hash map
then
Error_monad.error_value
(Build_extensible "Duplicate_map_keys"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
return?
((Some k_value),
{|
Script_typed_ir.big_map_overlay.map :=
Script_typed_ir.Big_map_overlay.(Map.S.add) key_hash
(k_value, (item_wrapper v_value)) map;
Script_typed_ir.big_map_overlay.size := size_value +i 1;
|}, ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_Elt l_value _
⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim ×
int × int)
(loc_value, Michelson_v1_primitives.D_Elt, 2,
(List.length l_value)))
| Micheline.Prim loc_value name _ _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_primitive"
(Alpha_context.Script.location ×
list Alpha_context.Script.prim × Alpha_context.Script.prim)
(loc_value, [ Michelson_v1_primitives.D_Elt ], name))
|
(Micheline.Int _ _ | Micheline.String _ _ | Micheline.Bytes _ _
| Micheline.Seq _ _) ⇒ fail_parse_data tt
end)
(None,
{|
Script_typed_ir.big_map_overlay.map :=
Script_typed_ir.Big_map_overlay.(Map.S.empty);
Script_typed_ir.big_map_overlay.size := 0; |}, ctxt) items) in
return? (map, ctxt) in
let legacy := elab_conf.(Script_ir_translator_config.elab_config.legacy) in
match (ty_value, script_data) with
| (Script_typed_ir.Unit_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_unit ctxt legacy expr))
| (Script_typed_ir.Bool_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_bool ctxt legacy expr))
| (Script_typed_ir.String_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_string ctxt expr))
| (Script_typed_ir.Bytes_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_bytes ctxt expr))
| (Script_typed_ir.Int_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context)) (traced_no_lwt (parse_int ctxt expr))
| (Script_typed_ir.Nat_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context)) (traced_no_lwt (parse_nat ctxt expr))
| (Script_typed_ir.Mutez_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_mutez ctxt expr))
| (Script_typed_ir.Timestamp_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_timestamp ctxt expr))
| (Script_typed_ir.Key_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context)) (traced_no_lwt (parse_key ctxt expr))
| (Script_typed_ir.Key_hash_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_key_hash ctxt expr))
| (Script_typed_ir.Signature_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_signature ctxt expr))
| (Script_typed_ir.Operation_t, _) ⇒
cast (M? (a × Alpha_context.context))
((Error_monad.error_value (a := (unit × Alpha_context.context)))
(Build_extensible "Asserted" unit tt))
| (Script_typed_ir.Chain_id_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_chain_id ctxt expr))
| (Script_typed_ir.Address_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_address ctxt expr))
| (Script_typed_ir.Tx_rollup_l2_address_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_tx_rollup_l2_address ctxt expr))
| (Script_typed_ir.Contract_t arg_ty _, expr) ⇒
let '[expr, arg_ty] :=
cast [Alpha_context.Script.node ** Script_typed_ir.ty] [expr, arg_ty] in
cast (M? (a × Alpha_context.context))
(traced
(let? '(address, ctxt) := parse_address ctxt expr in
let loc_value := location expr in
let? '(ctxt, typed_contract) :=
parse_contract_data_aux (stack_depth +i 1) ctxt loc_value arg_ty
address.(Script_typed_ir.address.destination)
address.(Script_typed_ir.address.entrypoint) in
return? (typed_contract, ctxt)))
| (Script_typed_ir.Pair_t tl tr _ _, expr) ⇒
let 'existT _ [__2, __1] [expr, tr, tl] :=
cast_exists (Es := [Set ** Set])
(fun '[__2, __1] ⇒
[Alpha_context.Script.node ** Script_typed_ir.ty **
Script_typed_ir.ty]) [expr, tr, tl] in
cast (M? (a × Alpha_context.context))
(let r_witness := comb_witness1 tr in
let parse_l
(ctxt : Alpha_context.context) (v_value : Alpha_context.Script.node)
: M? (__1 × Alpha_context.context) :=
non_terminal_recursion ctxt tl v_value in
let parse_r
(ctxt : Alpha_context.context) (v_value : Alpha_context.Script.node)
: M? (__2 × Alpha_context.context) :=
non_terminal_recursion ctxt tr v_value in
traced (parse_pair parse_l parse_r ctxt legacy r_witness expr))
| (Script_typed_ir.Union_t tl tr _ _, expr) ⇒
let 'existT _ [__4, __3] [expr, tr, tl] :=
cast_exists (Es := [Set ** Set])
(fun '[__4, __3] ⇒
[Alpha_context.Script.node ** Script_typed_ir.ty **
Script_typed_ir.ty]) [expr, tr, tl] in
cast (M? (a × Alpha_context.context))
(let parse_l
(ctxt : Alpha_context.context) (v_value : Alpha_context.Script.node)
: M? (__3 × Alpha_context.context) :=
non_terminal_recursion ctxt tl v_value in
let parse_r
(ctxt : Alpha_context.context) (v_value : Alpha_context.Script.node)
: M? (__4 × Alpha_context.context) :=
non_terminal_recursion ctxt tr v_value in
traced (parse_union parse_l parse_r ctxt legacy expr))
|
(Script_typed_ir.Lambda_t ta tr _ty_name,
(Micheline.Seq _loc _) as script_instr) ⇒
let '[script_instr, _loc, _ty_name, tr, ta] :=
cast
[Micheline.node Alpha_context.Script.location Alpha_context.Script.prim
** Alpha_context.Script.location ** Script_typed_ir.ty_metadata **
Script_typed_ir.ty ** Script_typed_ir.ty]
[script_instr, _loc, _ty_name, tr, ta] in
cast (M? (a × Alpha_context.context))
(let? '(kdescr, ctxt) :=
traced
(parse_kdescr elab_conf (stack_depth +i 1) Tc_context.data ctxt ta tr
script_instr) in
return? ((Script_typed_ir.Lam kdescr script_instr), ctxt))
|
(Script_typed_ir.Lambda_t ta tr _ty_name,
Micheline.Prim loc_value Michelson_v1_primitives.D_Lambda_rec
(cons ((Micheline.Seq _loc _) as script_instr) []) []) ⇒
let '[script_instr, _loc, loc_value, _ty_name, tr, ta] :=
cast
[Micheline.node Alpha_context.Script.location Alpha_context.Script.prim
** Alpha_context.Script.location ** Alpha_context.Script.location **
Script_typed_ir.ty_metadata ** Script_typed_ir.ty **
Script_typed_ir.ty] [script_instr, _loc, loc_value, _ty_name, tr, ta]
in
cast (M? (a × Alpha_context.context))
(traced
(let? lambda_rec_ty := Script_typed_ir.lambda_t loc_value ta tr in
parse_lam_rec elab_conf (stack_depth +i 1)
(Tc_context.add_lambda Tc_context.data) ctxt ta tr lambda_rec_ty
script_instr))
| (Script_typed_ir.Lambda_t _ _ _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Seq_kind ], (kind_value expr))))
| (Script_typed_ir.Option_t t_value _ _, expr) ⇒
let 'existT _ __11 [expr, t_value] :=
cast_exists (Es := Set)
(fun __11 ⇒ [Alpha_context.Script.node ** Script_typed_ir.ty])
[expr, t_value] in
cast (M? (a × Alpha_context.context))
(let parse_v
(ctxt : Alpha_context.context) (v_value : Alpha_context.Script.node)
: M? (__11 × Alpha_context.context) :=
non_terminal_recursion ctxt t_value v_value in
traced (parse_option parse_v ctxt legacy expr))
| (Script_typed_ir.List_t t_value _ty_name, Micheline.Seq _loc items) ⇒
let 'existT _ __12 [items, _loc, _ty_name, t_value] :=
cast_exists (Es := Set)
(fun __12 ⇒
[list
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim) ** Alpha_context.Script.location **
Script_typed_ir.ty_metadata ** Script_typed_ir.ty])
[items, _loc, _ty_name, t_value] in
cast (M? (a × Alpha_context.context))
(traced
(List.fold_right_es
(fun (v_value : Alpha_context.Script.node) ⇒
fun (function_parameter : Script_list.t __12 × Alpha_context.context)
⇒
let '(rest, ctxt) := function_parameter in
let? '(v_value, ctxt) := non_terminal_recursion ctxt t_value v_value
in
return? ((Script_list.cons_value v_value rest), ctxt)) items
(Script_list.empty, ctxt)))
| (Script_typed_ir.List_t _ _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Seq_kind ], (kind_value expr))))
| (Script_typed_ir.Ticket_t t_value _ty_name, expr) ⇒
let 'existT _ __14 [expr, _ty_name, t_value] :=
cast_exists (Es := Set)
(fun __14 ⇒
[Alpha_context.Script.node ** Script_typed_ir.ty_metadata **
Script_typed_ir.comparable_ty]) [expr, _ty_name, t_value] in
cast (M? (a × Alpha_context.context))
(if allow_forged then
let? ty_value := opened_ticket_type (location expr) t_value in
let?
'(({|
Script_typed_ir.address.destination := destination;
Script_typed_ir.address.entrypoint := _
|}, (contents, amount)), ctxt) :=
non_terminal_recursion ctxt ty_value expr in
match Ticket_amount.of_n amount with
| Some amount ⇒
match destination with
| Alpha_context.Destination.Contract ticketer ⇒
return?
({| Script_typed_ir.ticket.ticketer := ticketer;
Script_typed_ir.ticket.contents := (contents : __14);
Script_typed_ir.ticket.amount := amount; |}, ctxt)
|
(Alpha_context.Destination.Tx_rollup _ |
Alpha_context.Destination.Sc_rollup _ |
Alpha_context.Destination.Zk_rollup _) ⇒
Error_monad.tzfail
(Build_extensible "Unexpected_ticket_owner"
Alpha_context.Destination.t destination)
end
| None ⇒
traced_fail (Build_extensible "Forbidden_zero_ticket_quantity" unit tt)
end
else
traced_fail
(Build_extensible "Unexpected_forged_value"
Alpha_context.Script.location (location expr)))
|
(Script_typed_ir.Set_t t_value _ty_name,
(Micheline.Seq loc_value vs) as expr) ⇒
let 'existT _ __15 [expr, vs, loc_value, _ty_name, t_value] :=
cast_exists (Es := Set)
(fun __15 ⇒
[Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim **
list
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim) ** Alpha_context.Script.location **
Script_typed_ir.ty_metadata ** Script_typed_ir.comparable_ty])
[expr, vs, loc_value, _ty_name, t_value] in
cast (M? (a × Alpha_context.context))
(let? '(_, set, ctxt) :=
traced
(List.fold_left_es
(fun (function_parameter :
option __15 × Script_typed_ir.set __15 × Alpha_context.context) ⇒
let '(last_value, set, ctxt) := function_parameter in
fun (v_value : Alpha_context.Script.node) ⇒
let? '(v_value, ctxt) :=
non_terminal_recursion ctxt t_value v_value in
let? ctxt :=
match last_value with
| Some value_value ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.compare t_value
value_value v_value) in
let c_value :=
Script_comparable.compare_comparable t_value value_value
v_value in
if 0 ≤i c_value then
if 0 =i c_value then
Error_monad.error_value
(Build_extensible "Duplicate_set_values"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
Error_monad.error_value
(Build_extensible "Unordered_set_values"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
return? ctxt
| None ⇒ return? ctxt
end in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.set_update v_value set)
in
return?
((Some v_value), (Script_set.update v_value true set), ctxt))
(None, (Script_set.empty t_value), ctxt) vs) in
return? (set, ctxt))
| (Script_typed_ir.Set_t _ _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Seq_kind ], (kind_value expr))))
| (Script_typed_ir.Map_t tk tv _ty_name, (Micheline.Seq _ vs) as expr) ⇒
let 'existT _ [__17, __18] [expr, vs, _ty_name, tv, tk] :=
cast_exists (Es := [Set ** Set])
(fun '[__17, __18] ⇒
[Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim **
list
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim) ** Script_typed_ir.ty_metadata **
Script_typed_ir.ty ** Script_typed_ir.comparable_ty])
[expr, vs, _ty_name, tv, tk] in
cast (M? (a × Alpha_context.context))
((parse_items :
Alpha_context.context →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
Script_typed_ir.ty → Script_typed_ir.ty →
list
(Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
→ (__18 → __18) →
M? (Script_typed_ir.map __17 __18 × Alpha_context.context)) ctxt expr tk
tv vs (fun (x_value : __18) ⇒ x_value))
| (Script_typed_ir.Map_t _ _ _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Seq_kind ], (kind_value expr))))
| (Script_typed_ir.Big_map_t tk tv _ty_name, expr) ⇒
let 'existT _ [__21, __22] [expr, _ty_name, tv, tk] :=
cast_exists (Es := [Set ** Set])
(fun '[__21, __22] ⇒
[Alpha_context.Script.node ** Script_typed_ir.ty_metadata **
Script_typed_ir.ty ** Script_typed_ir.comparable_ty])
[expr, _ty_name, tv, tk] in
cast (M? (a × Alpha_context.context))
(let? '(id_opt, diff_value, ctxt) :=
match expr with
| Micheline.Int loc_value id ⇒
((return?
((Some (id, loc_value)),
{|
Script_typed_ir.big_map_overlay.map :=
Script_typed_ir.Big_map_overlay.(Map.S.empty);
Script_typed_ir.big_map_overlay.size := 0; |}, ctxt)) :
M?
(option (Z.t × Alpha_context.Script.location) ×
Script_typed_ir.big_map_overlay __21 __22 × Alpha_context.context))
| Micheline.Seq _ vs ⇒
let? '(diff_value, ctxt) :=
parse_big_map_items ctxt expr tk tv vs
(fun (x_value : __22) ⇒ Some x_value) in
return? (None, diff_value, ctxt)
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Pair
(cons (Micheline.Int loc_id id) (cons (Micheline.Seq _ vs) [])) annot
⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? tv_opt := Script_typed_ir.option_t loc_value tv in
let? '(diff_value, ctxt) :=
parse_big_map_items ctxt expr tk tv_opt vs
(fun (x_value : option __22) ⇒ x_value) in
return? ((Some (id, loc_id)), diff_value, ctxt)
|
Micheline.Prim _ Michelson_v1_primitives.D_Pair
(cons (Micheline.Int _ _) (cons expr [])) _ ⇒
traced_fail
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Seq_kind ], (kind_value expr)))
|
Micheline.Prim _ Michelson_v1_primitives.D_Pair (cons expr (cons _ []))
_ ⇒
traced_fail
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Int_kind ], (kind_value expr)))
| Micheline.Prim loc_value Michelson_v1_primitives.D_Pair l_value _ ⇒
traced_fail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
int)
(loc_value, Michelson_v1_primitives.D_Pair, 2, (List.length l_value)))
| _ ⇒
traced_fail
(unexpected expr
[ Script_tc_errors.Seq_kind; Script_tc_errors.Int_kind ]
Michelson_v1_primitives.Constant_namespace
[ Michelson_v1_primitives.D_Pair ])
end in
let? '(id, ctxt) :=
match id_opt with
| None ⇒ return? (None, ctxt)
| Some (id, loc_value) ⇒
if allow_forged then
let id := Alpha_context.Big_map.Id.parse_z id in
let? function_parameter := Alpha_context.Big_map._exists ctxt id in
match function_parameter with
| (_, None) ⇒
traced_fail
(Build_extensible "Invalid_big_map"
(Alpha_context.Script.location × Alpha_context.Big_map.Id.t)
(loc_value, id))
| (ctxt, Some (btk, btv)) ⇒
let? '(Ex_comparable_ty btk, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1)
(Micheline.root_value btk) in
let? '(Script_typed_ir.Ex_ty btv, ctxt) :=
parse_big_map_value_ty_aux ctxt (stack_depth +i 1) legacy
(Micheline.root_value btv) in
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(let error_details := Script_tc_errors.Informative loc_value in
Gas_monad.Syntax.op_letstar (ty_eq error_details tk btk)
(fun function_parameter ⇒
let 'Eq := function_parameter in
ty_eq error_details tv btv)) in
let? 'Eq := eq_value in
return? ((Some id), ctxt)
end
else
traced_fail
(Build_extensible "Unexpected_forged_value"
Alpha_context.Script.location loc_value)
end in
return?
((Script_typed_ir.Big_map
{| Script_typed_ir.big_map.Big_map.id := id;
Script_typed_ir.big_map.Big_map.diff := diff_value;
Script_typed_ir.big_map.Big_map.key_type := tk;
Script_typed_ir.big_map.Big_map.value_type := tv; |}), ctxt))
| (Script_typed_ir.Never_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context)) (traced_no_lwt (parse_never expr))
| (Script_typed_ir.Bls12_381_g1_t, Micheline.Bytes _ bs) ⇒
let bs := cast bytes bs in
cast (M? (a × Alpha_context.context))
(let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.bls12_381_g1 in
match
Script_typed_ir.Script_bls.G1.(Script_typed_ir.Script_bls.S.of_bytes_opt)
bs with
| Some pt ⇒ return? (pt, ctxt)
| None ⇒ fail_parse_data tt
end)
| (Script_typed_ir.Bls12_381_g1_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
| (Script_typed_ir.Bls12_381_g2_t, Micheline.Bytes _ bs) ⇒
let bs := cast bytes bs in
cast (M? (a × Alpha_context.context))
(let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.bls12_381_g2 in
match
Script_typed_ir.Script_bls.G2.(Script_typed_ir.Script_bls.S.of_bytes_opt)
bs with
| Some pt ⇒ return? (pt, ctxt)
| None ⇒ fail_parse_data tt
end)
| (Script_typed_ir.Bls12_381_g2_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
| (Script_typed_ir.Bls12_381_fr_t, Micheline.Bytes _ bs) ⇒
let bs := cast bytes bs in
cast (M? (a × Alpha_context.context))
(let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.bls12_381_fr in
match Script_typed_ir.Script_bls.Fr.of_bytes_opt bs with
| Some pt ⇒ return? (pt, ctxt)
| None ⇒ fail_parse_data tt
end)
| (Script_typed_ir.Bls12_381_fr_t, Micheline.Int _ v_value) ⇒
let v_value := cast Z.t v_value in
cast (M? (a × Alpha_context.context))
(let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.bls12_381_fr in
return? ((Script_typed_ir.Script_bls.Fr.of_z v_value), ctxt))
| (Script_typed_ir.Bls12_381_fr_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
|
(Script_typed_ir.Sapling_transaction_t memo_size,
Micheline.Bytes _ bytes_value) ⇒
let '[bytes_value, memo_size] :=
cast [bytes ** Alpha_context.Sapling.Memo_size.t] [bytes_value, memo_size]
in
cast (M? (a × Alpha_context.context))
match
Data_encoding.Binary.of_bytes_opt
Alpha_context.Sapling.transaction_encoding bytes_value with
| Some transaction ⇒
match Alpha_context.Sapling.transaction_get_memo_size transaction with
| None ⇒ return? (transaction, ctxt)
| Some transac_memo_size ⇒
let? '_ :=
memo_size_eq (Script_tc_errors.Informative tt) memo_size
transac_memo_size in
return? (transaction, ctxt)
end
| None ⇒ fail_parse_data tt
end
| (Script_typed_ir.Sapling_transaction_t _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
|
(Script_typed_ir.Sapling_transaction_deprecated_t memo_size,
Micheline.Bytes _ bytes_value) ⇒
let '[bytes_value, memo_size] :=
cast [bytes ** Alpha_context.Sapling.Memo_size.t] [bytes_value, memo_size]
in
cast (M? (a × Alpha_context.context))
match
Data_encoding.Binary.of_bytes_opt
Alpha_context.Sapling.Legacy.transaction_encoding bytes_value with
| Some transaction ⇒
match Alpha_context.Sapling.Legacy.transaction_get_memo_size transaction
with
| None ⇒ return? (transaction, ctxt)
| Some transac_memo_size ⇒
let? '_ :=
memo_size_eq (Script_tc_errors.Informative tt) memo_size
transac_memo_size in
return? (transaction, ctxt)
end
| None ⇒ fail_parse_data tt
end
| (Script_typed_ir.Sapling_transaction_deprecated_t _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
| (Script_typed_ir.Sapling_state_t memo_size, Micheline.Int loc_value id) ⇒
let '[id, loc_value, memo_size] :=
cast
[Z.t ** Alpha_context.Script.location **
Alpha_context.Sapling.Memo_size.t] [id, loc_value, memo_size] in
cast (M? (a × Alpha_context.context))
(if allow_forged then
let id := Alpha_context.Sapling.Id.parse_z id in
let? '(state_value, ctxt) := Alpha_context.Sapling.state_from_id ctxt id
in
let? '_ :=
traced_no_lwt
(memo_size_eq (Script_tc_errors.Informative tt) memo_size
state_value.(Alpha_context.Sapling.state.memo_size)) in
return? (state_value, ctxt)
else
traced_fail
(Build_extensible "Unexpected_forged_value"
Alpha_context.Script.location loc_value))
| (Script_typed_ir.Sapling_state_t memo_size, Micheline.Seq _ []) ⇒
let memo_size := cast Alpha_context.Sapling.Memo_size.t memo_size in
cast (M? (a × Alpha_context.context))
((Error_monad._return :
Alpha_context.Sapling.state × Alpha_context.context →
M? (Alpha_context.Sapling.state × Alpha_context.context))
((Alpha_context.Sapling.empty_state None memo_size tt), ctxt))
| (Script_typed_ir.Sapling_state_t _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.Int_kind; Script_tc_errors.Seq_kind ],
(kind_value expr))))
| (Script_typed_ir.Chest_key_t, Micheline.Bytes _ bytes_value) ⇒
let bytes_value := cast bytes bytes_value in
cast (M? (a × Alpha_context.context))
(let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.chest_key_value
in
match
Data_encoding.Binary.of_bytes_opt
Script_typed_ir.Script_timelock.chest_key_encoding bytes_value with
| Some chest_key_value ⇒ return? (chest_key_value, ctxt)
| None ⇒ fail_parse_data tt
end)
| (Script_typed_ir.Chest_key_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
| (Script_typed_ir.Chest_t, Micheline.Bytes _ bytes_value) ⇒
let bytes_value := cast bytes bytes_value in
cast (M? (a × Alpha_context.context))
(let? ctxt :=
Alpha_context.Gas.consume ctxt
(Typecheck_costs.chest_value (Bytes.length bytes_value)) in
match
Data_encoding.Binary.of_bytes_opt
Script_typed_ir.Script_timelock.chest_encoding bytes_value with
| Some chest_value ⇒ return? (chest_value, ctxt)
| None ⇒ fail_parse_data tt
end)
| (Script_typed_ir.Chest_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
end
with parse_view
(elab_conf : elab_conf) (ctxt : Alpha_context.context)
(storage_type : Script_typed_ir.ty)
(function_parameter : Script_typed_ir.view) {struct ctxt}
: M? (typed_view × Alpha_context.context) :=
let '{|
Script_typed_ir.view.input_ty := input_ty;
Script_typed_ir.view.output_ty := output_ty;
Script_typed_ir.view.view_code := view_code
|} := function_parameter in
let legacy := elab_conf.(Script_ir_translator_config.elab_config.legacy) in
let input_ty_loc := location input_ty in
let? '(Script_typed_ir.Ex_ty input_ty, ctxt) :=
Error_monad.record_trace_eval
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
Build_extensible "Ill_formed_type"
(option string × Micheline.canonical Alpha_context.Script.prim ×
Alpha_context.Script.location)
((Some "arg of view"), (Micheline.strip_locations input_ty),
input_ty_loc)) (parse_view_input_ty ctxt 0 legacy input_ty) in
let output_ty_loc := location output_ty in
let? '(Script_typed_ir.Ex_ty output_ty, ctxt) :=
Error_monad.record_trace_eval
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
Build_extensible "Ill_formed_type"
(option string × Micheline.canonical Alpha_context.Script.prim ×
Alpha_context.Script.location)
((Some "return of view"), (Micheline.strip_locations output_ty),
output_ty_loc)) (parse_view_output_ty ctxt 0 legacy output_ty) in
let? 'Script_typed_ir.Ty_ex_c pair_ty :=
Script_typed_ir.pair_t input_ty_loc input_ty storage_type in
let? '(judgement_value, ctxt) :=
parse_instr_aux elab_conf 0 Tc_context.view ctxt view_code
(Script_typed_ir.Item_t pair_ty Script_typed_ir.Bot_t) in
match judgement_value with
| Failed {| judgement.Failed.descr := descr_value |} ⇒
let '{| Script_typed_ir.kdescr.kinstr := kinstr |} :=
close_descr
(descr_value (Script_typed_ir.Item_t output_ty Script_typed_ir.Bot_t))
in
return?
((Typed_view
{| typed_view.Typed_view.input_ty := input_ty;
typed_view.Typed_view.output_ty := output_ty;
typed_view.Typed_view.kinstr := kinstr;
typed_view.Typed_view.original_code_expr := view_code; |}), ctxt)
| Typed ({| descr.loc := loc_value; descr.aft := aft |} as descr_value) ⇒
let ill_type_view
(stack_ty : Script_typed_ir.stack_ty)
(loc_value : Alpha_context.Script.location) : Error_monad._error :=
let actual := Script_ir_unparser.serialize_stack_for_error ctxt stack_ty
in
let expected_stack :=
Script_typed_ir.Item_t output_ty Script_typed_ir.Bot_t in
let expected :=
Script_ir_unparser.serialize_stack_for_error ctxt expected_stack in
Build_extensible "Ill_typed_view" Script_tc_errors.Ill_typed_view
{| Script_tc_errors.Ill_typed_view.loc := loc_value;
Script_tc_errors.Ill_typed_view.actual := actual;
Script_tc_errors.Ill_typed_view.expected := expected; |} in
match aft with
| Script_typed_ir.Item_t ty_value Script_typed_ir.Bot_t ⇒
let error_details := Script_tc_errors.Informative loc_value in
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(Gas_monad.record_trace_eval error_details
(fun (loc_value : Alpha_context.Script.location) ⇒
ill_type_view aft loc_value)
(ty_eq error_details ty_value output_ty)) in
let? 'Eq := eq_value in
let '{| Script_typed_ir.kdescr.kinstr := kinstr |} :=
close_descr descr_value in
return?
((Typed_view
{| typed_view.Typed_view.input_ty := input_ty;
typed_view.Typed_view.output_ty := output_ty;
typed_view.Typed_view.kinstr := kinstr;
typed_view.Typed_view.original_code_expr := view_code; |}), ctxt)
| _ ⇒ Error_monad.error_value (ill_type_view aft loc_value)
end
end
with parse_instr_aux
(elab_conf : elab_conf) (stack_depth : int) (tc_context_value : tc_context)
(ctxt : Alpha_context.context) (script_instr : Alpha_context.Script.node)
(stack_ty : Script_typed_ir.stack_ty) {struct ctxt}
: M? (judgement × Alpha_context.context) :=
let parse_views := 'parse_views in
let parse_kdescr := 'parse_kdescr in
let parse_lam_rec := 'parse_lam_rec in
let for_logging_only {A : Set} (x_value : A) : option A :=
if
elab_conf.(Script_ir_translator_config.elab_config.keep_extra_types_for_interpreter_logging)
then
Some x_value
else
None in
let check_item_ty
(ctxt : Alpha_context.context) (exp : Script_typed_ir.ty)
(got : Script_typed_ir.ty) (loc_value : Alpha_context.Script.location)
(name : Alpha_context.Script.prim) (n_value : int) (m_value : int)
: M? (eq × Alpha_context.context) :=
Error_monad.record_trace_eval
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
let stack_ty :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_ty in
Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, name, m_value, stack_ty))
(Error_monad.record_trace (Build_extensible "Bad_stack_item" int n_value)
(let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(ty_eq (Script_tc_errors.Informative loc_value) exp got) in
let? 'Eq := eq_value in
return? (Eq, ctxt))) in
let log_stack
(loc_value : Alpha_context.Script.location)
(stack_ty : Script_typed_ir.stack_ty) (aft : Script_typed_ir.stack_ty)
: unit :=
match
(elab_conf.(Script_ir_translator_config.elab_config.type_logger),
script_instr) with
|
((None, _) |
(Some _, (Micheline.Int _ _ | Micheline.String _ _ | Micheline.Bytes _ _)))
⇒ tt
| (Some log, (Micheline.Prim _ _ _ _ | Micheline.Seq _ _)) ⇒
let stack_ty_before :=
Script_ir_unparser.unparse_stack_uncarbonated stack_ty in
let stack_ty_after := Script_ir_unparser.unparse_stack_uncarbonated aft in
log loc_value stack_ty_before stack_ty_after
end in
let typed_no_lwt {A B : Set}
(ctxt : A) (loc_value : Alpha_context.Script.location) (instr : cinstr)
(aft : Script_typed_ir.stack_ty) : Pervasives.result (judgement × A) B :=
let '_ := log_stack loc_value stack_ty aft in
let j_value :=
Typed
{| descr.loc := loc_value; descr.bef := stack_ty; descr.aft := aft;
descr.instr := instr; |} in
Pervasives.Ok (j_value, ctxt) in
let typed {A B : Set}
(ctxt : A) (loc_value : Alpha_context.Script.location) (instr : cinstr)
(aft : Script_typed_ir.stack_ty) : Pervasives.result (judgement × A) B :=
typed_no_lwt ctxt loc_value instr aft in
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle
in
let non_terminal_recursion
(tc_context_value : tc_context) (ctxt : Alpha_context.context)
(script_instr : Alpha_context.Script.node)
(stack_ty : Script_typed_ir.stack_ty)
: M? (judgement × Alpha_context.context) :=
if stack_depth >i 10000 then
Error_monad.tzfail
(Build_extensible "Typechecking_too_many_recursive_calls" unit tt)
else
parse_instr_aux elab_conf (stack_depth +i 1) tc_context_value ctxt
script_instr stack_ty in
let bad_stack_error {A : Set}
(ctxt : Alpha_context.context) (loc_value : Alpha_context.Script.location)
(prim : Alpha_context.Script.prim) (relevant_stack_portion : int) : M? A :=
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_ty in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, prim, relevant_stack_portion, whole_stack)) in
let legacy := elab_conf.(Script_ir_translator_config.elab_config.legacy) in
match (script_instr, stack_ty) with
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DROP [] annot,
Script_typed_ir.Item_t _ rest) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
typed ctxt loc_value
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDrop loc_value k_value; |} rest
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DROP (cons n_value [])
result_annot, whole_stack) ⇒
let? whole_n := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) in
let fix make_proof_argument (n_value : int) (stk : Script_typed_ir.stack_ty)
: M? dropn_proof_argument :=
match ((n_value =i 0), stk) with
| (true, rest) ⇒
return? (Dropn_proof_argument Script_typed_ir.KRest rest)
| (false, Script_typed_ir.Item_t a_value rest) ⇒
let? 'Dropn_proof_argument n' stack_after_drops :=
make_proof_argument (n_value -i 1) rest in
return?
(Dropn_proof_argument (Script_typed_ir.KPrefix loc_value a_value n')
stack_after_drops)
| (_, _) ⇒
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt whole_stack in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_DROP, whole_n, whole_stack))
end in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value result_annot in
let? 'Dropn_proof_argument n' stack_after_drops :=
make_proof_argument whole_n whole_stack in
let kdropn (k_value : Script_typed_ir.kinstr) : Script_typed_ir.kinstr :=
Script_typed_ir.IDropn loc_value whole_n n' k_value in
typed ctxt loc_value {| cinstr.apply := kdropn; |} stack_after_drops
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DROP
((cons _ (cons _ _)) as l_value) _, _) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.I_DROP, 1, (List.length l_value)))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DUP [] annot,
(Script_typed_ir.Item_t v_value _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? ctxt :=
Error_monad.record_trace_eval
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
let t_value := Script_ir_unparser.serialize_ty_for_error v_value in
Build_extensible "Non_dupable_type"
(Alpha_context.Script.location × Alpha_context.Script.expr)
(loc_value, t_value)) (check_dupable_ty ctxt loc_value v_value) in
let dup :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDup loc_value k_value; |} in
typed ctxt loc_value dup (Script_typed_ir.Item_t v_value stack_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DUP (cons n_value [])
v_annot, (Script_typed_ir.Item_t _ _) as stack_ty) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value v_annot in
let fix make_proof_argument
(n_value : int) (stack_ty : Script_typed_ir.stack_ty)
: M? dup_n_proof_argument :=
match (n_value, stack_ty) with
| (1, Script_typed_ir.Item_t hd_ty _) ⇒
return? (Dup_n_proof_argument Script_typed_ir.Dup_n_zero hd_ty)
|
(n_value,
Script_typed_ir.Item_t _ ((Script_typed_ir.Item_t _ _) as tl_ty)) ⇒
let? 'Dup_n_proof_argument dup_n_witness b_ty :=
make_proof_argument (n_value -i 1) tl_ty in
return?
(Dup_n_proof_argument (Script_typed_ir.Dup_n_succ dup_n_witness) b_ty)
| _ ⇒ bad_stack_error ctxt loc_value Michelson_v1_primitives.I_DUP 1
end in
let? n_value := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
let? '_ :=
Error_monad.error_unless (n_value >i 0)
(Build_extensible "Dup_n_bad_argument" Alpha_context.Script.location
loc_value) in
let? 'Dup_n_proof_argument witness after_ty :=
Error_monad.record_trace
(Build_extensible "Dup_n_bad_stack" Alpha_context.Script.location
loc_value) (make_proof_argument n_value stack_ty) in
let? ctxt :=
Error_monad.record_trace_eval
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
let t_value := Script_ir_unparser.serialize_ty_for_error after_ty in
Build_extensible "Non_dupable_type"
(Alpha_context.Script.location × Alpha_context.Script.expr)
(loc_value, t_value)) (check_dupable_ty ctxt loc_value after_ty) in
let dupn :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDup_n loc_value n_value witness k_value; |} in
typed ctxt loc_value dupn (Script_typed_ir.Item_t after_ty stack_ty)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DIG (cons n_value [])
result_annot, stack_value) ⇒
let fix make_proof_argument (n_value : int) (stk : Script_typed_ir.stack_ty)
: M? dig_proof_argument :=
match ((n_value =i 0), stk) with
| (true, Script_typed_ir.Item_t v_value rest) ⇒
return? (Dig_proof_argument Script_typed_ir.KRest v_value rest)
| (false, Script_typed_ir.Item_t v_value rest) ⇒
let? 'Dig_proof_argument n' x_value aft' :=
make_proof_argument (n_value -i 1) rest in
return?
(Dig_proof_argument (Script_typed_ir.KPrefix loc_value v_value n')
x_value (Script_typed_ir.Item_t v_value aft'))
| (_, _) ⇒
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_DIG, 3, whole_stack))
end in
let? n_value := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value result_annot in
let? 'Dig_proof_argument n' x_value aft :=
make_proof_argument n_value stack_value in
let dig :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDig loc_value n_value n' k_value; |} in
typed ctxt loc_value dig (Script_typed_ir.Item_t x_value aft)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DIG
(([] | cons _ (cons _ _)) as l_value) _, _) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.I_DIG, 1, (List.length l_value)))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DUG (cons n_value [])
result_annot, Script_typed_ir.Item_t x_value whole_stack) ⇒
let? whole_n := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value result_annot in
match make_dug_proof_argument loc_value whole_n x_value whole_stack with
| None ⇒
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt whole_stack in
Error_monad.tzfail
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_DUG, whole_n, whole_stack))
| Some (Dug_proof_argument (n', aft)) ⇒
let dug :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDug loc_value whole_n n' k_value; |} in
typed ctxt loc_value dug aft
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DUG (cons _ [])
result_annot, stack_value) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value result_annot in
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_DUG, 1, stack_value))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DUG
(([] | cons _ (cons _ _)) as l_value) _, _) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.I_DUG, 1, (List.length l_value)))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SWAP [] annot,
Script_typed_ir.Item_t v_value (Script_typed_ir.Item_t w_value rest)) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let swap :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISwap loc_value k_value; |} in
let stack_ty :=
Script_typed_ir.Item_t w_value (Script_typed_ir.Item_t v_value rest) in
typed ctxt loc_value swap stack_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_PUSH
(cons t_value (cons d_value [])) annot, stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_packable_ty_aux ctxt (stack_depth +i 1) legacy t_value in
let 'existT _ __Ex_ty_'a3 [ctxt, t_value] :=
cast_exists (Es := Set)
(fun __Ex_ty_'a3 ⇒ [Alpha_context.context ** Script_typed_ir.ty])
[ctxt, t_value] in
let? '(v_value, ctxt) :=
parse_data_aux elab_conf (stack_depth +i 1) ctxt false t_value d_value in
let const :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IConst loc_value t_value (v_value : __Ex_ty_'a3)
k_value; |} in
typed ctxt loc_value const (Script_typed_ir.Item_t t_value stack_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UNIT [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let const :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IConst loc_value Script_typed_ir.unit_t tt k_value;
|} in
typed ctxt loc_value const
(Script_typed_ir.Item_t Script_typed_ir.unit_t stack_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SOME [] annot,
Script_typed_ir.Item_t t_value rest) ⇒
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let cons_some :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICons_some loc_value k_value; |} in
let? ty_value := Script_typed_ir.option_t loc_value t_value in
typed ctxt loc_value cons_some (Script_typed_ir.Item_t ty_value rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NONE (cons t_value [])
annot, stack_value) ⇒
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy t_value in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let cons_none :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICons_none loc_value t_value k_value; |} in
let? ty_value := Script_typed_ir.option_t loc_value t_value in
let stack_ty := Script_typed_ir.Item_t ty_value stack_value in
typed ctxt loc_value cons_none stack_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MAP (cons body []) annot,
Script_typed_ir.Item_t (Script_typed_ir.Option_t t_value _ _) rest) ⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t t_value rest) in
match judgement_value with
|
Typed
({|
descr.loc := loc_value;
descr.aft := Script_typed_ir.Item_t ret_value aft_rest
|} as kibody) ⇒
let invalid_map_body (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt kibody.(descr.aft)
in
Build_extensible "Invalid_map_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty)
(loc_value, aft) in
Error_monad.record_trace_eval invalid_map_body
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 aft_rest rest in
let? opt_ty := Script_typed_ir.option_t loc_value ret_value in
let final_stack := Script_typed_ir.Item_t opt_ty rest in
let body :=
kibody.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt loc_value)
in
let apply (k_value : Script_typed_ir.kinstr) : Script_typed_ir.kinstr :=
Script_typed_ir.IOpt_map
{| Script_typed_ir.kinstr.IOpt_map.loc := loc_value;
Script_typed_ir.kinstr.IOpt_map.body := body;
Script_typed_ir.kinstr.IOpt_map.k := k_value; |} in
typed_no_lwt ctxt loc_value {| cinstr.apply := apply; |} final_stack)
| Typed {| descr.aft := Script_typed_ir.Bot_t |} ⇒
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt Script_typed_ir.Bot_t
in
Error_monad.error_value
(Build_extensible "Invalid_map_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty)
(loc_value, aft))
| Failed _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_map_block_fail" Alpha_context.Script.location
loc_value)
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_IF_NONE
(cons bt (cons bf [])) annot,
(Script_typed_ir.Item_t (Script_typed_ir.Option_t t_value _ _) rest) as
bef) ⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bt in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bf in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(btr, ctxt) := non_terminal_recursion tc_context_value ctxt bt rest in
let stack_ty := Script_typed_ir.Item_t t_value rest in
let? '(bfr, ctxt) :=
non_terminal_recursion tc_context_value ctxt bf stack_ty in
let branch (ibt : descr) (ibf : descr) : descr :=
let ifnone :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hloc := Script_typed_ir.kinstr_location k_value in
let branch_if_none : Script_typed_ir.kinstr :=
ibt.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc)
in let branch_if_some : Script_typed_ir.kinstr :=
ibf.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc) in
Script_typed_ir.IIf_none
{| Script_typed_ir.kinstr.IIf_none.loc := loc_value;
Script_typed_ir.kinstr.IIf_none.branch_if_none :=
branch_if_none;
Script_typed_ir.kinstr.IIf_none.branch_if_some :=
branch_if_some;
Script_typed_ir.kinstr.IIf_none.k := k_value; |}; |} in
{| descr.loc := loc_value; descr.bef := bef; descr.aft := ibt.(descr.aft);
descr.instr := ifnone; |} in
merge_branches ctxt loc_value btr bfr {| branch.branch := branch; |}
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_PAIR [] annot,
Script_typed_ir.Item_t a_value (Script_typed_ir.Item_t b_value rest)) ⇒
let? '_ := Script_ir_annot.check_constr_annot loc_value annot in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.pair_t loc_value a_value b_value in
let stack_ty := Script_typed_ir.Item_t ty_value rest in
let cons_pair :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICons_pair loc_value k_value; |} in
typed ctxt loc_value cons_pair stack_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_PAIR (cons n_value [])
annot, (Script_typed_ir.Item_t _ _) as stack_ty) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let fix make_proof_argument
(n_value : int) (stack_ty : Script_typed_ir.stack_ty)
: M? comb_proof_argument :=
match (n_value, stack_ty) with
| (1, Script_typed_ir.Item_t _ _) ⇒
return? (Comb_proof_argument Script_typed_ir.Comb_one stack_ty)
|
(n_value,
Script_typed_ir.Item_t a_ty ((Script_typed_ir.Item_t _ _) as tl_ty))
⇒
let? function_parameter := make_proof_argument (n_value -i 1) tl_ty in
match function_parameter with
| Comb_proof_argument comb_witness (Script_typed_ir.Item_t b_ty tl_ty')
⇒
let? 'Script_typed_ir.Ty_ex_c pair_t :=
Script_typed_ir.pair_t loc_value a_ty b_ty in
return?
(Comb_proof_argument (Script_typed_ir.Comb_succ comb_witness)
(Script_typed_ir.Item_t pair_t tl_ty'))
| _ ⇒ unreachable_gadt_branch
end
| _ ⇒ bad_stack_error ctxt loc_value Michelson_v1_primitives.I_PAIR 1
end in
let? n_value := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
let? '_ :=
Error_monad.error_unless (n_value >i 1)
(Build_extensible "Pair_bad_argument" Alpha_context.Script.location
loc_value) in
let? 'Comb_proof_argument witness after_ty :=
make_proof_argument n_value stack_ty in
let comb :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IComb loc_value n_value witness k_value; |} in
typed ctxt loc_value comb after_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UNPAIR (cons n_value [])
annot, (Script_typed_ir.Item_t _ _) as stack_ty) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let fix make_proof_argument
(n_value : int) (stack_ty : Script_typed_ir.stack_ty) {struct n_value}
: M? uncomb_proof_argument :=
match (n_value, stack_ty) with
| (1, (Script_typed_ir.Item_t _ _) as stack_value) ⇒
return? (Uncomb_proof_argument Script_typed_ir.Uncomb_one stack_value)
|
(n_value,
Script_typed_ir.Item_t (Script_typed_ir.Pair_t a_ty b_ty _ _) tl_ty)
⇒
let? 'Uncomb_proof_argument uncomb_witness after_ty :=
make_proof_argument (n_value -i 1) (Script_typed_ir.Item_t b_ty tl_ty)
in
return?
(Uncomb_proof_argument (Script_typed_ir.Uncomb_succ uncomb_witness)
(Script_typed_ir.Item_t a_ty after_ty))
| _ ⇒ bad_stack_error ctxt loc_value Michelson_v1_primitives.I_UNPAIR 1
end in
let? n_value := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
let? '_ :=
Error_monad.error_unless (n_value >i 1)
(Build_extensible "Unpair_bad_argument" Alpha_context.Script.location
loc_value) in
let? 'Uncomb_proof_argument witness after_ty :=
make_proof_argument n_value stack_ty in
let uncomb :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IUncomb loc_value n_value witness k_value; |} in
typed ctxt loc_value uncomb after_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GET (cons n_value [])
annot, Script_typed_ir.Item_t comb_ty rest_ty) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? n_value := parse_uint11 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
match make_comb_get_proof_argument n_value comb_ty with
| None ⇒
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_ty in
Error_monad.tzfail
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_GET, 1, whole_stack))
| Some (Comb_get_proof_argument witness ty') ⇒
let after_stack_ty := Script_typed_ir.Item_t ty' rest_ty in
let comb_get :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IComb_get loc_value n_value witness k_value; |} in
typed ctxt loc_value comb_get after_stack_ty
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UPDATE (cons n_value [])
annot,
Script_typed_ir.Item_t value_ty (Script_typed_ir.Item_t comb_ty rest_ty))
⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? n_value := parse_uint11 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
let? 'Comb_set_proof_argument witness after_ty :=
make_comb_set_proof_argument ctxt stack_ty loc_value n_value value_ty
comb_ty in
let after_stack_ty := Script_typed_ir.Item_t after_ty rest_ty in
let comb_set :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IComb_set loc_value n_value witness k_value; |} in
typed ctxt loc_value comb_set after_stack_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UNPAIR [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Pair_t a_value b_value _ _) rest)
⇒
let? '_ := Script_ir_annot.check_unpair_annot loc_value annot in
let unpair :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IUnpair loc_value k_value; |} in
typed ctxt loc_value unpair
(Script_typed_ir.Item_t a_value (Script_typed_ir.Item_t b_value rest))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CAR [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Pair_t a_value _ _ _) rest) ⇒
let? '_ := Script_ir_annot.check_destr_annot loc_value annot in
let car :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICar loc_value k_value; |} in
typed ctxt loc_value car (Script_typed_ir.Item_t a_value rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CDR [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Pair_t _ b_value _ _) rest) ⇒
let? '_ := Script_ir_annot.check_destr_annot loc_value annot in
let cdr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICdr loc_value k_value; |} in
typed ctxt loc_value cdr (Script_typed_ir.Item_t b_value rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LEFT (cons tr []) annot,
Script_typed_ir.Item_t tl rest) ⇒
let? '(Script_typed_ir.Ex_ty tr, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy tr in
let? '_ := Script_ir_annot.check_constr_annot loc_value annot in
let cons_left :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICons_left loc_value tr k_value; |} in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.union_t loc_value tl tr in
let stack_ty := Script_typed_ir.Item_t ty_value rest in
typed ctxt loc_value cons_left stack_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_RIGHT (cons tl []) annot,
Script_typed_ir.Item_t tr rest) ⇒
let? '(Script_typed_ir.Ex_ty tl, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy tl in
let? '_ := Script_ir_annot.check_constr_annot loc_value annot in
let cons_right :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICons_right loc_value tl k_value; |} in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.union_t loc_value tl tr in
let stack_ty := Script_typed_ir.Item_t ty_value rest in
typed ctxt loc_value cons_right stack_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_IF_LEFT
(cons bt (cons bf [])) annot,
(Script_typed_ir.Item_t (Script_typed_ir.Union_t tl tr _ _) rest) as bef)
⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bt in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bf in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(btr, ctxt) :=
non_terminal_recursion tc_context_value ctxt bt
(Script_typed_ir.Item_t tl rest) in
let? '(bfr, ctxt) :=
non_terminal_recursion tc_context_value ctxt bf
(Script_typed_ir.Item_t tr rest) in
let branch (ibt : descr) (ibf : descr) : descr :=
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hloc := Script_typed_ir.kinstr_location k_value in
let branch_if_left : Script_typed_ir.kinstr :=
ibt.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc)
in let branch_if_right : Script_typed_ir.kinstr :=
ibf.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc) in
Script_typed_ir.IIf_left
{| Script_typed_ir.kinstr.IIf_left.loc := loc_value;
Script_typed_ir.kinstr.IIf_left.branch_if_left :=
branch_if_left;
Script_typed_ir.kinstr.IIf_left.branch_if_right :=
branch_if_right;
Script_typed_ir.kinstr.IIf_left.k := k_value; |}; |} in
{| descr.loc := loc_value; descr.bef := bef; descr.aft := ibt.(descr.aft);
descr.instr := instr; |} in
merge_branches ctxt loc_value btr bfr {| branch.branch := branch; |}
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NIL (cons t_value [])
annot, stack_value) ⇒
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy t_value in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let nil :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INil loc_value t_value k_value; |} in
let? ty_value := Script_typed_ir.list_t loc_value t_value in
typed ctxt loc_value nil (Script_typed_ir.Item_t ty_value stack_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CONS [] annot,
Script_typed_ir.Item_t tv
((Script_typed_ir.Item_t (Script_typed_ir.List_t t_value _) _) as
stack_value)) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt tv t_value loc_value Michelson_v1_primitives.I_CONS 1 2
in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let cons_list :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICons_list loc_value k_value; |} in
typed ctxt loc_value cons_list stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_IF_CONS
(cons bt (cons bf [])) annot,
(Script_typed_ir.Item_t (Script_typed_ir.List_t t_value _) rest) as bef)
⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bt in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bf in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(btr, ctxt) :=
non_terminal_recursion tc_context_value ctxt bt
(Script_typed_ir.Item_t t_value bef) in
let? '(bfr, ctxt) := non_terminal_recursion tc_context_value ctxt bf rest in
let branch (ibt : descr) (ibf : descr) : descr :=
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hloc := Script_typed_ir.kinstr_location k_value in
let branch_if_cons : Script_typed_ir.kinstr :=
ibt.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc)
in let branch_if_nil : Script_typed_ir.kinstr :=
ibf.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc) in
Script_typed_ir.IIf_cons
{| Script_typed_ir.kinstr.IIf_cons.loc := loc_value;
Script_typed_ir.kinstr.IIf_cons.branch_if_cons :=
branch_if_cons;
Script_typed_ir.kinstr.IIf_cons.branch_if_nil :=
branch_if_nil; Script_typed_ir.kinstr.IIf_cons.k := k_value;
|}; |} in
{| descr.loc := loc_value; descr.bef := bef; descr.aft := ibt.(descr.aft);
descr.instr := instr; |} in
merge_branches ctxt loc_value btr bfr {| branch.branch := branch; |}
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SIZE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.List_t _ _) rest) ⇒
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let list_size :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IList_size loc_value k_value; |} in
typed ctxt loc_value list_size
(Script_typed_ir.Item_t Script_typed_ir.nat_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MAP (cons body []) annot,
Script_typed_ir.Item_t (Script_typed_ir.List_t elt_value _) starting_rest)
⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t elt_value starting_rest) in
match judgement_value with
|
Typed
({| descr.aft := (Script_typed_ir.Item_t ret_value rest) as aft |} as
kibody) ⇒
let invalid_map_body (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft := Script_ir_unparser.serialize_stack_for_error ctxt aft in
Build_extensible "Invalid_map_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty)
(loc_value, aft) in
Error_monad.record_trace_eval invalid_map_body
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 rest starting_rest in
let hloc := loc_value in
let ibody :=
kibody.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc) in
let? ty_value := Script_typed_ir.list_t loc_value ret_value in
let list_map :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IList_map loc_value ibody
(for_logging_only ty_value) k_value; |} in
let stack_value := Script_typed_ir.Item_t ty_value rest in
typed_no_lwt ctxt loc_value list_map stack_value)
| Typed {| descr.aft := aft |} ⇒
let aft := Script_ir_unparser.serialize_stack_for_error ctxt aft in
Error_monad.error_value
(Build_extensible "Invalid_map_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty)
(loc_value, aft))
| Failed _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_map_block_fail" Alpha_context.Script.location
loc_value)
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ITER (cons body [])
annot, Script_typed_ir.Item_t (Script_typed_ir.List_t elt_value _) rest)
⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t elt_value rest) in
let mk_list_iter (ibody : descr) : cinstr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hinfo := loc_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hinfo)
in
Script_typed_ir.IList_iter loc_value (for_logging_only elt_value)
ibody k_value; |} in
match judgement_value with
| Typed ({| descr.aft := aft |} as ibody) ⇒
let invalid_iter_body (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt ibody.(descr.aft) in
let rest := Script_ir_unparser.serialize_stack_for_error ctxt rest in
Build_extensible "Invalid_iter_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Script_tc_errors.unparsed_stack_ty) (loc_value, rest, aft) in
Error_monad.record_trace_eval invalid_iter_body
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 aft rest in
typed_no_lwt ctxt loc_value (mk_list_iter ibody) rest)
| Failed {| judgement.Failed.descr := descr_value |} ⇒
typed_no_lwt ctxt loc_value (mk_list_iter (descr_value rest)) rest
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EMPTY_SET
(cons t_value []) annot, rest) ⇒
let? '(Ex_comparable_ty t_value, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) t_value in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEmpty_set loc_value t_value k_value; |} in
let? ty_value := Script_typed_ir.set_t loc_value t_value in
typed ctxt loc_value instr (Script_typed_ir.Item_t ty_value rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ITER (cons body [])
annot, Script_typed_ir.Item_t (Script_typed_ir.Set_t elt_value _) rest) ⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t elt_value rest) in
let mk_iset_iter (ibody : descr) : cinstr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hinfo := loc_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hinfo)
in
Script_typed_ir.ISet_iter loc_value (for_logging_only elt_value)
ibody k_value; |} in
match judgement_value with
| Typed ({| descr.aft := aft |} as ibody) ⇒
let invalid_iter_body (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt ibody.(descr.aft) in
let rest := Script_ir_unparser.serialize_stack_for_error ctxt rest in
Build_extensible "Invalid_iter_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Script_tc_errors.unparsed_stack_ty) (loc_value, rest, aft) in
Error_monad.record_trace_eval invalid_iter_body
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 aft rest in
typed_no_lwt ctxt loc_value (mk_iset_iter ibody) rest)
| Failed {| judgement.Failed.descr := descr_value |} ⇒
typed_no_lwt ctxt loc_value (mk_iset_iter (descr_value rest)) rest
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MEM [] annot,
Script_typed_ir.Item_t v_value
(Script_typed_ir.Item_t (Script_typed_ir.Set_t elt_value _) rest)) ⇒
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let? '(Eq, ctxt) :=
check_item_ty ctxt elt_value v_value loc_value
Michelson_v1_primitives.I_MEM 1 2 in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISet_mem loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.bool_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UPDATE [] annot,
Script_typed_ir.Item_t v_value
(Script_typed_ir.Item_t Script_typed_ir.Bool_t
((Script_typed_ir.Item_t (Script_typed_ir.Set_t elt_value _) _) as
stack_value))) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt elt_value v_value loc_value
Michelson_v1_primitives.I_UPDATE 1 3 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISet_update loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SIZE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Set_t _ _) rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISet_size loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.nat_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EMPTY_MAP
(cons tk (cons tv [])) annot, stack_value) ⇒
let? '(Ex_comparable_ty tk, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) tk in
let? '(Script_typed_ir.Ex_ty tv, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy tv in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEmpty_map loc_value tk (for_logging_only tv)
k_value; |} in
let? ty_value := Script_typed_ir.map_t loc_value tk tv in
typed ctxt loc_value instr (Script_typed_ir.Item_t ty_value stack_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MAP (cons body []) annot,
Script_typed_ir.Item_t (Script_typed_ir.Map_t kt elt_value _)
starting_rest) ⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.pair_t loc_value kt elt_value in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t ty_value starting_rest) in
match judgement_value with
|
Typed
({| descr.aft := (Script_typed_ir.Item_t ret_value rest) as aft |} as
ibody) ⇒
let invalid_map_body (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft := Script_ir_unparser.serialize_stack_for_error ctxt aft in
Build_extensible "Invalid_map_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty)
(loc_value, aft) in
Error_monad.record_trace_eval invalid_map_body
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 rest starting_rest in
let? ty_value := Script_typed_ir.map_t loc_value kt ret_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hinfo := loc_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt hinfo) in
Script_typed_ir.IMap_map loc_value (for_logging_only ty_value)
ibody k_value; |} in
let stack_value := Script_typed_ir.Item_t ty_value rest in
typed_no_lwt ctxt loc_value instr stack_value)
| Typed {| descr.aft := aft |} ⇒
let aft := Script_ir_unparser.serialize_stack_for_error ctxt aft in
Error_monad.error_value
(Build_extensible "Invalid_map_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty)
(loc_value, aft))
| Failed _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_map_block_fail" Alpha_context.Script.location
loc_value)
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ITER (cons body [])
annot,
Script_typed_ir.Item_t (Script_typed_ir.Map_t key_value element_ty _) rest)
⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.pair_t loc_value key_value element_ty in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t ty_value rest) in
let make_instr (ibody : descr) : cinstr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hinfo := loc_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hinfo)
in
Script_typed_ir.IMap_iter loc_value (for_logging_only ty_value)
ibody k_value; |} in
match judgement_value with
| Typed ({| descr.aft := aft |} as ibody) ⇒
let invalid_iter_body (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt ibody.(descr.aft) in
let rest := Script_ir_unparser.serialize_stack_for_error ctxt rest in
Build_extensible "Invalid_iter_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Script_tc_errors.unparsed_stack_ty) (loc_value, rest, aft) in
Error_monad.record_trace_eval invalid_iter_body
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 aft rest in
typed_no_lwt ctxt loc_value (make_instr ibody) rest)
| Failed {| judgement.Failed.descr := descr_value |} ⇒
typed_no_lwt ctxt loc_value (make_instr (descr_value rest)) rest
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MEM [] annot,
Script_typed_ir.Item_t vk
(Script_typed_ir.Item_t (Script_typed_ir.Map_t k_value _ _) rest)) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt vk k_value loc_value Michelson_v1_primitives.I_MEM 1 2
in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMap_mem loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.bool_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GET [] annot,
Script_typed_ir.Item_t vk
(Script_typed_ir.Item_t (Script_typed_ir.Map_t k_value elt_value _) rest))
⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt vk k_value loc_value Michelson_v1_primitives.I_GET 1 2
in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMap_get loc_value k_value; |} in
let? ty_value := Script_typed_ir.option_t loc_value elt_value in
typed ctxt loc_value instr (Script_typed_ir.Item_t ty_value rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UPDATE [] annot,
Script_typed_ir.Item_t vk
(Script_typed_ir.Item_t (Script_typed_ir.Option_t vv _ _)
((Script_typed_ir.Item_t (Script_typed_ir.Map_t k_value v_value _) _)
as stack_value))) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt vk k_value loc_value Michelson_v1_primitives.I_UPDATE 1
3 in
let? '(Eq, ctxt) :=
check_item_ty ctxt vv v_value loc_value Michelson_v1_primitives.I_UPDATE 2
3 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMap_update loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GET_AND_UPDATE [] annot,
Script_typed_ir.Item_t vk
((Script_typed_ir.Item_t (Script_typed_ir.Option_t vv _ _)
(Script_typed_ir.Item_t (Script_typed_ir.Map_t k_value v_value _) _))
as stack_value)) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt vk k_value loc_value
Michelson_v1_primitives.I_GET_AND_UPDATE 1 3 in
let? '(Eq, ctxt) :=
check_item_ty ctxt vv v_value loc_value
Michelson_v1_primitives.I_GET_AND_UPDATE 2 3 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMap_get_and_update loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SIZE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Map_t _ _ _) rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMap_size loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.nat_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EMPTY_BIG_MAP
(cons tk (cons tv [])) annot, stack_value) ⇒
let? '(Ex_comparable_ty tk, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) tk in
let? '(Script_typed_ir.Ex_ty tv, ctxt) :=
parse_big_map_value_ty_aux ctxt (stack_depth +i 1) legacy tv in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEmpty_big_map loc_value tk tv k_value; |} in
let? ty_value := Script_typed_ir.big_map_t loc_value tk tv in
let stack_value := Script_typed_ir.Item_t ty_value stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MEM [] annot,
Script_typed_ir.Item_t set_key
(Script_typed_ir.Item_t (Script_typed_ir.Big_map_t k_value _ _) rest))
⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt set_key k_value loc_value Michelson_v1_primitives.I_MEM
1 2 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBig_map_mem loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GET [] annot,
Script_typed_ir.Item_t vk
(Script_typed_ir.Item_t (Script_typed_ir.Big_map_t k_value elt_value _)
rest)) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt vk k_value loc_value Michelson_v1_primitives.I_GET 1 2
in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBig_map_get loc_value k_value; |} in
let? ty_value := Script_typed_ir.option_t loc_value elt_value in
let stack_value := Script_typed_ir.Item_t ty_value rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UPDATE [] annot,
Script_typed_ir.Item_t set_key
(Script_typed_ir.Item_t (Script_typed_ir.Option_t set_value _ _)
((Script_typed_ir.Item_t
(Script_typed_ir.Big_map_t map_key map_value _) _) as stack_value)))
⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt set_key map_key loc_value
Michelson_v1_primitives.I_UPDATE 1 3 in
let? '(Eq, ctxt) :=
check_item_ty ctxt set_value map_value loc_value
Michelson_v1_primitives.I_UPDATE 2 3 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBig_map_update loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GET_AND_UPDATE [] annot,
Script_typed_ir.Item_t vk
((Script_typed_ir.Item_t (Script_typed_ir.Option_t vv _ _)
(Script_typed_ir.Item_t (Script_typed_ir.Big_map_t k_value v_value _)
_)) as stack_value)) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt vk k_value loc_value
Michelson_v1_primitives.I_GET_AND_UPDATE 1 3 in
let? '(Eq, ctxt) :=
check_item_ty ctxt vv v_value loc_value
Michelson_v1_primitives.I_GET_AND_UPDATE 2 3 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBig_map_get_and_update loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SAPLING_EMPTY_STATE
(cons memo_size []) annot, rest) ⇒
let? memo_size := parse_memo_size memo_size in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISapling_empty_state loc_value memo_size k_value; |}
in
let stack_value :=
Script_typed_ir.Item_t (Script_typed_ir.sapling_state_t memo_size) rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SAPLING_VERIFY_UPDATE []
_,
Script_typed_ir.Item_t
(Script_typed_ir.Sapling_transaction_deprecated_t transaction_memo_size)
(Script_typed_ir.Item_t
((Script_typed_ir.Sapling_state_t state_memo_size) as state_ty) rest))
⇒
if legacy then
let? '_ :=
memo_size_eq (Script_tc_errors.Informative tt) state_memo_size
transaction_memo_size in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISapling_verify_update_deprecated loc_value
k_value; |} in
let? 'Script_typed_ir.Ty_ex_c pair_ty :=
Script_typed_ir.pair_t loc_value Script_typed_ir.int_t state_ty in
let? ty_value := Script_typed_ir.option_t loc_value pair_ty in
let stack_value := Script_typed_ir.Item_t ty_value rest in
typed ctxt loc_value instr stack_value
else
Error_monad.tzfail
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.T_sapling_transaction_deprecated)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SAPLING_VERIFY_UPDATE []
_,
Script_typed_ir.Item_t
(Script_typed_ir.Sapling_transaction_t transaction_memo_size)
(Script_typed_ir.Item_t
((Script_typed_ir.Sapling_state_t state_memo_size) as state_ty) rest))
⇒
let? '_ :=
memo_size_eq (Script_tc_errors.Informative tt) state_memo_size
transaction_memo_size in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISapling_verify_update loc_value k_value; |} in
let? 'Script_typed_ir.Ty_ex_c pair_ty :=
Script_typed_ir.pair_t loc_value Script_typed_ir.int_t state_ty in
let? 'Script_typed_ir.Ty_ex_c pair_ty :=
Script_typed_ir.pair_t loc_value Script_typed_ir.bytes_t pair_ty in
let? ty_value := Script_typed_ir.option_t loc_value pair_ty in
let stack_value := Script_typed_ir.Item_t ty_value rest in
typed ctxt loc_value instr stack_value
| (Micheline.Seq loc_value [], stack_value) ⇒
let instr :=
{| cinstr.apply := fun (k_value : Script_typed_ir.kinstr) ⇒ k_value; |}
in
typed ctxt loc_value instr stack_value
| (Micheline.Seq _ (cons single []), stack_value) ⇒
non_terminal_recursion tc_context_value ctxt single stack_value
| (Micheline.Seq loc_value (cons hd tl), stack_value) ⇒
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt hd stack_value in
match judgement_value with
| Failed _ ⇒
Error_monad.tzfail
(Build_extensible "Fail_not_in_tail_position"
Alpha_context.Script.location (Micheline.location hd))
| Typed ({| descr.aft := middle |} as ihd) ⇒
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt
(Micheline.Seq Micheline.dummy_location tl) middle in
let judgement_value :=
match judgement_value with
| Failed {| judgement.Failed.descr := descr_value |} ⇒
let descr_value (ret_value : Script_typed_ir.stack_ty) : descr :=
compose_descr loc_value ihd (descr_value ret_value) in
Failed {| judgement.Failed.descr := descr_value; |}
| Typed itl ⇒ Typed (compose_descr loc_value ihd itl)
end in
return? (judgement_value, ctxt)
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_IF
(cons bt (cons bf [])) annot,
(Script_typed_ir.Item_t Script_typed_ir.Bool_t rest) as bef) ⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bt in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bf in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(btr, ctxt) := non_terminal_recursion tc_context_value ctxt bt rest in
let? '(bfr, ctxt) := non_terminal_recursion tc_context_value ctxt bf rest in
let branch (ibt : descr) (ibf : descr) : descr :=
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hloc := Script_typed_ir.kinstr_location k_value in
let branch_if_true : Script_typed_ir.kinstr :=
ibt.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc)
in let branch_if_false : Script_typed_ir.kinstr :=
ibf.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc) in
Script_typed_ir.IIf
{| Script_typed_ir.kinstr.IIf.loc := loc_value;
Script_typed_ir.kinstr.IIf.branch_if_true := branch_if_true;
Script_typed_ir.kinstr.IIf.branch_if_false := branch_if_false;
Script_typed_ir.kinstr.IIf.k := k_value; |}; |} in
{| descr.loc := loc_value; descr.bef := bef; descr.aft := ibt.(descr.aft);
descr.instr := instr; |} in
merge_branches ctxt loc_value btr bfr {| branch.branch := branch; |}
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LOOP (cons body [])
annot, (Script_typed_ir.Item_t Script_typed_ir.Bool_t rest) as stack_value)
⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body rest in
match judgement_value with
| Typed ibody ⇒
let unmatched_branches (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt ibody.(descr.aft) in
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Build_extensible "Unmatched_branches"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Script_tc_errors.unparsed_stack_ty) (loc_value, aft, stack_value) in
Error_monad.record_trace_eval unmatched_branches
(let? '(Eq, ctxt) :=
stack_eq loc_value ctxt 1 ibody.(descr.aft) stack_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let loc_value := Script_typed_ir.kinstr_location k_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt loc_value) in
Script_typed_ir.ILoop loc_value ibody k_value; |} in
typed_no_lwt ctxt loc_value instr rest)
| Failed {| judgement.Failed.descr := descr_value |} ⇒
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let loc_value := Script_typed_ir.kinstr_location k_value in
let ibody := descr_value stack_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt loc_value) in
Script_typed_ir.ILoop loc_value ibody k_value; |} in
typed_no_lwt ctxt loc_value instr rest
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LOOP_LEFT (cons body [])
annot,
(Script_typed_ir.Item_t (Script_typed_ir.Union_t tl tr _ _) rest) as
stack_value) ⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t tl rest) in
match judgement_value with
| Typed ibody ⇒
let unmatched_branches (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt ibody.(descr.aft) in
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Build_extensible "Unmatched_branches"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Script_tc_errors.unparsed_stack_ty) (loc_value, aft, stack_value) in
Error_monad.record_trace_eval unmatched_branches
(let? '(Eq, ctxt) :=
stack_eq loc_value ctxt 1 ibody.(descr.aft) stack_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let loc_value := Script_typed_ir.kinstr_location k_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt loc_value) in
Script_typed_ir.ILoop_left loc_value ibody k_value; |} in
let stack_value := Script_typed_ir.Item_t tr rest in
typed_no_lwt ctxt loc_value instr stack_value)
| Failed {| judgement.Failed.descr := descr_value |} ⇒
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let loc_value := Script_typed_ir.kinstr_location k_value in
let ibody := descr_value stack_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt loc_value) in
Script_typed_ir.ILoop_left loc_value ibody k_value; |} in
let stack_value := Script_typed_ir.Item_t tr rest in
typed_no_lwt ctxt loc_value instr stack_value
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LAMBDA
(cons arg (cons ret_value (cons code []))) annot, stack_value) ⇒
let? '(Script_typed_ir.Ex_ty arg, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy arg in
let? '(Script_typed_ir.Ex_ty ret_value, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy ret_value in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] code in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? '(kdescr, ctxt) :=
parse_kdescr elab_conf (stack_depth +i 1)
(Tc_context.add_lambda tc_context_value) ctxt arg ret_value code in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILambda loc_value (Script_typed_ir.Lam kdescr code)
k_value; |} in
let? ty_value := Script_typed_ir.lambda_t loc_value arg ret_value in
let stack_value := Script_typed_ir.Item_t ty_value stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LAMBDA_REC
(cons arg_ty_expr (cons ret_ty_expr (cons lambda_expr []))) annot,
stack_value) ⇒
let? '(Script_typed_ir.Ex_ty arg, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy arg_ty_expr in
let? '(Script_typed_ir.Ex_ty ret_value, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy ret_ty_expr in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] lambda_expr in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? lambda_rec_ty := Script_typed_ir.lambda_t loc_value arg ret_value in
let? '(code, ctxt) :=
parse_lam_rec elab_conf (stack_depth +i 1)
(Tc_context.add_lambda tc_context_value) ctxt arg ret_value
lambda_rec_ty lambda_expr in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILambda loc_value code k_value; |} in
let stack_value := Script_typed_ir.Item_t lambda_rec_ty stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EXEC [] annot,
Script_typed_ir.Item_t arg
(Script_typed_ir.Item_t (Script_typed_ir.Lambda_t param ret_value _)
rest)) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt arg param loc_value Michelson_v1_primitives.I_EXEC 1 2
in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let stack_value := Script_typed_ir.Item_t ret_value rest in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IExec loc_value (for_logging_only stack_value)
k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_APPLY [] annot,
Script_typed_ir.Item_t capture
(Script_typed_ir.Item_t
(Script_typed_ir.Lambda_t
(Script_typed_ir.Pair_t capture_ty arg_ty _ _) ret_value _) rest))
⇒
let? '_ := check_packable false loc_value capture_ty in
let? '(Eq, ctxt) :=
check_item_ty ctxt capture capture_ty loc_value
Michelson_v1_primitives.I_APPLY 1 2 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IApply loc_value capture_ty k_value; |} in
let? res_ty := Script_typed_ir.lambda_t loc_value arg_ty ret_value in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DIP (cons code []) annot,
Script_typed_ir.Item_t v_value rest) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] code in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt code rest in
match judgement_value with
| Typed descr_value ⇒
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let b_value :=
descr_value.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt descr_value.(descr.loc)) in
Script_typed_ir.IDip loc_value b_value (for_logging_only v_value)
k_value; |} in
let stack_value := Script_typed_ir.Item_t v_value descr_value.(descr.aft)
in
typed ctxt loc_value instr stack_value
| Failed _ ⇒
Error_monad.tzfail
(Build_extensible "Fail_not_in_tail_position"
Alpha_context.Script.location loc_value)
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DIP
(cons n_value (cons code [])) result_annot, stack_value) ⇒
let? n_value := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
let fix make_proof_argument (n_value : int) (stk : Script_typed_ir.stack_ty)
: M? dipn_proof_argument :=
match ((n_value =i 0), stk) with
| (true, rest) ⇒
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt code rest in
match judgement_value with
| Typed descr_value ⇒
return?
(Dipn_proof_argument Script_typed_ir.KRest ctxt descr_value
descr_value.(descr.aft))
| Failed _ ⇒
Error_monad.error_value
(Build_extensible "Fail_not_in_tail_position"
Alpha_context.Script.location loc_value)
end
| (false, Script_typed_ir.Item_t v_value rest) ⇒
let? 'Dipn_proof_argument n' ctxt descr_value aft' :=
make_proof_argument (n_value -i 1) rest in
let w_value := Script_typed_ir.KPrefix loc_value v_value n' in
return?
(Dipn_proof_argument w_value ctxt descr_value
(Script_typed_ir.Item_t v_value aft'))
| (_, _) ⇒
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_DIP, 1, whole_stack))
end in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value result_annot in
let? 'Dipn_proof_argument n' ctxt descr_value aft :=
make_proof_argument n_value stack_value in
let b_value :=
descr_value.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt descr_value.(descr.loc)) in
let res :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDipn loc_value n_value n' b_value k_value; |} in
typed ctxt loc_value res aft
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DIP
(([] | cons _ (cons _ (cons _ _))) as l_value) _, _) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.I_DIP, 2, (List.length l_value)))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_FAILWITH [] annot,
Script_typed_ir.Item_t v_value _rest) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '_ :=
if legacy then
Result.return_unit
else
check_packable false loc_value v_value in
let instr :=
{|
cinstr.apply :=
fun (_k : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IFailwith loc_value v_value; |} in
return?
(let descr_value (aft : Script_typed_ir.stack_ty) : descr :=
{| descr.loc := loc_value; descr.bef := stack_ty; descr.aft := aft;
descr.instr := instr; |} in
let '_ := log_stack loc_value stack_ty Script_typed_ir.Bot_t in
((Failed {| judgement.Failed.descr := descr_value; |}), ctxt))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEVER [] annot,
Script_typed_ir.Item_t Script_typed_ir.Never_t _rest) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (_k : Script_typed_ir.kinstr) ⇒ Script_typed_ir.INever loc_value;
|} in
return?
(let descr_value (aft : Script_typed_ir.stack_ty) : descr :=
{| descr.loc := loc_value; descr.bef := stack_ty; descr.aft := aft;
descr.instr := instr; |} in
let '_ := log_stack loc_value stack_ty Script_typed_ir.Bot_t in
((Failed {| judgement.Failed.descr := descr_value; |}), ctxt))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Timestamp_t
(Script_typed_ir.Item_t Script_typed_ir.Int_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_timestamp_to_seconds loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.Timestamp_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
((Script_typed_ir.Item_t Script_typed_ir.Timestamp_t _) as stack_value))
⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_seconds_to_timestamp loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Timestamp_t
(Script_typed_ir.Item_t Script_typed_ir.Int_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_timestamp_seconds loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Timestamp_t rest
in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Timestamp_t
(Script_typed_ir.Item_t Script_typed_ir.Timestamp_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDiff_timestamps loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CONCAT [] annot,
Script_typed_ir.Item_t Script_typed_ir.String_t
((Script_typed_ir.Item_t Script_typed_ir.String_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IConcat_string_pair loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CONCAT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.List_t Script_typed_ir.String_t _)
rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IConcat_string loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.String_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SLICE [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.String_t rest))) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISlice_string loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_string_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SIZE [] annot,
Script_typed_ir.Item_t Script_typed_ir.String_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IString_size loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CONCAT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t
((Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IConcat_bytes_pair loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CONCAT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.List_t Script_typed_ir.Bytes_t _)
rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IConcat_bytes loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SLICE [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest))) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISlice_bytes loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_bytes_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SIZE [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBytes_size loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Mutez_t
((Script_typed_ir.Item_t Script_typed_ir.Mutez_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_tez loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Mutez_t
((Script_typed_ir.Item_t Script_typed_ir.Mutez_t _) as stack_value)) ⇒
if legacy then
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_tez_legacy loc_value k_value; |} in
typed ctxt loc_value instr stack_value
else
Error_monad.tzfail
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.I_SUB)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB_MUTEZ [] annot,
Script_typed_ir.Item_t Script_typed_ir.Mutez_t
(Script_typed_ir.Item_t Script_typed_ir.Mutez_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_tez loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_mutez_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Mutez_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_teznat loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Mutez_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Mutez_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_nattez loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_OR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bool_t
((Script_typed_ir.Item_t Script_typed_ir.Bool_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IOr loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_AND [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bool_t
((Script_typed_ir.Item_t Script_typed_ir.Bool_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAnd loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_XOR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bool_t
((Script_typed_ir.Item_t Script_typed_ir.Bool_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IXor loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NOT [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bool_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INot loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ABS [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAbs_int loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ISNAT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IIs_nat loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.option_nat_t rest
in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_INT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IInt_nat loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEG [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INeg loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEG [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INeg loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
((Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_int loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_int loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_int loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
((Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_int loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_int loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_int loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_int loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
((Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_int loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_int loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EDIV [] annot,
Script_typed_ir.Item_t Script_typed_ir.Mutez_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEdiv_teznat loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_pair_mutez_mutez_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EDIV [] annot,
Script_typed_ir.Item_t Script_typed_ir.Mutez_t
(Script_typed_ir.Item_t Script_typed_ir.Mutez_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEdiv_tez loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_pair_nat_mutez_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EDIV [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
(Script_typed_ir.Item_t Script_typed_ir.Int_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEdiv_int loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_pair_int_nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EDIV [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEdiv_int loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_pair_int_nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EDIV [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.Int_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEdiv_nat loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_pair_int_nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EDIV [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEdiv_nat loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_pair_nat_nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LSL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILsl_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LSL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILsl_bytes loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LSR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILsr_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LSR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILsr_bytes loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_OR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IOr_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_OR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t
((Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IOr_bytes loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_AND [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAnd_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_AND [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAnd_int_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_AND [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t
((Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAnd_bytes loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_XOR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IXor_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_XOR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t
((Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IXor_bytes loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NOT [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INot_int loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NOT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INot_int loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NOT [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INot_bytes loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_COMPARE [] annot,
Script_typed_ir.Item_t t1 (Script_typed_ir.Item_t t2 rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? '(Eq, ctxt) :=
check_item_ty ctxt t1 t2 loc_value Michelson_v1_primitives.I_COMPARE 1 2
in
let? 'Eq := check_comparable loc_value t1 in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICompare loc_value t1 k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EQ [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEq loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEQ [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INeq loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILt loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IGt loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LE [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILe loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GE [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IGe loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CAST (cons cast_t [])
annot, (Script_typed_ir.Item_t t_value _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? '(Script_typed_ir.Ex_ty cast_t, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy cast_t in
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(ty_eq (Script_tc_errors.Informative loc_value) cast_t t_value) in
let? 'Eq := eq_value in
let instr :=
{| cinstr.apply := fun (k_value : Script_typed_ir.kinstr) ⇒ k_value; |}
in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_RENAME [] annot,
(Script_typed_ir.Item_t _ _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{| cinstr.apply := fun (k_value : Script_typed_ir.kinstr) ⇒ k_value; |}
in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_PACK [] annot,
Script_typed_ir.Item_t t_value rest) ⇒
let? '_ := check_packable true loc_value t_value in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IPack loc_value t_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bytes_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UNPACK
(cons ty_value []) annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest) ⇒
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_packable_ty_aux ctxt (stack_depth +i 1) legacy ty_value in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let? res_ty := Script_typed_ir.option_t loc_value t_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IUnpack loc_value t_value k_value; |} in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADDRESS [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Contract_t _ _) rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAddress loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.address_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CONTRACT
(cons ty_value []) annot,
Script_typed_ir.Item_t Script_typed_ir.Address_t rest) ⇒
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_passable_ty_aux ctxt (stack_depth +i 1) legacy ty_value in
let? contract_ty := Script_typed_ir.contract_t loc_value t_value in
let? res_ty := Script_typed_ir.option_t loc_value contract_ty in
let? entrypoint :=
Script_ir_annot.parse_entrypoint_annot_strict loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IContract loc_value t_value entrypoint k_value; |}
in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_VIEW
(cons name (cons output_ty [])) annot,
Script_typed_ir.Item_t input_ty
(Script_typed_ir.Item_t Script_typed_ir.Address_t rest)) ⇒
let output_ty_loc := location output_ty in
let? '(name, ctxt) := parse_view_name ctxt name in
let? '(Script_typed_ir.Ex_ty output_ty, ctxt) :=
parse_view_output_ty ctxt 0 legacy output_ty in
let? res_ty := Script_typed_ir.option_t output_ty_loc output_ty in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IView loc_value
(Script_typed_ir.View_signature
{| Script_typed_ir.view_signature.View_signature.name := name;
Script_typed_ir.view_signature.View_signature.input_ty :=
input_ty;
Script_typed_ir.view_signature.View_signature.output_ty :=
output_ty; |}) (for_logging_only rest) k_value; |} in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value
(Michelson_v1_primitives.I_TRANSFER_TOKENS as prim) [] annot,
Script_typed_ir.Item_t p_value
(Script_typed_ir.Item_t Script_typed_ir.Mutez_t
(Script_typed_ir.Item_t (Script_typed_ir.Contract_t cp _) rest))) ⇒
let? '_ :=
Tc_context.check_not_in_view loc_value legacy tc_context_value prim in
let? '(Eq, ctxt) := check_item_ty ctxt p_value cp loc_value prim 1 4 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ITransfer_tokens loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.operation_t rest
in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value (Michelson_v1_primitives.I_SET_DELEGATE as prim)
[] annot,
Script_typed_ir.Item_t
(Script_typed_ir.Option_t Script_typed_ir.Key_hash_t _ _) rest) ⇒
let? '_ :=
Tc_context.check_not_in_view loc_value legacy tc_context_value prim in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISet_delegate loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.operation_t rest
in
typed ctxt loc_value instr stack_value
| (Micheline.Prim _ Michelson_v1_primitives.I_CREATE_ACCOUNT _ _, _) ⇒
Error_monad.tzfail
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.I_CREATE_ACCOUNT)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_IMPLICIT_ACCOUNT []
annot, Script_typed_ir.Item_t Script_typed_ir.Key_hash_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IImplicit_account loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.contract_unit_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value
(Michelson_v1_primitives.I_CREATE_CONTRACT as prim)
(cons ((Micheline.Seq _ _) as code) []) annot,
Script_typed_ir.Item_t
(Script_typed_ir.Option_t Script_typed_ir.Key_hash_t _ _)
(Script_typed_ir.Item_t Script_typed_ir.Mutez_t
(Script_typed_ir.Item_t ginit rest))) ⇒
let? '_ :=
Tc_context.check_not_in_view loc_value legacy tc_context_value prim in
let? '_ := Script_ir_annot.check_two_var_annot loc_value annot in
let canonical_code := Micheline.strip_locations code in
let?
'({|
toplevel.code_field := code_field;
toplevel.arg_type := arg_type;
toplevel.storage_type := storage_type;
toplevel.views := views
|}, ctxt) := parse_toplevel_aux ctxt legacy canonical_code in
let?
'(Ex_parameter_ty_and_entrypoints {|
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.arg_type :=
arg_type;
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.entrypoints
:= entrypoints
|}, ctxt) :=
Error_monad.record_trace
(Build_extensible "Ill_formed_type"
(option string × Micheline.canonical Alpha_context.Script.prim ×
Alpha_context.Script.location)
((Some "parameter"), canonical_code, (location arg_type)))
(parse_parameter_ty_and_entrypoints_aux ctxt (stack_depth +i 1) legacy
arg_type) in
let? '(Script_typed_ir.Ex_ty storage_type, ctxt) :=
Error_monad.record_trace
(Build_extensible "Ill_formed_type"
(option string × Micheline.canonical Alpha_context.Script.prim ×
Alpha_context.Script.location)
((Some "storage"), canonical_code, (location storage_type)))
(parse_storage_ty ctxt (stack_depth +i 1) legacy storage_type) in
let? 'Script_typed_ir.Ty_ex_c arg_type_full :=
Script_typed_ir.pair_t loc_value arg_type storage_type in
let? 'Script_typed_ir.Ty_ex_c ret_type_full :=
Script_typed_ir.pair_t loc_value Script_typed_ir.list_operation_t
storage_type in
let? function_parameter :=
Error_monad.trace_value
(Build_extensible "Ill_typed_contract"
(Micheline.canonical Alpha_context.Script.prim ×
Script_tc_errors.type_map) (canonical_code, nil))
(parse_kdescr elab_conf (stack_depth +i 1)
(Tc_context.toplevel_value storage_type arg_type entrypoints) ctxt
arg_type_full ret_type_full code_field) in
match function_parameter with
|
({|
Script_typed_ir.kdescr.kbef :=
Script_typed_ir.Item_t arg Script_typed_ir.Bot_t;
Script_typed_ir.kdescr.kaft :=
Script_typed_ir.Item_t ret_value Script_typed_ir.Bot_t
|}, ctxt) ⇒
let views_result := parse_views elab_conf ctxt storage_type views in
let? '(_typed_views, ctxt) :=
Error_monad.trace_value
(Build_extensible "Ill_typed_contract"
(Micheline.canonical Alpha_context.Script.prim ×
Script_tc_errors.type_map) (canonical_code, nil)) views_result in
let? '(storage_eq, ctxt) :=
let error_details := Script_tc_errors.Informative loc_value in
Gas_monad.run ctxt
(Gas_monad.Syntax.op_letstar (ty_eq error_details arg arg_type_full)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Gas_monad.Syntax.op_letstar
(ty_eq error_details ret_value ret_type_full)
(fun function_parameter ⇒
let 'Eq := function_parameter in
ty_eq error_details storage_type ginit))) in
let? 'Eq := storage_eq in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICreate_contract
{| Script_typed_ir.kinstr.ICreate_contract.loc := loc_value;
Script_typed_ir.kinstr.ICreate_contract.storage_type :=
storage_type;
Script_typed_ir.kinstr.ICreate_contract.code :=
canonical_code;
Script_typed_ir.kinstr.ICreate_contract.k := k_value; |}; |}
in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.operation_t
(Script_typed_ir.Item_t Script_typed_ir.address_t rest) in
typed ctxt loc_value instr stack_value
| _ ⇒ unreachable_gadt_branch
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NOW [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INow loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.timestamp_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MIN_BLOCK_TIME [] _,
stack_value) ⇒
typed ctxt loc_value
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMin_block_time loc_value k_value; |}
(Script_typed_ir.Item_t Script_typed_ir.nat_t stack_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_AMOUNT [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAmount loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.mutez_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CHAIN_ID [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IChainId loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.chain_id_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_BALANCE [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBalance loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.mutez_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LEVEL [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILevel loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.nat_t stack_value
in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_VOTING_POWER [] annot,
Script_typed_ir.Item_t Script_typed_ir.Key_hash_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IVoting_power loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_TOTAL_VOTING_POWER []
annot, stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ITotal_voting_power loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.nat_t stack_value
in
typed ctxt loc_value instr stack_value
| (Micheline.Prim _ Michelson_v1_primitives.I_STEPS_TO_QUOTA _ _, _) ⇒
Error_monad.tzfail
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.I_STEPS_TO_QUOTA)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SOURCE [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISource loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.address_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SENDER [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISender loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.address_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value (Michelson_v1_primitives.I_SELF as prim) [] annot,
stack_value) ⇒
let? entrypoint :=
Script_ir_annot.parse_entrypoint_annot_lax loc_value annot in
match
(tc_context_value.(Script_tc_context.t.callsite),
(let '_ := tc_context_value.(Script_tc_context.t.callsite) in
Tc_context.is_in_lambda tc_context_value)) with
| (_, true) ⇒
Error_monad.error_value
(Build_extensible "Forbidden_instr_in_context"
(Alpha_context.Script.location × Script_tc_errors.context_desc ×
Alpha_context.Script.prim)
(loc_value, Script_tc_errors.Lambda, prim))
| (Script_tc_context.Data, _) ⇒
Error_monad.error_value
(Build_extensible "Forbidden_instr_in_context"
(Alpha_context.Script.location × Script_tc_errors.context_desc ×
Alpha_context.Script.prim)
(loc_value, Script_tc_errors.Lambda, prim))
| (Script_tc_context.View, _) ⇒
Error_monad.error_value
(Build_extensible "Forbidden_instr_in_context"
(Alpha_context.Script.location × Script_tc_errors.context_desc ×
Alpha_context.Script.prim) (loc_value, Script_tc_errors.View, prim))
|
(Script_tc_context.Toplevel {|
Tc_context.callsite.Toplevel.storage_type := _;
Tc_context.callsite.Toplevel.param_type := param_type;
Tc_context.callsite.Toplevel.entrypoints := entrypoints
|}, _) ⇒
let 'existT _ __Toplevel_'param [entrypoints, param_type] :=
cast_exists (Es := Set)
(fun __Toplevel_'param ⇒
[Script_typed_ir.entrypoints ** Script_typed_ir.ty])
[entrypoints, param_type] in
let? '(r_value, ctxt) :=
Gas_monad.run ctxt
((find_entrypoint (Script_tc_errors.Informative tt) param_type
entrypoints entrypoint) :
Gas_monad.t (ex_ty_cstr __Toplevel_'param)
(Error_monad.trace Error_monad._error)) in
let? 'Ex_ty_cstr {| ex_ty_cstr.Ex_ty_cstr.ty := param_type |} := r_value
in
let? res_ty := Script_typed_ir.contract_t loc_value param_type in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISelf loc_value param_type entrypoint k_value; |}
in
let stack_value := Script_typed_ir.Item_t res_ty stack_value in
typed_no_lwt ctxt loc_value instr stack_value
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SELF_ADDRESS [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISelf_address loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.address_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_HASH_KEY [] annot,
Script_typed_ir.Item_t Script_typed_ir.Key_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IHash_key loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.key_hash_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CHECK_SIGNATURE [] annot,
Script_typed_ir.Item_t Script_typed_ir.Key_t
(Script_typed_ir.Item_t Script_typed_ir.Signature_t
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest))) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICheck_signature loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_BLAKE2B [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBlake2b loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SHA256 [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISha256 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SHA512 [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISha512 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_KECCAK [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IKeccak loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SHA3 [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISha3 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g1_t
((Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g1_t _) as
stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_bls12_381_g1 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g2_t
((Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g2_t _) as
stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_bls12_381_g2 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t
((Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t _) as
stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_bls12_381_fr loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g1_t
(Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_g1 loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g1_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g2_t
(Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_g2 loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g2_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t
((Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t _) as
stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_fr loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t _) as
stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_fr_z loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
((Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t _) as
stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_fr_z loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t
(Script_typed_ir.Item_t Script_typed_ir.Int_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_z_fr loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_z_fr loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_INT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IInt_bls12_381_fr loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEG [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g1_t _) as stack_value)
⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INeg_bls12_381_g1 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEG [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g2_t _) as stack_value)
⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INeg_bls12_381_g2 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEG [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t _) as stack_value)
⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INeg_bls12_381_fr loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_PAIRING_CHECK [] annot,
Script_typed_ir.Item_t
(Script_typed_ir.List_t
(Script_typed_ir.Pair_t Script_typed_ir.Bls12_381_g1_t
Script_typed_ir.Bls12_381_g2_t _ _) _) rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IPairing_check_bls12_381 loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_TICKET [] annot,
Script_typed_ir.Item_t t_value
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? 'Eq := check_comparable loc_value t_value in
let? res_ty := Script_typed_ir.ticket_t loc_value t_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ITicket loc_value (for_logging_only t_value) k_value;
|} in
let? res_ty := Script_typed_ir.option_t loc_value res_ty in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_TICKET_DEPRECATED []
annot,
Script_typed_ir.Item_t t_value
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
if legacy then
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? 'Eq := check_comparable loc_value t_value in
let? res_ty := Script_typed_ir.ticket_t loc_value t_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ITicket_deprecated loc_value
(for_logging_only t_value) k_value; |} in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
else
Error_monad.tzfail
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.I_TICKET_DEPRECATED)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_READ_TICKET [] annot,
(Script_typed_ir.Item_t (Script_typed_ir.Ticket_t t_value _) _) as
full_stack) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let '_ := check_dupable_comparable_ty t_value in
let? result_value := opened_ticket_type loc_value t_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IRead_ticket loc_value (for_logging_only t_value)
k_value; |} in
let stack_value := Script_typed_ir.Item_t result_value full_stack in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SPLIT_TICKET [] annot,
Script_typed_ir.Item_t ((Script_typed_ir.Ticket_t t_value _) as ticket_t)
(Script_typed_ir.Item_t
(Script_typed_ir.Pair_t Script_typed_ir.Nat_t Script_typed_ir.Nat_t _
_) rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let '_ := check_dupable_comparable_ty t_value in
let? 'Script_typed_ir.Ty_ex_c pair_tickets_ty :=
Script_typed_ir.pair_t loc_value ticket_t ticket_t in
let? res_ty := Script_typed_ir.option_t loc_value pair_tickets_ty in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISplit_ticket loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_JOIN_TICKETS [] annot,
Script_typed_ir.Item_t
(Script_typed_ir.Pair_t
((Script_typed_ir.Ticket_t contents_ty_a _) as ty_a)
(Script_typed_ir.Ticket_t contents_ty_b _) _ _) rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(ty_eq (Script_tc_errors.Informative loc_value) contents_ty_a
contents_ty_b) in
let? 'Eq := eq_value in
let? res_ty := Script_typed_ir.option_t loc_value ty_a in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IJoin_tickets loc_value contents_ty_a k_value; |} in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_OPEN_CHEST [] _,
Script_typed_ir.Item_t Script_typed_ir.Chest_key_t
(Script_typed_ir.Item_t Script_typed_ir.Chest_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest))) ⇒
if legacy then
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IOpen_chest loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.union_bytes_bool_t rest)
else
Error_monad.tzfail
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.I_OPEN_CHEST)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EMIT [] annot,
Script_typed_ir.Item_t data rest) ⇒
let? '_ := check_packable legacy loc_value data in
let? tag := Script_ir_annot.parse_entrypoint_annot_strict loc_value annot in
let? '(unparsed_ty, ctxt) := Script_ir_unparser.unparse_ty tt ctxt data in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Alpha_context.Script.strip_locations_cost unparsed_ty) in
let unparsed_ty := Micheline.strip_locations unparsed_ty in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEmit
{| Script_typed_ir.kinstr.IEmit.loc := loc_value;
Script_typed_ir.kinstr.IEmit.tag := tag;
Script_typed_ir.kinstr.IEmit.ty := data;
Script_typed_ir.kinstr.IEmit.unparsed_ty := unparsed_ty;
Script_typed_ir.kinstr.IEmit.k := k_value; |}; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.Operation_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EMIT (cons ty_node [])
annot, Script_typed_ir.Item_t data rest) ⇒
let? '(Script_typed_ir.Ex_ty ty_value, ctxt) :=
parse_packable_ty_aux ctxt (stack_depth +i 1) legacy ty_node in
let? '(Eq, ctxt) :=
check_item_ty ctxt ty_value data loc_value Michelson_v1_primitives.I_EMIT
1 2 in
let? tag := Script_ir_annot.parse_entrypoint_annot_strict loc_value annot in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Alpha_context.Script.strip_locations_cost ty_node) in
let unparsed_ty := Micheline.strip_locations ty_node in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEmit
{| Script_typed_ir.kinstr.IEmit.loc := loc_value;
Script_typed_ir.kinstr.IEmit.tag := tag;
Script_typed_ir.kinstr.IEmit.ty := data;
Script_typed_ir.kinstr.IEmit.unparsed_ty := unparsed_ty;
Script_typed_ir.kinstr.IEmit.k := k_value; |}; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.Operation_t rest)
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_DUP | Michelson_v1_primitives.I_SWAP |
Michelson_v1_primitives.I_SOME | Michelson_v1_primitives.I_UNIT |
Michelson_v1_primitives.I_PAIR | Michelson_v1_primitives.I_UNPAIR |
Michelson_v1_primitives.I_CAR | Michelson_v1_primitives.I_CDR |
Michelson_v1_primitives.I_CONS | Michelson_v1_primitives.I_CONCAT |
Michelson_v1_primitives.I_SLICE | Michelson_v1_primitives.I_MEM |
Michelson_v1_primitives.I_UPDATE | Michelson_v1_primitives.I_GET |
Michelson_v1_primitives.I_EXEC | Michelson_v1_primitives.I_FAILWITH |
Michelson_v1_primitives.I_SIZE | Michelson_v1_primitives.I_ADD |
Michelson_v1_primitives.I_SUB | Michelson_v1_primitives.I_SUB_MUTEZ |
Michelson_v1_primitives.I_MUL | Michelson_v1_primitives.I_EDIV |
Michelson_v1_primitives.I_OR | Michelson_v1_primitives.I_AND |
Michelson_v1_primitives.I_XOR | Michelson_v1_primitives.I_NOT |
Michelson_v1_primitives.I_ABS | Michelson_v1_primitives.I_NEG |
Michelson_v1_primitives.I_LSL | Michelson_v1_primitives.I_LSR |
Michelson_v1_primitives.I_COMPARE | Michelson_v1_primitives.I_EQ |
Michelson_v1_primitives.I_NEQ | Michelson_v1_primitives.I_LT |
Michelson_v1_primitives.I_GT | Michelson_v1_primitives.I_LE |
Michelson_v1_primitives.I_GE | Michelson_v1_primitives.I_TRANSFER_TOKENS |
Michelson_v1_primitives.I_SET_DELEGATE | Michelson_v1_primitives.I_NOW |
Michelson_v1_primitives.I_MIN_BLOCK_TIME |
Michelson_v1_primitives.I_IMPLICIT_ACCOUNT |
Michelson_v1_primitives.I_AMOUNT | Michelson_v1_primitives.I_BALANCE |
Michelson_v1_primitives.I_LEVEL |
Michelson_v1_primitives.I_CHECK_SIGNATURE |
Michelson_v1_primitives.I_HASH_KEY | Michelson_v1_primitives.I_SOURCE |
Michelson_v1_primitives.I_SENDER | Michelson_v1_primitives.I_BLAKE2B |
Michelson_v1_primitives.I_SHA256 | Michelson_v1_primitives.I_SHA512 |
Michelson_v1_primitives.I_ADDRESS | Michelson_v1_primitives.I_RENAME |
Michelson_v1_primitives.I_PACK | Michelson_v1_primitives.I_ISNAT |
Michelson_v1_primitives.I_INT | Michelson_v1_primitives.I_SELF |
Michelson_v1_primitives.I_CHAIN_ID | Michelson_v1_primitives.I_NEVER |
Michelson_v1_primitives.I_VOTING_POWER |
Michelson_v1_primitives.I_TOTAL_VOTING_POWER |
Michelson_v1_primitives.I_KECCAK | Michelson_v1_primitives.I_SHA3 |
Michelson_v1_primitives.I_PAIRING_CHECK | Michelson_v1_primitives.I_TICKET
| Michelson_v1_primitives.I_READ_TICKET |
Michelson_v1_primitives.I_SPLIT_TICKET |
Michelson_v1_primitives.I_JOIN_TICKETS |
Michelson_v1_primitives.I_OPEN_CHEST) as name) ((cons _ _) as l_value) _,
_) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, name, 0, (List.length l_value)))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_NONE | Michelson_v1_primitives.I_LEFT |
Michelson_v1_primitives.I_RIGHT | Michelson_v1_primitives.I_NIL |
Michelson_v1_primitives.I_MAP | Michelson_v1_primitives.I_ITER |
Michelson_v1_primitives.I_EMPTY_SET | Michelson_v1_primitives.I_LOOP |
Michelson_v1_primitives.I_LOOP_LEFT | Michelson_v1_primitives.I_CONTRACT |
Michelson_v1_primitives.I_CAST | Michelson_v1_primitives.I_UNPACK |
Michelson_v1_primitives.I_CREATE_CONTRACT | Michelson_v1_primitives.I_EMIT)
as name) (([] | cons _ (cons _ _)) as l_value) _, _) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, name, 1, (List.length l_value)))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_PUSH | Michelson_v1_primitives.I_VIEW |
Michelson_v1_primitives.I_IF_NONE | Michelson_v1_primitives.I_IF_LEFT |
Michelson_v1_primitives.I_IF_CONS | Michelson_v1_primitives.I_EMPTY_MAP |
Michelson_v1_primitives.I_EMPTY_BIG_MAP | Michelson_v1_primitives.I_IF) as
name) (([] | cons _ [] | cons _ (cons _ (cons _ _))) as l_value) _, _)
⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, name, 2, (List.length l_value)))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LAMBDA
(([] | cons _ [] | cons _ (cons _ []) |
cons _ (cons _ (cons _ (cons _ _)))) as l_value) _, _) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.I_LAMBDA, 3, (List.length l_value)))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_ADD | Michelson_v1_primitives.I_SUB |
Michelson_v1_primitives.I_SUB_MUTEZ | Michelson_v1_primitives.I_MUL |
Michelson_v1_primitives.I_EDIV | Michelson_v1_primitives.I_AND |
Michelson_v1_primitives.I_OR | Michelson_v1_primitives.I_XOR |
Michelson_v1_primitives.I_LSL | Michelson_v1_primitives.I_LSR |
Michelson_v1_primitives.I_CONCAT | Michelson_v1_primitives.I_PAIRING_CHECK)
as name) [] _, Script_typed_ir.Item_t ta (Script_typed_ir.Item_t tb _))
⇒
let ta := Script_ir_unparser.serialize_ty_for_error ta in
let tb := Script_ir_unparser.serialize_ty_for_error tb in
Error_monad.tzfail
(Build_extensible "Undefined_binop"
(Alpha_context.Script.location × Alpha_context.Script.prim ×
Alpha_context.Script.expr × Alpha_context.Script.expr)
(loc_value, name, ta, tb))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_NEG | Michelson_v1_primitives.I_ABS |
Michelson_v1_primitives.I_NOT | Michelson_v1_primitives.I_SIZE |
Michelson_v1_primitives.I_EQ | Michelson_v1_primitives.I_NEQ |
Michelson_v1_primitives.I_LT | Michelson_v1_primitives.I_GT |
Michelson_v1_primitives.I_LE | Michelson_v1_primitives.I_GE |
Michelson_v1_primitives.I_CONCAT) as name) [] _,
Script_typed_ir.Item_t t_value _) ⇒
let t_value := Script_ir_unparser.serialize_ty_for_error t_value in
Error_monad.tzfail
(Build_extensible "Undefined_unop"
(Alpha_context.Script.location × Alpha_context.Script.prim ×
Alpha_context.Script.expr) (loc_value, name, t_value))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_UPDATE | Michelson_v1_primitives.I_SLICE |
Michelson_v1_primitives.I_OPEN_CHEST) as name) [] _, stack_value) ⇒
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty) (loc_value, name, 3, stack_value))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CREATE_CONTRACT _ _,
stack_value) ⇒
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.tzfail
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_CREATE_CONTRACT, 7, stack_value))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_TRANSFER_TOKENS [] _,
stack_value) ⇒
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_TRANSFER_TOKENS, 4, stack_value))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_DROP | Michelson_v1_primitives.I_DUP |
Michelson_v1_primitives.I_CAR | Michelson_v1_primitives.I_CDR |
Michelson_v1_primitives.I_UNPAIR | Michelson_v1_primitives.I_SOME |
Michelson_v1_primitives.I_BLAKE2B | Michelson_v1_primitives.I_SHA256 |
Michelson_v1_primitives.I_SHA512 | Michelson_v1_primitives.I_DIP |
Michelson_v1_primitives.I_IF_NONE | Michelson_v1_primitives.I_LEFT |
Michelson_v1_primitives.I_RIGHT | Michelson_v1_primitives.I_IF_LEFT |
Michelson_v1_primitives.I_IF | Michelson_v1_primitives.I_LOOP |
Michelson_v1_primitives.I_IF_CONS |
Michelson_v1_primitives.I_IMPLICIT_ACCOUNT | Michelson_v1_primitives.I_NEG
| Michelson_v1_primitives.I_ABS | Michelson_v1_primitives.I_INT |
Michelson_v1_primitives.I_NOT | Michelson_v1_primitives.I_HASH_KEY |
Michelson_v1_primitives.I_EQ | Michelson_v1_primitives.I_NEQ |
Michelson_v1_primitives.I_LT | Michelson_v1_primitives.I_GT |
Michelson_v1_primitives.I_LE | Michelson_v1_primitives.I_GE |
Michelson_v1_primitives.I_SIZE | Michelson_v1_primitives.I_FAILWITH |
Michelson_v1_primitives.I_RENAME | Michelson_v1_primitives.I_PACK |
Michelson_v1_primitives.I_ISNAT | Michelson_v1_primitives.I_ADDRESS |
Michelson_v1_primitives.I_SET_DELEGATE | Michelson_v1_primitives.I_CAST |
Michelson_v1_primitives.I_MAP | Michelson_v1_primitives.I_ITER |
Michelson_v1_primitives.I_LOOP_LEFT | Michelson_v1_primitives.I_UNPACK |
Michelson_v1_primitives.I_CONTRACT | Michelson_v1_primitives.I_NEVER |
Michelson_v1_primitives.I_KECCAK | Michelson_v1_primitives.I_SHA3 |
Michelson_v1_primitives.I_READ_TICKET |
Michelson_v1_primitives.I_JOIN_TICKETS) as name) _ _, stack_value) ⇒
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty) (loc_value, name, 1, stack_value))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_SWAP | Michelson_v1_primitives.I_PAIR |
Michelson_v1_primitives.I_CONS | Michelson_v1_primitives.I_GET |
Michelson_v1_primitives.I_MEM | Michelson_v1_primitives.I_EXEC |
Michelson_v1_primitives.I_CHECK_SIGNATURE | Michelson_v1_primitives.I_ADD
| Michelson_v1_primitives.I_SUB | Michelson_v1_primitives.I_SUB_MUTEZ |
Michelson_v1_primitives.I_MUL | Michelson_v1_primitives.I_EDIV |
Michelson_v1_primitives.I_AND | Michelson_v1_primitives.I_OR |
Michelson_v1_primitives.I_XOR | Michelson_v1_primitives.I_LSL |
Michelson_v1_primitives.I_LSR | Michelson_v1_primitives.I_COMPARE |
Michelson_v1_primitives.I_PAIRING_CHECK | Michelson_v1_primitives.I_TICKET
| Michelson_v1_primitives.I_SPLIT_TICKET) as name) _ _, stack_value) ⇒
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty) (loc_value, name, 2, stack_value))
| (expr, _) ⇒
Error_monad.tzfail
(unexpected expr [ Script_tc_errors.Seq_kind ]
Michelson_v1_primitives.Instr_namespace
[
Michelson_v1_primitives.I_ABS;
Michelson_v1_primitives.I_ADD;
Michelson_v1_primitives.I_AMOUNT;
Michelson_v1_primitives.I_AND;
Michelson_v1_primitives.I_BALANCE;
Michelson_v1_primitives.I_BLAKE2B;
Michelson_v1_primitives.I_CAR;
Michelson_v1_primitives.I_CDR;
Michelson_v1_primitives.I_CHECK_SIGNATURE;
Michelson_v1_primitives.I_COMPARE;
Michelson_v1_primitives.I_CONCAT;
Michelson_v1_primitives.I_CONS;
Michelson_v1_primitives.I_CREATE_CONTRACT;
Michelson_v1_primitives.I_DIG;
Michelson_v1_primitives.I_DIP;
Michelson_v1_primitives.I_DROP;
Michelson_v1_primitives.I_DUG;
Michelson_v1_primitives.I_DUP;
Michelson_v1_primitives.I_EDIV;
Michelson_v1_primitives.I_EMPTY_BIG_MAP;
Michelson_v1_primitives.I_EMPTY_MAP;
Michelson_v1_primitives.I_EMPTY_SET;
Michelson_v1_primitives.I_EQ;
Michelson_v1_primitives.I_EXEC;
Michelson_v1_primitives.I_FAILWITH;
Michelson_v1_primitives.I_GE;
Michelson_v1_primitives.I_GET;
Michelson_v1_primitives.I_GET_AND_UPDATE;
Michelson_v1_primitives.I_GT;
Michelson_v1_primitives.I_HASH_KEY;
Michelson_v1_primitives.I_IF;
Michelson_v1_primitives.I_IF_CONS;
Michelson_v1_primitives.I_IF_LEFT;
Michelson_v1_primitives.I_IF_NONE;
Michelson_v1_primitives.I_IMPLICIT_ACCOUNT;
Michelson_v1_primitives.I_INT;
Michelson_v1_primitives.I_ITER;
Michelson_v1_primitives.I_JOIN_TICKETS;
Michelson_v1_primitives.I_KECCAK;
Michelson_v1_primitives.I_LAMBDA;
Michelson_v1_primitives.I_LE;
Michelson_v1_primitives.I_LEFT;
Michelson_v1_primitives.I_LEVEL;
Michelson_v1_primitives.I_LOOP;
Michelson_v1_primitives.I_LSL;
Michelson_v1_primitives.I_LSR;
Michelson_v1_primitives.I_LT;
Michelson_v1_primitives.I_MAP;
Michelson_v1_primitives.I_MEM;
Michelson_v1_primitives.I_MIN_BLOCK_TIME;
Michelson_v1_primitives.I_MUL;
Michelson_v1_primitives.I_NEG;
Michelson_v1_primitives.I_NEQ;
Michelson_v1_primitives.I_NEVER;
Michelson_v1_primitives.I_NIL;
Michelson_v1_primitives.I_NONE;
Michelson_v1_primitives.I_NOT;
Michelson_v1_primitives.I_NOW;
Michelson_v1_primitives.I_OPEN_CHEST;
Michelson_v1_primitives.I_OR;
Michelson_v1_primitives.I_PAIR;
Michelson_v1_primitives.I_PAIRING_CHECK;
Michelson_v1_primitives.I_PUSH;
Michelson_v1_primitives.I_READ_TICKET;
Michelson_v1_primitives.I_RIGHT;
Michelson_v1_primitives.I_SAPLING_EMPTY_STATE;
Michelson_v1_primitives.I_SAPLING_VERIFY_UPDATE;
Michelson_v1_primitives.I_SELF;
Michelson_v1_primitives.I_SELF_ADDRESS;
Michelson_v1_primitives.I_SENDER;
Michelson_v1_primitives.I_SHA256;
Michelson_v1_primitives.I_SHA3;
Michelson_v1_primitives.I_SHA512;
Michelson_v1_primitives.I_SIZE;
Michelson_v1_primitives.I_SOME;
Michelson_v1_primitives.I_SOURCE;
Michelson_v1_primitives.I_SPLIT_TICKET;
Michelson_v1_primitives.I_SUB;
Michelson_v1_primitives.I_SUB_MUTEZ;
Michelson_v1_primitives.I_SWAP;
Michelson_v1_primitives.I_TICKET;
Michelson_v1_primitives.I_TOTAL_VOTING_POWER;
Michelson_v1_primitives.I_TRANSFER_TOKENS;
Michelson_v1_primitives.I_UNIT;
Michelson_v1_primitives.I_UNPAIR;
Michelson_v1_primitives.I_UPDATE;
Michelson_v1_primitives.I_VIEW;
Michelson_v1_primitives.I_VOTING_POWER;
Michelson_v1_primitives.I_XOR
])
end
where "'parse_views" :=
(fun
(elab_conf : elab_conf) (ctxt : Alpha_context.context)
(storage_type : Script_typed_ir.ty) (views : Script_typed_ir.view_map) ⇒
let aux
(ctxt : Alpha_context.context) (name : Script_string.t)
(cur_view : Script_typed_ir.view)
: M? (typed_view × Alpha_context.context) :=
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.view_update name views) in
parse_view elab_conf ctxt storage_type cur_view in
Script_map.map_es_in_context aux ctxt views)
and "'parse_kdescr" :=
(fun
(elab_conf : elab_conf) (stack_depth : int) (tc_context_value : tc_context)
(ctxt : Alpha_context.context) (arg : Script_typed_ir.ty)
(ret_value : Script_typed_ir.ty) (script_instr : Alpha_context.Script.node)
⇒
let? function_parameter :=
parse_instr_aux elab_conf (stack_depth +i 1) tc_context_value ctxt
script_instr (Script_typed_ir.Item_t arg Script_typed_ir.Bot_t) in
match function_parameter with
|
(Typed
({|
descr.loc := loc_value;
descr.aft :=
(Script_typed_ir.Item_t ty_value Script_typed_ir.Bot_t) as
stack_ty
|} as descr_value), ctxt) ⇒
let error_details := Script_tc_errors.Informative loc_value in
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(Gas_monad.record_trace_eval error_details
(fun (loc_value : Alpha_context.Script.location) ⇒
let ret_value :=
Script_ir_unparser.serialize_ty_for_error ret_value in
let stack_ty :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_ty in
Build_extensible "Bad_return"
(Alpha_context.Script.location ×
Script_tc_errors.unparsed_stack_ty × Alpha_context.Script.expr)
(loc_value, stack_ty, ret_value))
(ty_eq error_details ty_value ret_value)) in
let? 'Eq := eq_value in
return? ((close_descr descr_value), ctxt)
| (Typed {| descr.loc := loc_value; descr.aft := stack_ty |}, ctxt) ⇒
let ret_value := Script_ir_unparser.serialize_ty_for_error ret_value in
let stack_ty := Script_ir_unparser.serialize_stack_for_error ctxt stack_ty
in
Error_monad.tzfail
(Build_extensible "Bad_return"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Alpha_context.Script.expr) (loc_value, stack_ty, ret_value))
| (Failed {| judgement.Failed.descr := descr_value |}, ctxt) ⇒
return?
((close_descr
(descr_value (Script_typed_ir.Item_t ret_value Script_typed_ir.Bot_t))),
ctxt)
end)
and "'parse_lam_rec" :=
(fun
(elab_conf : elab_conf) (stack_depth : int) (tc_context_value : tc_context)
(ctxt : Alpha_context.context) (arg : Script_typed_ir.ty)
(ret_value : Script_typed_ir.ty) (lambda_rec_ty : Script_typed_ir.ty)
(script_instr : Alpha_context.Script.node) ⇒
let? function_parameter :=
parse_instr_aux elab_conf (stack_depth +i 1) tc_context_value ctxt
script_instr
(Script_typed_ir.Item_t arg
(Script_typed_ir.Item_t lambda_rec_ty Script_typed_ir.Bot_t)) in
match function_parameter with
|
(Typed
({|
descr.loc := loc_value;
descr.aft :=
(Script_typed_ir.Item_t ty_value Script_typed_ir.Bot_t) as
stack_ty
|} as descr_value), ctxt) ⇒
let error_details := Script_tc_errors.Informative loc_value in
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(Gas_monad.record_trace_eval error_details
(fun (loc_value : Alpha_context.Script.location) ⇒
let ret_value :=
Script_ir_unparser.serialize_ty_for_error ret_value in
let stack_ty :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_ty in
Build_extensible "Bad_return"
(Alpha_context.Script.location ×
Script_tc_errors.unparsed_stack_ty × Alpha_context.Script.expr)
(loc_value, stack_ty, ret_value))
(ty_eq error_details ty_value ret_value)) in
let? 'Eq := eq_value in
return?
((Script_typed_ir.LamRec (close_descr descr_value) script_instr), ctxt)
| (Typed {| descr.loc := loc_value; descr.aft := stack_ty |}, ctxt) ⇒
let ret_value := Script_ir_unparser.serialize_ty_for_error ret_value in
let stack_ty := Script_ir_unparser.serialize_stack_for_error ctxt stack_ty
in
Error_monad.tzfail
(Build_extensible "Bad_return"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Alpha_context.Script.expr) (loc_value, stack_ty, ret_value))
| (Failed {| judgement.Failed.descr := descr_value |}, ctxt) ⇒
return?
((Script_typed_ir.LamRec
(close_descr
(descr_value
(Script_typed_ir.Item_t ret_value Script_typed_ir.Bot_t)))
script_instr), ctxt)
end)
and "'parse_contract" :=
(fun (err : Set) ⇒ fun
(stack_depth : int) (ctxt : Alpha_context.context)
(error_details :
Script_tc_errors.error_details Alpha_context.Script.location)
(loc_value : Alpha_context.Script.location) (arg : Script_typed_ir.ty)
(destination : Alpha_context.Destination.t)
(entrypoint : Alpha_context.Entrypoint.t) ⇒
let error_value {B : Set}
(ctxt : Alpha_context.context)
(f_err : Alpha_context.Script.location → Error_monad._error)
: Alpha_context.context × Pervasives.result B err :=
(ctxt,
(Pervasives.Error
match error_details with
| Script_tc_errors.Fast ⇒
cast err Script_tc_errors.Inconsistent_types_fast
| Script_tc_errors.Informative loc_value ⇒
let loc_value := cast Alpha_context.Script.location loc_value in
cast err (Error_monad.trace_of_error (f_err loc_value))
end)) in
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle in
match destination with
| Alpha_context.Destination.Contract contract ⇒
match contract with
| Contract_repr.Implicit pkh ⇒
if Alpha_context.Entrypoint.is_default entrypoint then
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt (ty_eq error_details arg Script_typed_ir.unit_t)
in
return?
(ctxt,
(let? 'Eq := eq_value in
return? (Script_typed_ir.Typed_implicit pkh)))
else
return?
(error_value ctxt
(fun (_loc : Alpha_context.Script.location) ⇒
Build_extensible "No_such_entrypoint" Alpha_context.Entrypoint.t
entrypoint))
| Contract_repr.Originated contract_hash ⇒
Error_monad.trace_value
(Build_extensible "Invalid_contract"
(Alpha_context.Script.location × Alpha_context.Contract.t)
(loc_value, contract))
(let? '(ctxt, code) :=
Alpha_context.Contract.get_script_code ctxt contract_hash in
match code with
| None ⇒
return?
(error_value ctxt
(fun (loc_value : Alpha_context.Script.location) ⇒
Build_extensible "Invalid_contract"
(Alpha_context.Script.location × Alpha_context.Contract.t)
(loc_value, contract)))
| Some code ⇒
let? '(code, ctxt) :=
Alpha_context.Script.force_decode_in_context
Alpha_context.Script.When_needed ctxt code in
let? '({| toplevel.arg_type := arg_type |}, ctxt) :=
parse_toplevel_aux ctxt true code in
let?
'(Ex_parameter_ty_and_entrypoints {|
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.arg_type :=
targ;
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.entrypoints
:= entrypoints
|}, ctxt) :=
parse_parameter_ty_and_entrypoints_aux ctxt (stack_depth +i 1)
true arg_type in
let 'existT _ __Ex_parameter_ty_and_entrypoints_'a1
[ctxt, entrypoints, targ] :=
cast_exists (Es := Set)
(fun __Ex_parameter_ty_and_entrypoints_'a1 ⇒
[Alpha_context.context ** Script_typed_ir.entrypoints **
Script_typed_ir.ty]) [ctxt, entrypoints, targ] in
let? '(entrypoint_arg, ctxt) :=
Gas_monad.run ctxt
((find_entrypoint_for_type
(full := __Ex_parameter_ty_and_entrypoints_'a1)) error_details
targ arg entrypoints entrypoint) in
return?
(ctxt,
(let? '(entrypoint, arg_ty) := entrypoint_arg in
return?
(Script_typed_ir.Typed_originated
{|
Script_typed_ir.typed_contract.Typed_originated.arg_ty :=
arg_ty;
Script_typed_ir.typed_contract.Typed_originated.contract_hash
:= contract_hash;
Script_typed_ir.typed_contract.Typed_originated.entrypoint
:= entrypoint; |})))
end)
end
| Alpha_context.Destination.Tx_rollup tx_rollup ⇒
let? ctxt := Alpha_context.Tx_rollup_state.assert_exist ctxt tx_rollup in
return?
(if Alpha_context.Entrypoint.is_deposit entrypoint then
match arg with
|
Script_typed_ir.Pair_t (Script_typed_ir.Ticket_t _ _)
Script_typed_ir.Tx_rollup_l2_address_t _ _ ⇒
(ctxt,
(return?
(Script_typed_ir.Typed_tx_rollup
{|
Script_typed_ir.typed_contract.Typed_tx_rollup.arg_ty :=
arg;
Script_typed_ir.typed_contract.Typed_tx_rollup.tx_rollup :=
tx_rollup; |})))
| _ ⇒
error_value ctxt
(fun (loc_value : Alpha_context.Script.location) ⇒
Build_extensible "Tx_rollup_bad_deposit_parameter"
(Alpha_context.Script.location × Alpha_context.Script.expr)
(loc_value, (Script_ir_unparser.serialize_ty_for_error arg)))
end
else
error_value ctxt
(fun (_loc : Alpha_context.Script.location) ⇒
Build_extensible "No_such_entrypoint" Alpha_context.Entrypoint.t
entrypoint))
| Alpha_context.Destination.Zk_rollup zk_rollup ⇒
let? ctxt := Alpha_context.Zk_rollup.assert_exist ctxt zk_rollup in
return?
(if Alpha_context.Entrypoint.is_deposit entrypoint then
match arg with
|
Script_typed_ir.Pair_t (Script_typed_ir.Ticket_t _ _)
Script_typed_ir.Bytes_t _ _ ⇒
(ctxt,
(return?
(Script_typed_ir.Typed_zk_rollup
{|
Script_typed_ir.typed_contract.Typed_zk_rollup.arg_ty :=
arg;
Script_typed_ir.typed_contract.Typed_zk_rollup.zk_rollup :=
zk_rollup; |})))
| _ ⇒
error_value ctxt
(fun (loc_value : Alpha_context.Script.location) ⇒
Build_extensible "Zk_rollup_bad_deposit_parameter"
(Alpha_context.Script.location × Alpha_context.Script.expr)
(loc_value, (Script_ir_unparser.serialize_ty_for_error arg)))
end
else
error_value ctxt
(fun (_loc : Alpha_context.Script.location) ⇒
Build_extensible "No_such_entrypoint" Alpha_context.Entrypoint.t
entrypoint))
| Alpha_context.Destination.Sc_rollup sc_rollup ⇒
let? '(parameters_type, ctxt) :=
Alpha_context.Sc_rollup.parameters_type ctxt sc_rollup in
match parameters_type with
| None ⇒
return?
(error_value ctxt
(fun (_loc : Alpha_context.Script.location) ⇒
Build_extensible "Sc_rollup_does_not_exist"
Alpha_context.Sc_rollup.t sc_rollup))
| Some parameters_type ⇒
let? '(parameters_type, ctxt) :=
Alpha_context.Script.force_decode_in_context
Alpha_context.Script.When_needed ctxt parameters_type in
let?
'(Ex_parameter_ty_and_entrypoints {|
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.arg_type :=
full_value;
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.entrypoints
:= entrypoints
|}, ctxt) :=
parse_parameter_ty_and_entrypoints_aux ctxt (stack_depth +i 1) true
(Micheline.root_value parameters_type) in
let 'existT _ __Ex_parameter_ty_and_entrypoints_'a2
[ctxt, entrypoints, full_value] :=
cast_exists (Es := Set)
(fun __Ex_parameter_ty_and_entrypoints_'a2 ⇒
[Alpha_context.context ** Script_typed_ir.entrypoints **
Script_typed_ir.ty]) [ctxt, entrypoints, full_value] in
let? '(entrypoint_arg, ctxt) :=
Gas_monad.run ctxt
((find_entrypoint_for_type
(full := __Ex_parameter_ty_and_entrypoints_'a2)) error_details
full_value arg entrypoints entrypoint) in
return?
(ctxt,
(let? '(entrypoint, arg_ty) := entrypoint_arg in
return?
(Script_typed_ir.Typed_sc_rollup
{|
Script_typed_ir.typed_contract.Typed_sc_rollup.arg_ty :=
arg_ty;
Script_typed_ir.typed_contract.Typed_sc_rollup.sc_rollup :=
sc_rollup;
Script_typed_ir.typed_contract.Typed_sc_rollup.entrypoint :=
entrypoint; |})))
end
end)
and "'parse_contract_data_aux" :=
(fun
(stack_depth : int) (ctxt : Alpha_context.context)
(loc_value : Alpha_context.Script.location) (arg : Script_typed_ir.ty)
(destination : Alpha_context.Destination.t)
(entrypoint : Alpha_context.Entrypoint.t) ⇒
let parse_contract {err} := 'parse_contract err in
let error_details := Script_tc_errors.Informative loc_value in
let? '(ctxt, res) :=
parse_contract (stack_depth +i 1) ctxt error_details loc_value arg
destination entrypoint in
let? res := res in
return? (ctxt, res)).
Definition parse_views := 'parse_views.
Definition parse_kdescr := 'parse_kdescr.
Definition parse_lam_rec := 'parse_lam_rec.
Definition parse_contract {err : Set} := 'parse_contract err.
Definition parse_contract_data_aux := 'parse_contract_data_aux.
Definition parse_contract_for_script
(ctxt : Alpha_context.context) (loc_value : Alpha_context.Script.location)
(arg : Script_typed_ir.ty) (destination : Alpha_context.Destination.t)
(entrypoint : Alpha_context.Entrypoint.t)
: M? (Alpha_context.context × option Script_typed_ir.typed_contract) :=
let? '(ctxt, res) :=
parse_contract 0 ctxt Script_tc_errors.Fast loc_value arg destination
entrypoint in
return?
(ctxt,
match res with
| Pervasives.Ok res ⇒ Some res
| Pervasives.Error Script_tc_errors.Inconsistent_types_fast ⇒ None
end).
Definition view_size (view : Script_typed_ir.view)
: Cache_memory_helpers.nodes_and_size :=
Script_typed_ir_size.op_plusplus
(Script_typed_ir_size.op_plusplus
(Script_typed_ir_size.node_size view.(Script_typed_ir.view.view_code))
(Script_typed_ir_size.node_size view.(Script_typed_ir.view.input_ty)))
(Script_typed_ir_size.node_size view.(Script_typed_ir.view.output_ty)).
Definition code_size {A : Set}
(ctxt : Alpha_context.context) (code : Script_typed_ir.lambda)
(views : Script_typed_ir.map A Script_typed_ir.view)
: M? (Cache_memory_helpers.sint × Alpha_context.context) :=
let views_size :=
Script_map.fold
(fun (function_parameter : A) ⇒
let '_ := function_parameter in
fun (v_value : Script_typed_ir.view) ⇒
fun (s_value : Cache_memory_helpers.nodes_and_size) ⇒
Script_typed_ir_size.op_plusplus (view_size v_value) s_value) views
Script_typed_ir_size.zero in
let ir_size := Script_typed_ir_size.lambda_size code in
let '(nodes, code_size) := Script_typed_ir_size.op_plusplus views_size ir_size
in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Script_typed_ir_size_costs.nodes_cost nodes)
in
return? (code_size, ctxt).
Definition parse_code
(elab_conf : elab_conf) (ctxt : Alpha_context.context)
(code : Alpha_context.Script.lazy_expr)
: M? (ex_code × Alpha_context.context) :=
let? '(code, ctxt) :=
Alpha_context.Script.force_decode_in_context
Alpha_context.Script.When_needed ctxt code in
let legacy := elab_conf.(Script_ir_translator_config.elab_config.legacy) in
let? '(ctxt, code) := Alpha_context.Global_constants_storage.expand ctxt code
in
let?
'({|
toplevel.code_field := code_field;
toplevel.arg_type := arg_type;
toplevel.storage_type := storage_type;
toplevel.views := views
|}, ctxt) := parse_toplevel_aux ctxt legacy code in
let arg_type_loc := location arg_type in
let?
'(Ex_parameter_ty_and_entrypoints {|
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.arg_type :=
arg_type;
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.entrypoints
:= entrypoints
|}, ctxt) :=
Error_monad.record_trace
(Build_extensible "Ill_formed_type"
(option string × Alpha_context.Script.expr ×
Alpha_context.Script.location)
((Some "parameter"), code, arg_type_loc))
(parse_parameter_ty_and_entrypoints_aux ctxt 0 legacy arg_type) in
let storage_type_loc := location storage_type in
let? '(Script_typed_ir.Ex_ty storage_type, ctxt) :=
Error_monad.record_trace
(Build_extensible "Ill_formed_type"
(option string × Alpha_context.Script.expr ×
Alpha_context.Script.location)
((Some "storage"), code, storage_type_loc))
(parse_storage_ty ctxt 0 legacy storage_type) in
let? 'Script_typed_ir.Ty_ex_c arg_type_full :=
Script_typed_ir.pair_t storage_type_loc arg_type storage_type in
let? 'Script_typed_ir.Ty_ex_c ret_type_full :=
Script_typed_ir.pair_t storage_type_loc Script_typed_ir.list_operation_t
storage_type in
let? '(kdescr, ctxt) :=
Error_monad.trace_value
(Build_extensible "Ill_typed_contract"
(Alpha_context.Script.expr × Script_tc_errors.type_map) (code, nil))
(parse_kdescr elab_conf 0
(Tc_context.toplevel_value storage_type arg_type entrypoints) ctxt
arg_type_full ret_type_full code_field) in
let code := Script_typed_ir.Lam kdescr code_field in
let? '(code_size, ctxt) := code_size ctxt code views in
return?
((Ex_code
(Code
{| code.Code.code := code; code.Code.arg_type := arg_type;
code.Code.storage_type := storage_type; code.Code.views := views;
code.Code.entrypoints := entrypoints;
code.Code.code_size := code_size; |})), ctxt).
Definition parse_storage {storage : Set}
(elab_conf : elab_conf) (ctxt : Alpha_context.context) (allow_forged : bool)
(storage_type : Script_typed_ir.ty)
(storage_value : Alpha_context.Script.lazy_expr)
: M? (storage × Alpha_context.context) :=
let? '(storage_value, ctxt) :=
Alpha_context.Script.force_decode_in_context
Alpha_context.Script.When_needed ctxt storage_value in
Error_monad.trace_eval
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
let storage_type := Script_ir_unparser.serialize_ty_for_error storage_type
in
Build_extensible "Ill_typed_data"
(option string × Alpha_context.Script.expr × Alpha_context.Script.expr)
(None, storage_value, storage_type))
(parse_data_aux elab_conf 0 ctxt allow_forged storage_type
(Micheline.root_value storage_value)).
Definition parse_script
(elab_conf : elab_conf) (ctxt : Alpha_context.context)
(allow_forged_in_storage : bool) (function_parameter : Alpha_context.Script.t)
: M? (ex_script × Alpha_context.context) :=
let '{|
Alpha_context.Script.t.code := code;
Alpha_context.Script.t.storage := storage_value
|} := function_parameter in
let?
'(Ex_code
(Code {|
code.Code.code := code;
code.Code.arg_type := arg_type;
code.Code.storage_type := storage_type;
code.Code.views := views;
code.Code.entrypoints := entrypoints;
code.Code.code_size := code_size
|}), ctxt) := parse_code elab_conf ctxt code in
let 'existT _ __Ex_code_'c
[ctxt, code_size, entrypoints, views, storage_type, arg_type, code] :=
cast_exists (Es := Set)
(fun __Ex_code_'c ⇒
[Alpha_context.context ** Cache_memory_helpers.sint **
Script_typed_ir.entrypoints ** Script_typed_ir.view_map **
Script_typed_ir.ty ** Script_typed_ir.ty ** Script_typed_ir.lambda])
[ctxt, code_size, entrypoints, views, storage_type, arg_type, code] in
let? '(storage_value, ctxt) :=
parse_storage elab_conf ctxt allow_forged_in_storage storage_type
storage_value in
return?
((Ex_script
(Script_typed_ir.Script
{| Script_typed_ir.script.Script.code := code;
Script_typed_ir.script.Script.arg_type := arg_type;
Script_typed_ir.script.Script.storage :=
(storage_value : __Ex_code_'c);
Script_typed_ir.script.Script.storage_type := storage_type;
Script_typed_ir.script.Script.views := views;
Script_typed_ir.script.Script.entrypoints := entrypoints;
Script_typed_ir.script.Script.code_size := code_size; |})), ctxt).
Module ex_parameter_ty_and_entrypoints.
Module Ex_parameter_ty_and_entrypoints.
Record record {arg_type entrypoints : Set} : Set := Build {
arg_type : arg_type;
entrypoints : entrypoints;
}.
Arguments record : clear implicits.
Definition with_arg_type {t_arg_type t_entrypoints} arg_type
(r : record t_arg_type t_entrypoints) :=
Build t_arg_type t_entrypoints arg_type r.(entrypoints).
Definition with_entrypoints {t_arg_type t_entrypoints} entrypoints
(r : record t_arg_type t_entrypoints) :=
Build t_arg_type t_entrypoints r.(arg_type) entrypoints.
End Ex_parameter_ty_and_entrypoints.
Definition Ex_parameter_ty_and_entrypoints_skeleton :=
Ex_parameter_ty_and_entrypoints.record.
End ex_parameter_ty_and_entrypoints.
End ConstructorRecords_ex_parameter_ty_and_entrypoints.
Import ConstructorRecords_ex_parameter_ty_and_entrypoints.
Reserved Notation
"'ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints".
Inductive ex_parameter_ty_and_entrypoints : Set :=
| Ex_parameter_ty_and_entrypoints :
'ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints →
ex_parameter_ty_and_entrypoints
where "'ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints" :=
(ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints_skeleton
Script_typed_ir.ty Script_typed_ir.entrypoints).
Module ex_parameter_ty_and_entrypoints.
Include ConstructorRecords_ex_parameter_ty_and_entrypoints.ex_parameter_ty_and_entrypoints.
Definition Ex_parameter_ty_and_entrypoints :=
'ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.
End ex_parameter_ty_and_entrypoints.
Definition parse_parameter_ty_and_entrypoints_aux
(ctxt : Alpha_context.context) (stack_depth : int) (legacy : bool)
(node_value : Alpha_context.Script.node)
: M? (ex_parameter_ty_and_entrypoints × Alpha_context.context) :=
let?
'(Ex_parameter_ty_and_entrypoints_node {|
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.arg_type
:= arg_type;
ex_parameter_ty_and_entrypoints_node.Ex_parameter_ty_and_entrypoints_node.entrypoints
:= entrypoints
|}, ctxt) :=
parse_passable_ty_aux_with_ret ctxt (stack_depth +i 1) legacy
Parse_entrypoints node_value in
let? '_ :=
if legacy then
Result.return_unit
else
well_formed_entrypoints arg_type entrypoints in
let entrypoints :=
{| Script_typed_ir.entrypoints.root := entrypoints;
Script_typed_ir.entrypoints.original_type_expr := node_value; |} in
return?
((Ex_parameter_ty_and_entrypoints
{|
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.arg_type
:= arg_type;
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.entrypoints
:= entrypoints; |}), ctxt).
Definition parse_passable_ty_aux
: Alpha_context.context → int → bool → Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
fun x_1 x_2 x_3 ⇒
parse_passable_ty_aux_with_ret x_1 x_2 x_3 Don't_parse_entrypoints.
Definition parse_uint (nb_bits : int)
: Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? int :=
if (nb_bits ≥i 0) && (nb_bits ≤i 30) then
let max_int := (Pervasives.lsl 1 nb_bits) -i 1 in
let max_z := Z.of_int max_int in
fun (function_parameter :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim) ⇒
match
(function_parameter,
match function_parameter with
| Micheline.Int _ n_value ⇒
(Z.zero ≤Z n_value) && (n_value ≤Z max_z)
| _ ⇒ false
end) with
| (Micheline.Int _ n_value, true) ⇒ return? (Z.to_int n_value)
| (node_value, _) ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
((location node_value), (Micheline.strip_locations node_value),
(Pervasives.op_caret "a positive "
(Pervasives.op_caret (Pervasives.string_of_int nb_bits)
(Pervasives.op_caret "-bit integer (between 0 and "
(Pervasives.op_caret (Pervasives.string_of_int max_int) ")"))))))
end
else
fun (function_parameter :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim) ⇒
let '_ := function_parameter in
Error_monad.error_value (Build_extensible "Asserted" unit tt).
Definition parse_uint10
: Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? int := parse_uint 10.
Definition parse_uint11
: Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? int := parse_uint 11.
Definition opened_ticket_type
(loc_value : Alpha_context.Script.location)
(ty_value : Script_typed_ir.comparable_ty)
: M? Script_typed_ir.comparable_ty :=
Script_typed_ir.comparable_pair_3_t loc_value Script_typed_ir.address_t
ty_value Script_typed_ir.nat_t.
Definition parse_unit
(ctxt : Alpha_context.context) (legacy : bool)
(function_parameter :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
: M? (unit × Alpha_context.context) :=
match function_parameter with
| Micheline.Prim loc_value Michelson_v1_primitives.D_Unit [] annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.unit_value in
return? (tt, ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_Unit l_value _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.D_Unit, 0, (List.length l_value)))
| expr ⇒
Error_monad.error_value
(unexpected expr nil Michelson_v1_primitives.Constant_namespace
[ Michelson_v1_primitives.D_Unit ])
end.
Definition parse_bool
(ctxt : Alpha_context.context) (legacy : bool)
(function_parameter :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
: M? (bool × Alpha_context.context) :=
match function_parameter with
| Micheline.Prim loc_value Michelson_v1_primitives.D_True [] annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.bool_value in
return? (true, ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_False [] annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.bool_value in
return? (false, ctxt)
|
Micheline.Prim loc_value
((Michelson_v1_primitives.D_True | Michelson_v1_primitives.D_False) as
c_value) l_value _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, c_value, 0, (List.length l_value)))
| expr ⇒
Error_monad.error_value
(unexpected expr nil Michelson_v1_primitives.Constant_namespace
[ Michelson_v1_primitives.D_True; Michelson_v1_primitives.D_False ])
end.
Definition parse_string
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_string.t × Alpha_context.context) :=
match function_parameter with
| (Micheline.String loc_value v_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.check_printable v_value)
in
Error_monad.record_trace
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a printable ascii string"))
(let? s_value := Script_string.of_string v_value in
return? (s_value, ctxt))
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.String_kind ], (kind_value expr)))
end.
Definition parse_bytes {A B : Set}
(ctxt : A)
(function_parameter : Micheline.node Alpha_context.Script.location B)
: M? (bytes × A) :=
match function_parameter with
| Micheline.Bytes _ v_value ⇒ return? (v_value, ctxt)
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr)))
end.
Definition parse_int {A B : Set}
(ctxt : A)
(function_parameter : Micheline.node Alpha_context.Script.location B)
: M? (Script_int.num × A) :=
match function_parameter with
| Micheline.Int _ v_value ⇒ return? ((Script_int.of_zint v_value), ctxt)
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Int_kind ], (kind_value expr)))
end.
Definition parse_nat
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_int.num × Alpha_context.context) :=
match function_parameter with
| (Micheline.Int loc_value v_value) as expr ⇒
let v_value := Script_int.of_zint v_value in
match Script_int.is_nat v_value with
| Some nat ⇒ return? (nat, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a non-negative integer"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Int_kind ], (kind_value expr)))
end.
Definition parse_mutez
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Alpha_context.Tez.t × Alpha_context.context) :=
match function_parameter with
| (Micheline.Int loc_value v_value) as expr ⇒
match
Option.bind
(Option.catch None
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
Z.to_int64 v_value)) Alpha_context.Tez.of_mutez with
| Some tez ⇒ Pervasives.Ok (tez, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid mutez amount"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Int_kind ], (kind_value expr)))
end.
Definition parse_timestamp
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_timestamp.t × Alpha_context.context) :=
match function_parameter with
| Micheline.Int _ v_value ⇒
return? ((Script_timestamp.of_zint v_value), ctxt)
| (Micheline.String loc_value s_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Typecheck_costs.timestamp_readable s_value) in
match Script_timestamp.of_string s_value with
| Some v_value ⇒ return? (v_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid timestamp"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Int_kind ],
(kind_value expr)))
end.
Definition parse_key
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Alpha_context.public_key × Alpha_context.context) :=
match function_parameter with
| (Micheline.Bytes loc_value bytes_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.public_key_optimized in
match
Data_encoding.Binary.of_bytes_opt
Signature.Public_key.(S.SIGNATURE_PUBLIC_KEY.encoding) bytes_value with
| Some k_value ⇒ return? (k_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid public key"))
end
| (Micheline.String loc_value s_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.public_key_readable in
match Signature.Public_key.(S.SIGNATURE_PUBLIC_KEY.of_b58check_opt) s_value
with
| Some k_value ⇒ return? (k_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid public key"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Bytes_kind ],
(kind_value expr)))
end.
Definition parse_key_hash
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Alpha_context.public_key_hash × Alpha_context.context) :=
match function_parameter with
| (Micheline.Bytes loc_value bytes_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.key_hash_optimized in
match
Data_encoding.Binary.of_bytes_opt
Signature.Public_key_hash.(S.SIGNATURE_PUBLIC_KEY_HASH.encoding)
bytes_value with
| Some k_value ⇒ return? (k_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid key hash"))
end
| (Micheline.String loc_value s_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.key_hash_readable in
match
Signature.Public_key_hash.(S.SIGNATURE_PUBLIC_KEY_HASH.of_b58check_opt)
s_value with
| Some k_value ⇒ return? (k_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid key hash"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Bytes_kind ],
(kind_value expr)))
end.
Definition parse_signature
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_typed_ir.signature × Alpha_context.context) :=
match function_parameter with
| (Micheline.Bytes loc_value bytes_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.signature_optimized in
match
Data_encoding.Binary.of_bytes_opt
Script_typed_ir.Script_signature.encoding bytes_value with
| Some k_value ⇒ return? (k_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid signature"))
end
| (Micheline.String loc_value s_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.signature_readable in
match Script_typed_ir.Script_signature.of_b58check_opt s_value with
| Some s_value ⇒ return? (s_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid signature"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Bytes_kind ],
(kind_value expr)))
end.
Definition parse_chain_id
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_typed_ir.Script_chain_id.t × Alpha_context.context) :=
match function_parameter with
| (Micheline.Bytes loc_value bytes_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.chain_id_optimized in
match
Data_encoding.Binary.of_bytes_opt Script_typed_ir.Script_chain_id.encoding
bytes_value with
| Some k_value ⇒ return? (k_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid chain id"))
end
| (Micheline.String loc_value s_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.chain_id_readable in
match Script_typed_ir.Script_chain_id.of_b58check_opt s_value with
| Some s_value ⇒ return? (s_value, ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid chain id"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Bytes_kind ],
(kind_value expr)))
end.
Definition parse_address (ctxt : Alpha_context.context)
: Alpha_context.Script.node →
M? (Script_typed_ir.address × Alpha_context.context) :=
let destination_allowed
(loc_value : Alpha_context.Script.location)
(function_parameter : Script_typed_ir.address)
: Alpha_context.context →
M? (Script_typed_ir.address × Alpha_context.context) :=
let '{|
Script_typed_ir.address.destination := destination;
Script_typed_ir.address.entrypoint := entrypoint
|} := function_parameter in
fun (ctxt : Alpha_context.context) ⇒
match
(destination,
match destination with
| Alpha_context.Destination.Tx_rollup _ ⇒
Pervasives.not (Alpha_context.Constants.tx_rollup_enable ctxt)
| _ ⇒ false
end,
match destination with
| Alpha_context.Destination.Sc_rollup _ ⇒
Pervasives.not (Alpha_context.Constants.sc_rollup_enable ctxt)
| _ ⇒ false
end,
match destination with
| Alpha_context.Destination.Zk_rollup _ ⇒
Pervasives.not (Alpha_context.Constants.zk_rollup_enable ctxt)
| _ ⇒ false
end) with
| (Alpha_context.Destination.Tx_rollup _, true, _, _) ⇒
Error_monad.error_value
(Build_extensible "Tx_rollup_addresses_disabled"
Alpha_context.Script.location loc_value)
| (Alpha_context.Destination.Sc_rollup _, _, true, _) ⇒
Error_monad.error_value
(Build_extensible "Sc_rollup_disabled" Alpha_context.Script.location
loc_value)
| (Alpha_context.Destination.Zk_rollup _, _, _, true) ⇒
Error_monad.error_value
(Build_extensible "Zk_rollup_disabled" Alpha_context.Script.location
loc_value)
| (_, _, _, _) ⇒
Pervasives.Ok
({| Script_typed_ir.address.destination := destination;
Script_typed_ir.address.entrypoint := entrypoint; |}, ctxt)
end in
fun (function_parameter : Alpha_context.Script.node) ⇒
match function_parameter with
| (Micheline.Bytes loc_value bytes_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.contract_optimized in
match
Data_encoding.Binary.of_bytes_opt
(Data_encoding.tup2 Alpha_context.Destination.encoding
Alpha_context.Entrypoint.value_encoding) bytes_value with
| Some (destination, entrypoint) ⇒
destination_allowed loc_value
{| Script_typed_ir.address.destination := destination;
Script_typed_ir.address.entrypoint := entrypoint; |} ctxt
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr), "a valid address"))
end
| Micheline.String loc_value s_value ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.contract_readable in
let? '(addr, entrypoint) :=
match String.index_opt s_value "%" % char with
| None ⇒ return? (s_value, Alpha_context.Entrypoint.default)
| Some pos ⇒
let len := ((String.length s_value) -i pos) -i 1 in
let name := String.sub s_value (pos +i 1) len in
let? entrypoint :=
Alpha_context.Entrypoint.of_string_strict loc_value name in
return? ((String.sub s_value 0 pos), entrypoint)
end in
let? destination := Alpha_context.Destination.of_b58check addr in
destination_allowed loc_value
{| Script_typed_ir.address.destination := destination;
Script_typed_ir.address.entrypoint := entrypoint; |} ctxt
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Bytes_kind ],
(kind_value expr)))
end.
Definition parse_tx_rollup_l2_address
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_typed_ir.tx_rollup_l2_address × Alpha_context.context) :=
match function_parameter with
| (Micheline.Bytes loc_value bytes_value) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.tx_rollup_l2_address in
match Tx_rollup_l2_address.of_bytes_opt bytes_value with
| Some txa ⇒
return? ((Tx_rollup_l2_address.Indexable.value_value txa), ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr),
"a valid transaction rollup L2 address"))
end
| (Micheline.String loc_value str) as expr ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.tx_rollup_l2_address in
match Tx_rollup_l2_address.of_b58check_opt str with
| Some txa ⇒
return? ((Tx_rollup_l2_address.Indexable.value_value txa), ctxt)
| None ⇒
Error_monad.error_value
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr),
"a valid transaction rollup L2 address"))
end
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.String_kind; Script_tc_errors.Bytes_kind ],
(kind_value expr)))
end.
Definition parse_never {A : Set}
(expr : Micheline.node Alpha_context.Script.location A)
: M? (Script_typed_ir.never × Alpha_context.context) :=
Error_monad.error_value
(Build_extensible "Invalid_never_expr" Alpha_context.Script.location
(location expr)).
Definition parse_pair {A B C D E : Set}
(parse_l :
A →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? (B × C))
(parse_r :
C →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? (D × E)) (ctxt : A) (legacy : bool)
(r_comb_witness : Script_ir_unparser.comb_witness)
(expr : Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
: M? ((B × D) × E) :=
let parse_comb
(loc_value : Alpha_context.Script.location)
(l_value :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
(rs :
list
(Micheline.node Alpha_context.Script.location Alpha_context.Script.prim))
: M? ((B × D) × E) :=
let? '(l_value, ctxt) := parse_l ctxt l_value in
let? r_value :=
match (rs, r_comb_witness) with
| (cons r_value [], _) ⇒ return? r_value
| ([], _) ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
int) (loc_value, Michelson_v1_primitives.D_Pair, 2, 1))
| (cons _ _, Script_ir_unparser.Comb_Pair _) ⇒
return? (Micheline.Prim loc_value Michelson_v1_primitives.D_Pair rs nil)
| _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
int)
(loc_value, Michelson_v1_primitives.D_Pair, 2,
(1 +i (List.length rs))))
end in
let? '(r_value, ctxt) := parse_r ctxt r_value in
return? ((l_value, r_value), ctxt) in
match expr with
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Pair (cons l_value rs)
annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
parse_comb loc_value l_value rs
| Micheline.Prim loc_value Michelson_v1_primitives.D_Pair l_value _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.D_Pair, 2, (List.length l_value)))
| Micheline.Seq loc_value (cons l_value ((cons _ _) as rs)) ⇒
parse_comb loc_value l_value rs
| Micheline.Seq loc_value l_value ⇒
Error_monad.tzfail
(Build_extensible "Invalid_seq_arity"
(Alpha_context.Script.location × int × int)
(loc_value, 2, (List.length l_value)))
| expr ⇒
Error_monad.tzfail
(unexpected expr nil Michelson_v1_primitives.Constant_namespace
[ Michelson_v1_primitives.D_Pair ])
end.
Definition parse_union {A B C D : Set}
(parse_l :
A →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? (B × C))
(parse_r :
A →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? (D × C)) (ctxt : A) (legacy : bool)
(function_parameter :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
: M? (Script_typed_ir.union B D × C) :=
match function_parameter with
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Left (cons v_value [])
annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(v_value, ctxt) := parse_l ctxt v_value in
return? ((Script_typed_ir.L v_value), ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_Left l_value _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.D_Left, 1, (List.length l_value)))
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Right (cons v_value [])
annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(v_value, ctxt) := parse_r ctxt v_value in
return? ((Script_typed_ir.R v_value), ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_Right l_value _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.D_Right, 1, (List.length l_value)))
| expr ⇒
Error_monad.tzfail
(unexpected expr nil Michelson_v1_primitives.Constant_namespace
[ Michelson_v1_primitives.D_Left; Michelson_v1_primitives.D_Right ])
end.
Definition parse_option {A B : Set}
(parse_v :
A →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? (B × A)) (ctxt : A) (legacy : bool)
(function_parameter :
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
: M? (option B × A) :=
match function_parameter with
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Some (cons v_value [])
annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(v_value, ctxt) := parse_v ctxt v_value in
return? ((Some v_value), ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_Some l_value _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.D_Some, 1, (List.length l_value)))
| Micheline.Prim loc_value Michelson_v1_primitives.D_None [] annot ⇒
let? '_ :=
if legacy then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
return? (None, ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_None l_value _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.D_None, 0, (List.length l_value)))
| expr ⇒
Error_monad.tzfail
(unexpected expr nil Michelson_v1_primitives.Constant_namespace
[ Michelson_v1_primitives.D_Some; Michelson_v1_primitives.D_None ])
end.
Definition comb_witness1 (function_parameter : Script_typed_ir.ty)
: Script_ir_unparser.comb_witness :=
match function_parameter with
| Script_typed_ir.Pair_t _ _ _ _ ⇒
Script_ir_unparser.Comb_Pair Script_ir_unparser.Comb_Any
| _ ⇒ Script_ir_unparser.Comb_Any
end.
#[bypass_check(guard)]
Definition parse_view_name
(ctxt : Alpha_context.context)
(function_parameter : Alpha_context.Script.node)
: M? (Script_string.t × Alpha_context.context) :=
match function_parameter with
| (Micheline.String loc_value v_value) as expr ⇒
if (String.length v_value) >i 31 then
Error_monad.error_value
(Build_extensible "View_name_too_long" string v_value)
else
let fix check_char (i_value : int) {struct i_value} : M? string :=
if i_value <i 0 then
return? v_value
else
if Script_ir_annot.is_allowed_char (String.get v_value i_value) then
check_char (i_value -i 1)
else
Error_monad.error_value
(Build_extensible "Bad_view_name" Alpha_context.Script.location
loc_value) in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.check_printable v_value)
in
Error_monad.record_trace
(Build_extensible "Invalid_syntactic_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim × string)
(loc_value, (Micheline.strip_locations expr),
"string [a-zA-Z0-9_.%@] and the maximum string length of 31 characters"))
(let? v_value := check_char ((String.length v_value) -i 1) in
let? s_value := Script_string.of_string v_value in
return? (s_value, ctxt))
| expr ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.String_kind ], (kind_value expr)))
end.
Definition parse_toplevel_aux
(ctxt : Alpha_context.context) (legacy : bool)
(toplevel_value : Alpha_context.Script.expr)
: M? (toplevel × Alpha_context.context) :=
Error_monad.record_trace
(Build_extensible "Ill_typed_contract"
(Alpha_context.Script.expr × Script_tc_errors.type_map)
(toplevel_value, nil))
match Micheline.root_value toplevel_value with
| Micheline.Int loc_value _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Micheline.canonical_location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Seq_kind ], Script_tc_errors.Int_kind))
| Micheline.String loc_value _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Micheline.canonical_location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Seq_kind ],
Script_tc_errors.String_kind))
| Micheline.Bytes loc_value _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Micheline.canonical_location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Seq_kind ], Script_tc_errors.Bytes_kind))
| Micheline.Prim loc_value _ _ _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Micheline.canonical_location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Seq_kind ], Script_tc_errors.Prim_kind))
| Micheline.Seq _ fields ⇒
let fix find_fields
(ctxt : Alpha_context.context)
(p_value :
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim × Alpha_context.Script.location ×
Micheline.annot))
(s_value :
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim × Alpha_context.Script.location ×
Micheline.annot))
(c_value :
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim × Alpha_context.Script.location ×
Micheline.annot)) (views : Script_typed_ir.view_map)
(fields :
list
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim))
: M?
(Alpha_context.context ×
(option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim × Alpha_context.Script.location ×
Micheline.annot) ×
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim × Alpha_context.Script.location ×
Micheline.annot) ×
option
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim × Alpha_context.Script.location ×
Micheline.annot) × Script_typed_ir.view_map)) :=
match fields with
| [] ⇒ return? (ctxt, (p_value, s_value, c_value, views))
| cons (Micheline.Int loc_value _) _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Prim_kind ],
Script_tc_errors.Int_kind))
| cons (Micheline.String loc_value _) _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Prim_kind ],
Script_tc_errors.String_kind))
| cons (Micheline.Bytes loc_value _) _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Prim_kind ],
Script_tc_errors.Bytes_kind))
| cons (Micheline.Seq loc_value _) _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
(loc_value, [ Script_tc_errors.Prim_kind ],
Script_tc_errors.Seq_kind))
|
cons
(Micheline.Prim loc_value Michelson_v1_primitives.K_parameter
(cons arg []) annot) rest ⇒
match p_value with
| None ⇒
find_fields ctxt (Some (arg, loc_value, annot)) s_value c_value
views rest
| Some _ ⇒
Error_monad.error_value
(Build_extensible "Duplicate_field"
(Alpha_context.Script.location × Alpha_context.Script.prim)
(loc_value, Michelson_v1_primitives.K_parameter))
end
|
cons
(Micheline.Prim loc_value Michelson_v1_primitives.K_storage
(cons arg []) annot) rest ⇒
match s_value with
| None ⇒
find_fields ctxt p_value (Some (arg, loc_value, annot)) c_value
views rest
| Some _ ⇒
Error_monad.error_value
(Build_extensible "Duplicate_field"
(Alpha_context.Script.location × Alpha_context.Script.prim)
(loc_value, Michelson_v1_primitives.K_storage))
end
|
cons
(Micheline.Prim loc_value Michelson_v1_primitives.K_code
(cons arg []) annot) rest ⇒
match c_value with
| None ⇒
find_fields ctxt p_value s_value (Some (arg, loc_value, annot))
views rest
| Some _ ⇒
Error_monad.error_value
(Build_extensible "Duplicate_field"
(Alpha_context.Script.location × Alpha_context.Script.prim)
(loc_value, Michelson_v1_primitives.K_code))
end
|
cons
(Micheline.Prim loc_value
((Michelson_v1_primitives.K_parameter |
Michelson_v1_primitives.K_storage | Michelson_v1_primitives.K_code)
as name) args _) _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
int) (loc_value, name, 1, (List.length args)))
|
cons
(Micheline.Prim loc_value Michelson_v1_primitives.K_view
(cons name (cons input_ty (cons output_ty (cons view_code [])))) _)
rest ⇒
let? '(str, ctxt) := parse_view_name ctxt name in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.view_update str views) in
if Script_map.mem str views then
Error_monad.error_value
(Build_extensible "Duplicated_view_name"
Alpha_context.Script.location loc_value)
else
let views' :=
Script_map.update str
(Some
{| Script_typed_ir.view.input_ty := input_ty;
Script_typed_ir.view.output_ty := output_ty;
Script_typed_ir.view.view_code := view_code; |}) views in
find_fields ctxt p_value s_value c_value views' rest
|
cons (Micheline.Prim loc_value Michelson_v1_primitives.K_view args _)
_ ⇒
Error_monad.error_value
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
int)
(loc_value, Michelson_v1_primitives.K_view, 4, (List.length args)))
| cons (Micheline.Prim loc_value name _ _) _ ⇒
let allowed :=
[
Michelson_v1_primitives.K_parameter;
Michelson_v1_primitives.K_storage;
Michelson_v1_primitives.K_code;
Michelson_v1_primitives.K_view
] in
Error_monad.error_value
(Build_extensible "Invalid_primitive"
(Alpha_context.Script.location × list Alpha_context.Script.prim ×
Alpha_context.Script.prim) (loc_value, allowed, name))
end in
let? '(ctxt, toplevel_value) :=
find_fields ctxt None None None
(Script_map.empty Script_typed_ir.string_t) fields in
match toplevel_value with
| (None, _, _, _) ⇒
Error_monad.error_value
(Build_extensible "Missing_field" Alpha_context.Script.prim
Michelson_v1_primitives.K_parameter)
| (Some _, None, _, _) ⇒
Error_monad.error_value
(Build_extensible "Missing_field" Alpha_context.Script.prim
Michelson_v1_primitives.K_storage)
| (Some _, Some _, None, _) ⇒
Error_monad.error_value
(Build_extensible "Missing_field" Alpha_context.Script.prim
Michelson_v1_primitives.K_code)
|
(Some (p_value, ploc, pannot), Some (s_value, sloc, sannot),
Some (c_value, cloc, cannot), views) ⇒
let p_pannot :=
let? function_parameter := Script_ir_annot.has_field_annot p_value in
match function_parameter with
| true ⇒ return? (p_value, pannot)
| false ⇒
match
(pannot,
match pannot with
| cons single [] ⇒ legacy
| _ ⇒ false
end) with
| (cons single [], true) ⇒
let? is_field_annot := Script_ir_annot.is_field_annot ploc single
in
match (is_field_annot, p_value) with
| (true, Micheline.Prim loc_value prim args annots) ⇒
return?
((Micheline.Prim loc_value prim args (cons single annots)),
nil)
| _ ⇒ return? (p_value, nil)
end
| (_, _) ⇒ return? (p_value, pannot)
end
end in
let? '(arg_type, pannot) := p_pannot in
let? '_ := Script_ir_annot.error_unexpected_annot ploc pannot in
let? '_ := Script_ir_annot.error_unexpected_annot cloc cannot in
let? '_ := Script_ir_annot.error_unexpected_annot sloc sannot in
return?
({| toplevel.code_field := c_value; toplevel.arg_type := arg_type;
toplevel.storage_type := s_value; toplevel.views := views; |}, ctxt)
end
end.
Reserved Notation "'parse_views".
Reserved Notation "'parse_kdescr".
Reserved Notation "'parse_lam_rec".
Reserved Notation "'parse_contract".
Reserved Notation "'parse_contract_data_aux".
#[bypass_check(guard)]
Fixpoint parse_data_aux {a : Set}
(elab_conf : elab_conf) (stack_depth : int) (ctxt : Alpha_context.context)
(allow_forged : bool) (ty_value : Script_typed_ir.ty)
(script_data : Alpha_context.Script.node) {struct ctxt}
: M? (a × Alpha_context.context) :=
let parse_kdescr := 'parse_kdescr in
let parse_lam_rec := 'parse_lam_rec in
let parse_contract_data_aux := 'parse_contract_data_aux in
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.parse_data_cycle
in
let non_terminal_recursion {B : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty)
(script_data : Alpha_context.Script.node)
: M? (B × Alpha_context.context) :=
if stack_depth >i 10000 then
Error_monad.tzfail
(Build_extensible "Typechecking_too_many_recursive_calls" unit tt)
else
parse_data_aux elab_conf (stack_depth +i 1) ctxt allow_forged ty_value
script_data in
let parse_data_error (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let ty_value := Script_ir_unparser.serialize_ty_for_error ty_value in
Build_extensible "Invalid_constant"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim ×
Alpha_context.Script.expr)
((location script_data), (Micheline.strip_locations script_data), ty_value)
in
let fail_parse_data {B : Set} (function_parameter : unit) : M? B :=
let '_ := function_parameter in
Error_monad.tzfail (parse_data_error tt) in
let traced_no_lwt {B : Set} (body : M? B) : M? B :=
Error_monad.record_trace_eval parse_data_error body in
let traced {B : Set} (body : M? B) : M? B :=
Error_monad.trace_eval parse_data_error body in
let traced_fail {B : Set} (err : Error_monad._error) : M? B :=
traced_no_lwt (Error_monad.error_value err) in
let parse_items {B C D E : Set}
(ctxt : Alpha_context.context)
(expr : Micheline.node B Alpha_context.Script.prim)
(key_type : Script_typed_ir.ty) (value_type : Script_typed_ir.ty)
(items :
list
(Micheline.node Alpha_context.Script.location Alpha_context.Script.prim))
(item_wrapper : C → D)
: M? (Script_typed_ir.map E D × Alpha_context.context) :=
let? '(_, items, ctxt) :=
traced
(List.fold_left_es
(fun (function_parameter :
option E × Script_typed_ir.map E D × Alpha_context.context) ⇒
let '(last_value, map, ctxt) := function_parameter in
fun (item :
Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim) ⇒
match item with
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Elt
(cons k_value (cons v_value [])) annot ⇒
let? '_ :=
if
elab_conf.(Script_ir_translator_config.elab_config.legacy)
then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(k_value, ctxt) :=
non_terminal_recursion ctxt key_type k_value in
let? '(v_value, ctxt) :=
non_terminal_recursion ctxt value_type v_value in
let? ctxt :=
match last_value with
| Some value_value ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.compare key_type
value_value k_value) in
let c_value :=
Script_comparable.compare_comparable key_type value_value
k_value in
if 0 ≤i c_value then
if 0 =i c_value then
Error_monad.error_value
(Build_extensible "Duplicate_map_keys"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
Error_monad.error_value
(Build_extensible "Unordered_map_keys"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
return? ctxt
| None ⇒ return? ctxt
end in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.map_update k_value map)
in
return?
((Some k_value),
(Script_map.update k_value (Some (item_wrapper v_value)) map),
ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_Elt l_value _
⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim ×
int × int)
(loc_value, Michelson_v1_primitives.D_Elt, 2,
(List.length l_value)))
| Micheline.Prim loc_value name _ _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_primitive"
(Alpha_context.Script.location ×
list Alpha_context.Script.prim × Alpha_context.Script.prim)
(loc_value, [ Michelson_v1_primitives.D_Elt ], name))
|
(Micheline.Int _ _ | Micheline.String _ _ | Micheline.Bytes _ _
| Micheline.Seq _ _) ⇒ fail_parse_data tt
end) (None, (Script_map.empty key_type), ctxt) items) in
return? (items, ctxt) in
let parse_big_map_items {B C D t : Set}
(ctxt : Alpha_context.context)
(expr : Micheline.node B Alpha_context.Script.prim)
(key_type : Script_typed_ir.comparable_ty) (value_type : Script_typed_ir.ty)
(items :
list
(Micheline.node Alpha_context.Script.location Alpha_context.Script.prim))
(item_wrapper : C → option D)
: M? (Script_typed_ir.big_map_overlay t D × Alpha_context.context) :=
let? '(_, map, ctxt) :=
traced
(List.fold_left_es
(fun (function_parameter :
option t × Script_typed_ir.big_map_overlay t D ×
Alpha_context.context) ⇒
let
'(last_key, {|
Script_typed_ir.big_map_overlay.map := map;
Script_typed_ir.big_map_overlay.size := size_value
|}, ctxt) := function_parameter in
fun (item :
Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim) ⇒
match item with
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Elt
(cons k_value (cons v_value [])) annot ⇒
let? '_ :=
if
elab_conf.(Script_ir_translator_config.elab_config.legacy)
then
Result.return_unit
else
Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(k_value, ctxt) :=
non_terminal_recursion ctxt key_type k_value in
let? '(key_hash, ctxt) :=
hash_comparable_data ctxt key_type k_value in
let? '(v_value, ctxt) :=
non_terminal_recursion ctxt value_type v_value in
let? ctxt :=
match last_key with
| Some last_key ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.compare key_type
last_key k_value) in
let c_value :=
Script_comparable.compare_comparable key_type last_key
k_value in
if 0 ≤i c_value then
if 0 =i c_value then
Error_monad.error_value
(Build_extensible "Duplicate_map_keys"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
Error_monad.error_value
(Build_extensible "Unordered_map_keys"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
return? ctxt
| None ⇒ return? ctxt
end in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.big_map_update
{| Script_typed_ir.big_map_overlay.map := map;
Script_typed_ir.big_map_overlay.size := size_value; |})
in
if
Script_typed_ir.Big_map_overlay.(Map.S.mem) key_hash map
then
Error_monad.error_value
(Build_extensible "Duplicate_map_keys"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
return?
((Some k_value),
{|
Script_typed_ir.big_map_overlay.map :=
Script_typed_ir.Big_map_overlay.(Map.S.add) key_hash
(k_value, (item_wrapper v_value)) map;
Script_typed_ir.big_map_overlay.size := size_value +i 1;
|}, ctxt)
| Micheline.Prim loc_value Michelson_v1_primitives.D_Elt l_value _
⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim ×
int × int)
(loc_value, Michelson_v1_primitives.D_Elt, 2,
(List.length l_value)))
| Micheline.Prim loc_value name _ _ ⇒
Error_monad.tzfail
(Build_extensible "Invalid_primitive"
(Alpha_context.Script.location ×
list Alpha_context.Script.prim × Alpha_context.Script.prim)
(loc_value, [ Michelson_v1_primitives.D_Elt ], name))
|
(Micheline.Int _ _ | Micheline.String _ _ | Micheline.Bytes _ _
| Micheline.Seq _ _) ⇒ fail_parse_data tt
end)
(None,
{|
Script_typed_ir.big_map_overlay.map :=
Script_typed_ir.Big_map_overlay.(Map.S.empty);
Script_typed_ir.big_map_overlay.size := 0; |}, ctxt) items) in
return? (map, ctxt) in
let legacy := elab_conf.(Script_ir_translator_config.elab_config.legacy) in
match (ty_value, script_data) with
| (Script_typed_ir.Unit_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_unit ctxt legacy expr))
| (Script_typed_ir.Bool_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_bool ctxt legacy expr))
| (Script_typed_ir.String_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_string ctxt expr))
| (Script_typed_ir.Bytes_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_bytes ctxt expr))
| (Script_typed_ir.Int_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context)) (traced_no_lwt (parse_int ctxt expr))
| (Script_typed_ir.Nat_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context)) (traced_no_lwt (parse_nat ctxt expr))
| (Script_typed_ir.Mutez_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_mutez ctxt expr))
| (Script_typed_ir.Timestamp_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_timestamp ctxt expr))
| (Script_typed_ir.Key_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context)) (traced_no_lwt (parse_key ctxt expr))
| (Script_typed_ir.Key_hash_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_key_hash ctxt expr))
| (Script_typed_ir.Signature_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_signature ctxt expr))
| (Script_typed_ir.Operation_t, _) ⇒
cast (M? (a × Alpha_context.context))
((Error_monad.error_value (a := (unit × Alpha_context.context)))
(Build_extensible "Asserted" unit tt))
| (Script_typed_ir.Chain_id_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_chain_id ctxt expr))
| (Script_typed_ir.Address_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_address ctxt expr))
| (Script_typed_ir.Tx_rollup_l2_address_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
(traced_no_lwt (parse_tx_rollup_l2_address ctxt expr))
| (Script_typed_ir.Contract_t arg_ty _, expr) ⇒
let '[expr, arg_ty] :=
cast [Alpha_context.Script.node ** Script_typed_ir.ty] [expr, arg_ty] in
cast (M? (a × Alpha_context.context))
(traced
(let? '(address, ctxt) := parse_address ctxt expr in
let loc_value := location expr in
let? '(ctxt, typed_contract) :=
parse_contract_data_aux (stack_depth +i 1) ctxt loc_value arg_ty
address.(Script_typed_ir.address.destination)
address.(Script_typed_ir.address.entrypoint) in
return? (typed_contract, ctxt)))
| (Script_typed_ir.Pair_t tl tr _ _, expr) ⇒
let 'existT _ [__2, __1] [expr, tr, tl] :=
cast_exists (Es := [Set ** Set])
(fun '[__2, __1] ⇒
[Alpha_context.Script.node ** Script_typed_ir.ty **
Script_typed_ir.ty]) [expr, tr, tl] in
cast (M? (a × Alpha_context.context))
(let r_witness := comb_witness1 tr in
let parse_l
(ctxt : Alpha_context.context) (v_value : Alpha_context.Script.node)
: M? (__1 × Alpha_context.context) :=
non_terminal_recursion ctxt tl v_value in
let parse_r
(ctxt : Alpha_context.context) (v_value : Alpha_context.Script.node)
: M? (__2 × Alpha_context.context) :=
non_terminal_recursion ctxt tr v_value in
traced (parse_pair parse_l parse_r ctxt legacy r_witness expr))
| (Script_typed_ir.Union_t tl tr _ _, expr) ⇒
let 'existT _ [__4, __3] [expr, tr, tl] :=
cast_exists (Es := [Set ** Set])
(fun '[__4, __3] ⇒
[Alpha_context.Script.node ** Script_typed_ir.ty **
Script_typed_ir.ty]) [expr, tr, tl] in
cast (M? (a × Alpha_context.context))
(let parse_l
(ctxt : Alpha_context.context) (v_value : Alpha_context.Script.node)
: M? (__3 × Alpha_context.context) :=
non_terminal_recursion ctxt tl v_value in
let parse_r
(ctxt : Alpha_context.context) (v_value : Alpha_context.Script.node)
: M? (__4 × Alpha_context.context) :=
non_terminal_recursion ctxt tr v_value in
traced (parse_union parse_l parse_r ctxt legacy expr))
|
(Script_typed_ir.Lambda_t ta tr _ty_name,
(Micheline.Seq _loc _) as script_instr) ⇒
let '[script_instr, _loc, _ty_name, tr, ta] :=
cast
[Micheline.node Alpha_context.Script.location Alpha_context.Script.prim
** Alpha_context.Script.location ** Script_typed_ir.ty_metadata **
Script_typed_ir.ty ** Script_typed_ir.ty]
[script_instr, _loc, _ty_name, tr, ta] in
cast (M? (a × Alpha_context.context))
(let? '(kdescr, ctxt) :=
traced
(parse_kdescr elab_conf (stack_depth +i 1) Tc_context.data ctxt ta tr
script_instr) in
return? ((Script_typed_ir.Lam kdescr script_instr), ctxt))
|
(Script_typed_ir.Lambda_t ta tr _ty_name,
Micheline.Prim loc_value Michelson_v1_primitives.D_Lambda_rec
(cons ((Micheline.Seq _loc _) as script_instr) []) []) ⇒
let '[script_instr, _loc, loc_value, _ty_name, tr, ta] :=
cast
[Micheline.node Alpha_context.Script.location Alpha_context.Script.prim
** Alpha_context.Script.location ** Alpha_context.Script.location **
Script_typed_ir.ty_metadata ** Script_typed_ir.ty **
Script_typed_ir.ty] [script_instr, _loc, loc_value, _ty_name, tr, ta]
in
cast (M? (a × Alpha_context.context))
(traced
(let? lambda_rec_ty := Script_typed_ir.lambda_t loc_value ta tr in
parse_lam_rec elab_conf (stack_depth +i 1)
(Tc_context.add_lambda Tc_context.data) ctxt ta tr lambda_rec_ty
script_instr))
| (Script_typed_ir.Lambda_t _ _ _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Seq_kind ], (kind_value expr))))
| (Script_typed_ir.Option_t t_value _ _, expr) ⇒
let 'existT _ __11 [expr, t_value] :=
cast_exists (Es := Set)
(fun __11 ⇒ [Alpha_context.Script.node ** Script_typed_ir.ty])
[expr, t_value] in
cast (M? (a × Alpha_context.context))
(let parse_v
(ctxt : Alpha_context.context) (v_value : Alpha_context.Script.node)
: M? (__11 × Alpha_context.context) :=
non_terminal_recursion ctxt t_value v_value in
traced (parse_option parse_v ctxt legacy expr))
| (Script_typed_ir.List_t t_value _ty_name, Micheline.Seq _loc items) ⇒
let 'existT _ __12 [items, _loc, _ty_name, t_value] :=
cast_exists (Es := Set)
(fun __12 ⇒
[list
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim) ** Alpha_context.Script.location **
Script_typed_ir.ty_metadata ** Script_typed_ir.ty])
[items, _loc, _ty_name, t_value] in
cast (M? (a × Alpha_context.context))
(traced
(List.fold_right_es
(fun (v_value : Alpha_context.Script.node) ⇒
fun (function_parameter : Script_list.t __12 × Alpha_context.context)
⇒
let '(rest, ctxt) := function_parameter in
let? '(v_value, ctxt) := non_terminal_recursion ctxt t_value v_value
in
return? ((Script_list.cons_value v_value rest), ctxt)) items
(Script_list.empty, ctxt)))
| (Script_typed_ir.List_t _ _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Seq_kind ], (kind_value expr))))
| (Script_typed_ir.Ticket_t t_value _ty_name, expr) ⇒
let 'existT _ __14 [expr, _ty_name, t_value] :=
cast_exists (Es := Set)
(fun __14 ⇒
[Alpha_context.Script.node ** Script_typed_ir.ty_metadata **
Script_typed_ir.comparable_ty]) [expr, _ty_name, t_value] in
cast (M? (a × Alpha_context.context))
(if allow_forged then
let? ty_value := opened_ticket_type (location expr) t_value in
let?
'(({|
Script_typed_ir.address.destination := destination;
Script_typed_ir.address.entrypoint := _
|}, (contents, amount)), ctxt) :=
non_terminal_recursion ctxt ty_value expr in
match Ticket_amount.of_n amount with
| Some amount ⇒
match destination with
| Alpha_context.Destination.Contract ticketer ⇒
return?
({| Script_typed_ir.ticket.ticketer := ticketer;
Script_typed_ir.ticket.contents := (contents : __14);
Script_typed_ir.ticket.amount := amount; |}, ctxt)
|
(Alpha_context.Destination.Tx_rollup _ |
Alpha_context.Destination.Sc_rollup _ |
Alpha_context.Destination.Zk_rollup _) ⇒
Error_monad.tzfail
(Build_extensible "Unexpected_ticket_owner"
Alpha_context.Destination.t destination)
end
| None ⇒
traced_fail (Build_extensible "Forbidden_zero_ticket_quantity" unit tt)
end
else
traced_fail
(Build_extensible "Unexpected_forged_value"
Alpha_context.Script.location (location expr)))
|
(Script_typed_ir.Set_t t_value _ty_name,
(Micheline.Seq loc_value vs) as expr) ⇒
let 'existT _ __15 [expr, vs, loc_value, _ty_name, t_value] :=
cast_exists (Es := Set)
(fun __15 ⇒
[Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim **
list
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim) ** Alpha_context.Script.location **
Script_typed_ir.ty_metadata ** Script_typed_ir.comparable_ty])
[expr, vs, loc_value, _ty_name, t_value] in
cast (M? (a × Alpha_context.context))
(let? '(_, set, ctxt) :=
traced
(List.fold_left_es
(fun (function_parameter :
option __15 × Script_typed_ir.set __15 × Alpha_context.context) ⇒
let '(last_value, set, ctxt) := function_parameter in
fun (v_value : Alpha_context.Script.node) ⇒
let? '(v_value, ctxt) :=
non_terminal_recursion ctxt t_value v_value in
let? ctxt :=
match last_value with
| Some value_value ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.compare t_value
value_value v_value) in
let c_value :=
Script_comparable.compare_comparable t_value value_value
v_value in
if 0 ≤i c_value then
if 0 =i c_value then
Error_monad.error_value
(Build_extensible "Duplicate_set_values"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
Error_monad.error_value
(Build_extensible "Unordered_set_values"
(Alpha_context.Script.location ×
Micheline.canonical Alpha_context.Script.prim)
(loc_value, (Micheline.strip_locations expr)))
else
return? ctxt
| None ⇒ return? ctxt
end in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.set_update v_value set)
in
return?
((Some v_value), (Script_set.update v_value true set), ctxt))
(None, (Script_set.empty t_value), ctxt) vs) in
return? (set, ctxt))
| (Script_typed_ir.Set_t _ _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Seq_kind ], (kind_value expr))))
| (Script_typed_ir.Map_t tk tv _ty_name, (Micheline.Seq _ vs) as expr) ⇒
let 'existT _ [__17, __18] [expr, vs, _ty_name, tv, tk] :=
cast_exists (Es := [Set ** Set])
(fun '[__17, __18] ⇒
[Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim **
list
(Micheline.node Alpha_context.Script.location
Alpha_context.Script.prim) ** Script_typed_ir.ty_metadata **
Script_typed_ir.ty ** Script_typed_ir.comparable_ty])
[expr, vs, _ty_name, tv, tk] in
cast (M? (a × Alpha_context.context))
((parse_items :
Alpha_context.context →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
Script_typed_ir.ty → Script_typed_ir.ty →
list
(Micheline.node Alpha_context.Script.location Alpha_context.Script.prim)
→ (__18 → __18) →
M? (Script_typed_ir.map __17 __18 × Alpha_context.context)) ctxt expr tk
tv vs (fun (x_value : __18) ⇒ x_value))
| (Script_typed_ir.Map_t _ _ _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Seq_kind ], (kind_value expr))))
| (Script_typed_ir.Big_map_t tk tv _ty_name, expr) ⇒
let 'existT _ [__21, __22] [expr, _ty_name, tv, tk] :=
cast_exists (Es := [Set ** Set])
(fun '[__21, __22] ⇒
[Alpha_context.Script.node ** Script_typed_ir.ty_metadata **
Script_typed_ir.ty ** Script_typed_ir.comparable_ty])
[expr, _ty_name, tv, tk] in
cast (M? (a × Alpha_context.context))
(let? '(id_opt, diff_value, ctxt) :=
match expr with
| Micheline.Int loc_value id ⇒
((return?
((Some (id, loc_value)),
{|
Script_typed_ir.big_map_overlay.map :=
Script_typed_ir.Big_map_overlay.(Map.S.empty);
Script_typed_ir.big_map_overlay.size := 0; |}, ctxt)) :
M?
(option (Z.t × Alpha_context.Script.location) ×
Script_typed_ir.big_map_overlay __21 __22 × Alpha_context.context))
| Micheline.Seq _ vs ⇒
let? '(diff_value, ctxt) :=
parse_big_map_items ctxt expr tk tv vs
(fun (x_value : __22) ⇒ Some x_value) in
return? (None, diff_value, ctxt)
|
Micheline.Prim loc_value Michelson_v1_primitives.D_Pair
(cons (Micheline.Int loc_id id) (cons (Micheline.Seq _ vs) [])) annot
⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? tv_opt := Script_typed_ir.option_t loc_value tv in
let? '(diff_value, ctxt) :=
parse_big_map_items ctxt expr tk tv_opt vs
(fun (x_value : option __22) ⇒ x_value) in
return? ((Some (id, loc_id)), diff_value, ctxt)
|
Micheline.Prim _ Michelson_v1_primitives.D_Pair
(cons (Micheline.Int _ _) (cons expr [])) _ ⇒
traced_fail
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Seq_kind ], (kind_value expr)))
|
Micheline.Prim _ Michelson_v1_primitives.D_Pair (cons expr (cons _ []))
_ ⇒
traced_fail
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Int_kind ], (kind_value expr)))
| Micheline.Prim loc_value Michelson_v1_primitives.D_Pair l_value _ ⇒
traced_fail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
int)
(loc_value, Michelson_v1_primitives.D_Pair, 2, (List.length l_value)))
| _ ⇒
traced_fail
(unexpected expr
[ Script_tc_errors.Seq_kind; Script_tc_errors.Int_kind ]
Michelson_v1_primitives.Constant_namespace
[ Michelson_v1_primitives.D_Pair ])
end in
let? '(id, ctxt) :=
match id_opt with
| None ⇒ return? (None, ctxt)
| Some (id, loc_value) ⇒
if allow_forged then
let id := Alpha_context.Big_map.Id.parse_z id in
let? function_parameter := Alpha_context.Big_map._exists ctxt id in
match function_parameter with
| (_, None) ⇒
traced_fail
(Build_extensible "Invalid_big_map"
(Alpha_context.Script.location × Alpha_context.Big_map.Id.t)
(loc_value, id))
| (ctxt, Some (btk, btv)) ⇒
let? '(Ex_comparable_ty btk, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1)
(Micheline.root_value btk) in
let? '(Script_typed_ir.Ex_ty btv, ctxt) :=
parse_big_map_value_ty_aux ctxt (stack_depth +i 1) legacy
(Micheline.root_value btv) in
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(let error_details := Script_tc_errors.Informative loc_value in
Gas_monad.Syntax.op_letstar (ty_eq error_details tk btk)
(fun function_parameter ⇒
let 'Eq := function_parameter in
ty_eq error_details tv btv)) in
let? 'Eq := eq_value in
return? ((Some id), ctxt)
end
else
traced_fail
(Build_extensible "Unexpected_forged_value"
Alpha_context.Script.location loc_value)
end in
return?
((Script_typed_ir.Big_map
{| Script_typed_ir.big_map.Big_map.id := id;
Script_typed_ir.big_map.Big_map.diff := diff_value;
Script_typed_ir.big_map.Big_map.key_type := tk;
Script_typed_ir.big_map.Big_map.value_type := tv; |}), ctxt))
| (Script_typed_ir.Never_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context)) (traced_no_lwt (parse_never expr))
| (Script_typed_ir.Bls12_381_g1_t, Micheline.Bytes _ bs) ⇒
let bs := cast bytes bs in
cast (M? (a × Alpha_context.context))
(let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.bls12_381_g1 in
match
Script_typed_ir.Script_bls.G1.(Script_typed_ir.Script_bls.S.of_bytes_opt)
bs with
| Some pt ⇒ return? (pt, ctxt)
| None ⇒ fail_parse_data tt
end)
| (Script_typed_ir.Bls12_381_g1_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
| (Script_typed_ir.Bls12_381_g2_t, Micheline.Bytes _ bs) ⇒
let bs := cast bytes bs in
cast (M? (a × Alpha_context.context))
(let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.bls12_381_g2 in
match
Script_typed_ir.Script_bls.G2.(Script_typed_ir.Script_bls.S.of_bytes_opt)
bs with
| Some pt ⇒ return? (pt, ctxt)
| None ⇒ fail_parse_data tt
end)
| (Script_typed_ir.Bls12_381_g2_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
| (Script_typed_ir.Bls12_381_fr_t, Micheline.Bytes _ bs) ⇒
let bs := cast bytes bs in
cast (M? (a × Alpha_context.context))
(let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.bls12_381_fr in
match Script_typed_ir.Script_bls.Fr.of_bytes_opt bs with
| Some pt ⇒ return? (pt, ctxt)
| None ⇒ fail_parse_data tt
end)
| (Script_typed_ir.Bls12_381_fr_t, Micheline.Int _ v_value) ⇒
let v_value := cast Z.t v_value in
cast (M? (a × Alpha_context.context))
(let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.bls12_381_fr in
return? ((Script_typed_ir.Script_bls.Fr.of_z v_value), ctxt))
| (Script_typed_ir.Bls12_381_fr_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
|
(Script_typed_ir.Sapling_transaction_t memo_size,
Micheline.Bytes _ bytes_value) ⇒
let '[bytes_value, memo_size] :=
cast [bytes ** Alpha_context.Sapling.Memo_size.t] [bytes_value, memo_size]
in
cast (M? (a × Alpha_context.context))
match
Data_encoding.Binary.of_bytes_opt
Alpha_context.Sapling.transaction_encoding bytes_value with
| Some transaction ⇒
match Alpha_context.Sapling.transaction_get_memo_size transaction with
| None ⇒ return? (transaction, ctxt)
| Some transac_memo_size ⇒
let? '_ :=
memo_size_eq (Script_tc_errors.Informative tt) memo_size
transac_memo_size in
return? (transaction, ctxt)
end
| None ⇒ fail_parse_data tt
end
| (Script_typed_ir.Sapling_transaction_t _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
|
(Script_typed_ir.Sapling_transaction_deprecated_t memo_size,
Micheline.Bytes _ bytes_value) ⇒
let '[bytes_value, memo_size] :=
cast [bytes ** Alpha_context.Sapling.Memo_size.t] [bytes_value, memo_size]
in
cast (M? (a × Alpha_context.context))
match
Data_encoding.Binary.of_bytes_opt
Alpha_context.Sapling.Legacy.transaction_encoding bytes_value with
| Some transaction ⇒
match Alpha_context.Sapling.Legacy.transaction_get_memo_size transaction
with
| None ⇒ return? (transaction, ctxt)
| Some transac_memo_size ⇒
let? '_ :=
memo_size_eq (Script_tc_errors.Informative tt) memo_size
transac_memo_size in
return? (transaction, ctxt)
end
| None ⇒ fail_parse_data tt
end
| (Script_typed_ir.Sapling_transaction_deprecated_t _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
| (Script_typed_ir.Sapling_state_t memo_size, Micheline.Int loc_value id) ⇒
let '[id, loc_value, memo_size] :=
cast
[Z.t ** Alpha_context.Script.location **
Alpha_context.Sapling.Memo_size.t] [id, loc_value, memo_size] in
cast (M? (a × Alpha_context.context))
(if allow_forged then
let id := Alpha_context.Sapling.Id.parse_z id in
let? '(state_value, ctxt) := Alpha_context.Sapling.state_from_id ctxt id
in
let? '_ :=
traced_no_lwt
(memo_size_eq (Script_tc_errors.Informative tt) memo_size
state_value.(Alpha_context.Sapling.state.memo_size)) in
return? (state_value, ctxt)
else
traced_fail
(Build_extensible "Unexpected_forged_value"
Alpha_context.Script.location loc_value))
| (Script_typed_ir.Sapling_state_t memo_size, Micheline.Seq _ []) ⇒
let memo_size := cast Alpha_context.Sapling.Memo_size.t memo_size in
cast (M? (a × Alpha_context.context))
((Error_monad._return :
Alpha_context.Sapling.state × Alpha_context.context →
M? (Alpha_context.Sapling.state × Alpha_context.context))
((Alpha_context.Sapling.empty_state None memo_size tt), ctxt))
| (Script_typed_ir.Sapling_state_t _, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr),
[ Script_tc_errors.Int_kind; Script_tc_errors.Seq_kind ],
(kind_value expr))))
| (Script_typed_ir.Chest_key_t, Micheline.Bytes _ bytes_value) ⇒
let bytes_value := cast bytes bytes_value in
cast (M? (a × Alpha_context.context))
(let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.chest_key_value
in
match
Data_encoding.Binary.of_bytes_opt
Script_typed_ir.Script_timelock.chest_key_encoding bytes_value with
| Some chest_key_value ⇒ return? (chest_key_value, ctxt)
| None ⇒ fail_parse_data tt
end)
| (Script_typed_ir.Chest_key_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
| (Script_typed_ir.Chest_t, Micheline.Bytes _ bytes_value) ⇒
let bytes_value := cast bytes bytes_value in
cast (M? (a × Alpha_context.context))
(let? ctxt :=
Alpha_context.Gas.consume ctxt
(Typecheck_costs.chest_value (Bytes.length bytes_value)) in
match
Data_encoding.Binary.of_bytes_opt
Script_typed_ir.Script_timelock.chest_encoding bytes_value with
| Some chest_value ⇒ return? (chest_value, ctxt)
| None ⇒ fail_parse_data tt
end)
| (Script_typed_ir.Chest_t, expr) ⇒
let expr := cast Alpha_context.Script.node expr in
cast (M? (a × Alpha_context.context))
((traced_fail (B := a × Raw_context.t))
(Build_extensible "Invalid_kind"
(Alpha_context.Script.location × list Script_tc_errors.kind ×
Script_tc_errors.kind)
((location expr), [ Script_tc_errors.Bytes_kind ], (kind_value expr))))
end
with parse_view
(elab_conf : elab_conf) (ctxt : Alpha_context.context)
(storage_type : Script_typed_ir.ty)
(function_parameter : Script_typed_ir.view) {struct ctxt}
: M? (typed_view × Alpha_context.context) :=
let '{|
Script_typed_ir.view.input_ty := input_ty;
Script_typed_ir.view.output_ty := output_ty;
Script_typed_ir.view.view_code := view_code
|} := function_parameter in
let legacy := elab_conf.(Script_ir_translator_config.elab_config.legacy) in
let input_ty_loc := location input_ty in
let? '(Script_typed_ir.Ex_ty input_ty, ctxt) :=
Error_monad.record_trace_eval
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
Build_extensible "Ill_formed_type"
(option string × Micheline.canonical Alpha_context.Script.prim ×
Alpha_context.Script.location)
((Some "arg of view"), (Micheline.strip_locations input_ty),
input_ty_loc)) (parse_view_input_ty ctxt 0 legacy input_ty) in
let output_ty_loc := location output_ty in
let? '(Script_typed_ir.Ex_ty output_ty, ctxt) :=
Error_monad.record_trace_eval
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
Build_extensible "Ill_formed_type"
(option string × Micheline.canonical Alpha_context.Script.prim ×
Alpha_context.Script.location)
((Some "return of view"), (Micheline.strip_locations output_ty),
output_ty_loc)) (parse_view_output_ty ctxt 0 legacy output_ty) in
let? 'Script_typed_ir.Ty_ex_c pair_ty :=
Script_typed_ir.pair_t input_ty_loc input_ty storage_type in
let? '(judgement_value, ctxt) :=
parse_instr_aux elab_conf 0 Tc_context.view ctxt view_code
(Script_typed_ir.Item_t pair_ty Script_typed_ir.Bot_t) in
match judgement_value with
| Failed {| judgement.Failed.descr := descr_value |} ⇒
let '{| Script_typed_ir.kdescr.kinstr := kinstr |} :=
close_descr
(descr_value (Script_typed_ir.Item_t output_ty Script_typed_ir.Bot_t))
in
return?
((Typed_view
{| typed_view.Typed_view.input_ty := input_ty;
typed_view.Typed_view.output_ty := output_ty;
typed_view.Typed_view.kinstr := kinstr;
typed_view.Typed_view.original_code_expr := view_code; |}), ctxt)
| Typed ({| descr.loc := loc_value; descr.aft := aft |} as descr_value) ⇒
let ill_type_view
(stack_ty : Script_typed_ir.stack_ty)
(loc_value : Alpha_context.Script.location) : Error_monad._error :=
let actual := Script_ir_unparser.serialize_stack_for_error ctxt stack_ty
in
let expected_stack :=
Script_typed_ir.Item_t output_ty Script_typed_ir.Bot_t in
let expected :=
Script_ir_unparser.serialize_stack_for_error ctxt expected_stack in
Build_extensible "Ill_typed_view" Script_tc_errors.Ill_typed_view
{| Script_tc_errors.Ill_typed_view.loc := loc_value;
Script_tc_errors.Ill_typed_view.actual := actual;
Script_tc_errors.Ill_typed_view.expected := expected; |} in
match aft with
| Script_typed_ir.Item_t ty_value Script_typed_ir.Bot_t ⇒
let error_details := Script_tc_errors.Informative loc_value in
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(Gas_monad.record_trace_eval error_details
(fun (loc_value : Alpha_context.Script.location) ⇒
ill_type_view aft loc_value)
(ty_eq error_details ty_value output_ty)) in
let? 'Eq := eq_value in
let '{| Script_typed_ir.kdescr.kinstr := kinstr |} :=
close_descr descr_value in
return?
((Typed_view
{| typed_view.Typed_view.input_ty := input_ty;
typed_view.Typed_view.output_ty := output_ty;
typed_view.Typed_view.kinstr := kinstr;
typed_view.Typed_view.original_code_expr := view_code; |}), ctxt)
| _ ⇒ Error_monad.error_value (ill_type_view aft loc_value)
end
end
with parse_instr_aux
(elab_conf : elab_conf) (stack_depth : int) (tc_context_value : tc_context)
(ctxt : Alpha_context.context) (script_instr : Alpha_context.Script.node)
(stack_ty : Script_typed_ir.stack_ty) {struct ctxt}
: M? (judgement × Alpha_context.context) :=
let parse_views := 'parse_views in
let parse_kdescr := 'parse_kdescr in
let parse_lam_rec := 'parse_lam_rec in
let for_logging_only {A : Set} (x_value : A) : option A :=
if
elab_conf.(Script_ir_translator_config.elab_config.keep_extra_types_for_interpreter_logging)
then
Some x_value
else
None in
let check_item_ty
(ctxt : Alpha_context.context) (exp : Script_typed_ir.ty)
(got : Script_typed_ir.ty) (loc_value : Alpha_context.Script.location)
(name : Alpha_context.Script.prim) (n_value : int) (m_value : int)
: M? (eq × Alpha_context.context) :=
Error_monad.record_trace_eval
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
let stack_ty :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_ty in
Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, name, m_value, stack_ty))
(Error_monad.record_trace (Build_extensible "Bad_stack_item" int n_value)
(let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(ty_eq (Script_tc_errors.Informative loc_value) exp got) in
let? 'Eq := eq_value in
return? (Eq, ctxt))) in
let log_stack
(loc_value : Alpha_context.Script.location)
(stack_ty : Script_typed_ir.stack_ty) (aft : Script_typed_ir.stack_ty)
: unit :=
match
(elab_conf.(Script_ir_translator_config.elab_config.type_logger),
script_instr) with
|
((None, _) |
(Some _, (Micheline.Int _ _ | Micheline.String _ _ | Micheline.Bytes _ _)))
⇒ tt
| (Some log, (Micheline.Prim _ _ _ _ | Micheline.Seq _ _)) ⇒
let stack_ty_before :=
Script_ir_unparser.unparse_stack_uncarbonated stack_ty in
let stack_ty_after := Script_ir_unparser.unparse_stack_uncarbonated aft in
log loc_value stack_ty_before stack_ty_after
end in
let typed_no_lwt {A B : Set}
(ctxt : A) (loc_value : Alpha_context.Script.location) (instr : cinstr)
(aft : Script_typed_ir.stack_ty) : Pervasives.result (judgement × A) B :=
let '_ := log_stack loc_value stack_ty aft in
let j_value :=
Typed
{| descr.loc := loc_value; descr.bef := stack_ty; descr.aft := aft;
descr.instr := instr; |} in
Pervasives.Ok (j_value, ctxt) in
let typed {A B : Set}
(ctxt : A) (loc_value : Alpha_context.Script.location) (instr : cinstr)
(aft : Script_typed_ir.stack_ty) : Pervasives.result (judgement × A) B :=
typed_no_lwt ctxt loc_value instr aft in
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle
in
let non_terminal_recursion
(tc_context_value : tc_context) (ctxt : Alpha_context.context)
(script_instr : Alpha_context.Script.node)
(stack_ty : Script_typed_ir.stack_ty)
: M? (judgement × Alpha_context.context) :=
if stack_depth >i 10000 then
Error_monad.tzfail
(Build_extensible "Typechecking_too_many_recursive_calls" unit tt)
else
parse_instr_aux elab_conf (stack_depth +i 1) tc_context_value ctxt
script_instr stack_ty in
let bad_stack_error {A : Set}
(ctxt : Alpha_context.context) (loc_value : Alpha_context.Script.location)
(prim : Alpha_context.Script.prim) (relevant_stack_portion : int) : M? A :=
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_ty in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, prim, relevant_stack_portion, whole_stack)) in
let legacy := elab_conf.(Script_ir_translator_config.elab_config.legacy) in
match (script_instr, stack_ty) with
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DROP [] annot,
Script_typed_ir.Item_t _ rest) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
typed ctxt loc_value
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDrop loc_value k_value; |} rest
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DROP (cons n_value [])
result_annot, whole_stack) ⇒
let? whole_n := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) in
let fix make_proof_argument (n_value : int) (stk : Script_typed_ir.stack_ty)
: M? dropn_proof_argument :=
match ((n_value =i 0), stk) with
| (true, rest) ⇒
return? (Dropn_proof_argument Script_typed_ir.KRest rest)
| (false, Script_typed_ir.Item_t a_value rest) ⇒
let? 'Dropn_proof_argument n' stack_after_drops :=
make_proof_argument (n_value -i 1) rest in
return?
(Dropn_proof_argument (Script_typed_ir.KPrefix loc_value a_value n')
stack_after_drops)
| (_, _) ⇒
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt whole_stack in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_DROP, whole_n, whole_stack))
end in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value result_annot in
let? 'Dropn_proof_argument n' stack_after_drops :=
make_proof_argument whole_n whole_stack in
let kdropn (k_value : Script_typed_ir.kinstr) : Script_typed_ir.kinstr :=
Script_typed_ir.IDropn loc_value whole_n n' k_value in
typed ctxt loc_value {| cinstr.apply := kdropn; |} stack_after_drops
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DROP
((cons _ (cons _ _)) as l_value) _, _) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.I_DROP, 1, (List.length l_value)))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DUP [] annot,
(Script_typed_ir.Item_t v_value _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? ctxt :=
Error_monad.record_trace_eval
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
let t_value := Script_ir_unparser.serialize_ty_for_error v_value in
Build_extensible "Non_dupable_type"
(Alpha_context.Script.location × Alpha_context.Script.expr)
(loc_value, t_value)) (check_dupable_ty ctxt loc_value v_value) in
let dup :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDup loc_value k_value; |} in
typed ctxt loc_value dup (Script_typed_ir.Item_t v_value stack_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DUP (cons n_value [])
v_annot, (Script_typed_ir.Item_t _ _) as stack_ty) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value v_annot in
let fix make_proof_argument
(n_value : int) (stack_ty : Script_typed_ir.stack_ty)
: M? dup_n_proof_argument :=
match (n_value, stack_ty) with
| (1, Script_typed_ir.Item_t hd_ty _) ⇒
return? (Dup_n_proof_argument Script_typed_ir.Dup_n_zero hd_ty)
|
(n_value,
Script_typed_ir.Item_t _ ((Script_typed_ir.Item_t _ _) as tl_ty)) ⇒
let? 'Dup_n_proof_argument dup_n_witness b_ty :=
make_proof_argument (n_value -i 1) tl_ty in
return?
(Dup_n_proof_argument (Script_typed_ir.Dup_n_succ dup_n_witness) b_ty)
| _ ⇒ bad_stack_error ctxt loc_value Michelson_v1_primitives.I_DUP 1
end in
let? n_value := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
let? '_ :=
Error_monad.error_unless (n_value >i 0)
(Build_extensible "Dup_n_bad_argument" Alpha_context.Script.location
loc_value) in
let? 'Dup_n_proof_argument witness after_ty :=
Error_monad.record_trace
(Build_extensible "Dup_n_bad_stack" Alpha_context.Script.location
loc_value) (make_proof_argument n_value stack_ty) in
let? ctxt :=
Error_monad.record_trace_eval
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
let t_value := Script_ir_unparser.serialize_ty_for_error after_ty in
Build_extensible "Non_dupable_type"
(Alpha_context.Script.location × Alpha_context.Script.expr)
(loc_value, t_value)) (check_dupable_ty ctxt loc_value after_ty) in
let dupn :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDup_n loc_value n_value witness k_value; |} in
typed ctxt loc_value dupn (Script_typed_ir.Item_t after_ty stack_ty)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DIG (cons n_value [])
result_annot, stack_value) ⇒
let fix make_proof_argument (n_value : int) (stk : Script_typed_ir.stack_ty)
: M? dig_proof_argument :=
match ((n_value =i 0), stk) with
| (true, Script_typed_ir.Item_t v_value rest) ⇒
return? (Dig_proof_argument Script_typed_ir.KRest v_value rest)
| (false, Script_typed_ir.Item_t v_value rest) ⇒
let? 'Dig_proof_argument n' x_value aft' :=
make_proof_argument (n_value -i 1) rest in
return?
(Dig_proof_argument (Script_typed_ir.KPrefix loc_value v_value n')
x_value (Script_typed_ir.Item_t v_value aft'))
| (_, _) ⇒
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_DIG, 3, whole_stack))
end in
let? n_value := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value result_annot in
let? 'Dig_proof_argument n' x_value aft :=
make_proof_argument n_value stack_value in
let dig :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDig loc_value n_value n' k_value; |} in
typed ctxt loc_value dig (Script_typed_ir.Item_t x_value aft)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DIG
(([] | cons _ (cons _ _)) as l_value) _, _) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.I_DIG, 1, (List.length l_value)))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DUG (cons n_value [])
result_annot, Script_typed_ir.Item_t x_value whole_stack) ⇒
let? whole_n := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value result_annot in
match make_dug_proof_argument loc_value whole_n x_value whole_stack with
| None ⇒
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt whole_stack in
Error_monad.tzfail
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_DUG, whole_n, whole_stack))
| Some (Dug_proof_argument (n', aft)) ⇒
let dug :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDug loc_value whole_n n' k_value; |} in
typed ctxt loc_value dug aft
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DUG (cons _ [])
result_annot, stack_value) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value result_annot in
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_DUG, 1, stack_value))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DUG
(([] | cons _ (cons _ _)) as l_value) _, _) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.I_DUG, 1, (List.length l_value)))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SWAP [] annot,
Script_typed_ir.Item_t v_value (Script_typed_ir.Item_t w_value rest)) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let swap :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISwap loc_value k_value; |} in
let stack_ty :=
Script_typed_ir.Item_t w_value (Script_typed_ir.Item_t v_value rest) in
typed ctxt loc_value swap stack_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_PUSH
(cons t_value (cons d_value [])) annot, stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_packable_ty_aux ctxt (stack_depth +i 1) legacy t_value in
let 'existT _ __Ex_ty_'a3 [ctxt, t_value] :=
cast_exists (Es := Set)
(fun __Ex_ty_'a3 ⇒ [Alpha_context.context ** Script_typed_ir.ty])
[ctxt, t_value] in
let? '(v_value, ctxt) :=
parse_data_aux elab_conf (stack_depth +i 1) ctxt false t_value d_value in
let const :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IConst loc_value t_value (v_value : __Ex_ty_'a3)
k_value; |} in
typed ctxt loc_value const (Script_typed_ir.Item_t t_value stack_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UNIT [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let const :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IConst loc_value Script_typed_ir.unit_t tt k_value;
|} in
typed ctxt loc_value const
(Script_typed_ir.Item_t Script_typed_ir.unit_t stack_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SOME [] annot,
Script_typed_ir.Item_t t_value rest) ⇒
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let cons_some :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICons_some loc_value k_value; |} in
let? ty_value := Script_typed_ir.option_t loc_value t_value in
typed ctxt loc_value cons_some (Script_typed_ir.Item_t ty_value rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NONE (cons t_value [])
annot, stack_value) ⇒
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy t_value in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let cons_none :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICons_none loc_value t_value k_value; |} in
let? ty_value := Script_typed_ir.option_t loc_value t_value in
let stack_ty := Script_typed_ir.Item_t ty_value stack_value in
typed ctxt loc_value cons_none stack_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MAP (cons body []) annot,
Script_typed_ir.Item_t (Script_typed_ir.Option_t t_value _ _) rest) ⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t t_value rest) in
match judgement_value with
|
Typed
({|
descr.loc := loc_value;
descr.aft := Script_typed_ir.Item_t ret_value aft_rest
|} as kibody) ⇒
let invalid_map_body (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt kibody.(descr.aft)
in
Build_extensible "Invalid_map_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty)
(loc_value, aft) in
Error_monad.record_trace_eval invalid_map_body
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 aft_rest rest in
let? opt_ty := Script_typed_ir.option_t loc_value ret_value in
let final_stack := Script_typed_ir.Item_t opt_ty rest in
let body :=
kibody.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt loc_value)
in
let apply (k_value : Script_typed_ir.kinstr) : Script_typed_ir.kinstr :=
Script_typed_ir.IOpt_map
{| Script_typed_ir.kinstr.IOpt_map.loc := loc_value;
Script_typed_ir.kinstr.IOpt_map.body := body;
Script_typed_ir.kinstr.IOpt_map.k := k_value; |} in
typed_no_lwt ctxt loc_value {| cinstr.apply := apply; |} final_stack)
| Typed {| descr.aft := Script_typed_ir.Bot_t |} ⇒
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt Script_typed_ir.Bot_t
in
Error_monad.error_value
(Build_extensible "Invalid_map_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty)
(loc_value, aft))
| Failed _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_map_block_fail" Alpha_context.Script.location
loc_value)
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_IF_NONE
(cons bt (cons bf [])) annot,
(Script_typed_ir.Item_t (Script_typed_ir.Option_t t_value _ _) rest) as
bef) ⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bt in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bf in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(btr, ctxt) := non_terminal_recursion tc_context_value ctxt bt rest in
let stack_ty := Script_typed_ir.Item_t t_value rest in
let? '(bfr, ctxt) :=
non_terminal_recursion tc_context_value ctxt bf stack_ty in
let branch (ibt : descr) (ibf : descr) : descr :=
let ifnone :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hloc := Script_typed_ir.kinstr_location k_value in
let branch_if_none : Script_typed_ir.kinstr :=
ibt.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc)
in let branch_if_some : Script_typed_ir.kinstr :=
ibf.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc) in
Script_typed_ir.IIf_none
{| Script_typed_ir.kinstr.IIf_none.loc := loc_value;
Script_typed_ir.kinstr.IIf_none.branch_if_none :=
branch_if_none;
Script_typed_ir.kinstr.IIf_none.branch_if_some :=
branch_if_some;
Script_typed_ir.kinstr.IIf_none.k := k_value; |}; |} in
{| descr.loc := loc_value; descr.bef := bef; descr.aft := ibt.(descr.aft);
descr.instr := ifnone; |} in
merge_branches ctxt loc_value btr bfr {| branch.branch := branch; |}
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_PAIR [] annot,
Script_typed_ir.Item_t a_value (Script_typed_ir.Item_t b_value rest)) ⇒
let? '_ := Script_ir_annot.check_constr_annot loc_value annot in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.pair_t loc_value a_value b_value in
let stack_ty := Script_typed_ir.Item_t ty_value rest in
let cons_pair :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICons_pair loc_value k_value; |} in
typed ctxt loc_value cons_pair stack_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_PAIR (cons n_value [])
annot, (Script_typed_ir.Item_t _ _) as stack_ty) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let fix make_proof_argument
(n_value : int) (stack_ty : Script_typed_ir.stack_ty)
: M? comb_proof_argument :=
match (n_value, stack_ty) with
| (1, Script_typed_ir.Item_t _ _) ⇒
return? (Comb_proof_argument Script_typed_ir.Comb_one stack_ty)
|
(n_value,
Script_typed_ir.Item_t a_ty ((Script_typed_ir.Item_t _ _) as tl_ty))
⇒
let? function_parameter := make_proof_argument (n_value -i 1) tl_ty in
match function_parameter with
| Comb_proof_argument comb_witness (Script_typed_ir.Item_t b_ty tl_ty')
⇒
let? 'Script_typed_ir.Ty_ex_c pair_t :=
Script_typed_ir.pair_t loc_value a_ty b_ty in
return?
(Comb_proof_argument (Script_typed_ir.Comb_succ comb_witness)
(Script_typed_ir.Item_t pair_t tl_ty'))
| _ ⇒ unreachable_gadt_branch
end
| _ ⇒ bad_stack_error ctxt loc_value Michelson_v1_primitives.I_PAIR 1
end in
let? n_value := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
let? '_ :=
Error_monad.error_unless (n_value >i 1)
(Build_extensible "Pair_bad_argument" Alpha_context.Script.location
loc_value) in
let? 'Comb_proof_argument witness after_ty :=
make_proof_argument n_value stack_ty in
let comb :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IComb loc_value n_value witness k_value; |} in
typed ctxt loc_value comb after_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UNPAIR (cons n_value [])
annot, (Script_typed_ir.Item_t _ _) as stack_ty) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let fix make_proof_argument
(n_value : int) (stack_ty : Script_typed_ir.stack_ty) {struct n_value}
: M? uncomb_proof_argument :=
match (n_value, stack_ty) with
| (1, (Script_typed_ir.Item_t _ _) as stack_value) ⇒
return? (Uncomb_proof_argument Script_typed_ir.Uncomb_one stack_value)
|
(n_value,
Script_typed_ir.Item_t (Script_typed_ir.Pair_t a_ty b_ty _ _) tl_ty)
⇒
let? 'Uncomb_proof_argument uncomb_witness after_ty :=
make_proof_argument (n_value -i 1) (Script_typed_ir.Item_t b_ty tl_ty)
in
return?
(Uncomb_proof_argument (Script_typed_ir.Uncomb_succ uncomb_witness)
(Script_typed_ir.Item_t a_ty after_ty))
| _ ⇒ bad_stack_error ctxt loc_value Michelson_v1_primitives.I_UNPAIR 1
end in
let? n_value := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
let? '_ :=
Error_monad.error_unless (n_value >i 1)
(Build_extensible "Unpair_bad_argument" Alpha_context.Script.location
loc_value) in
let? 'Uncomb_proof_argument witness after_ty :=
make_proof_argument n_value stack_ty in
let uncomb :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IUncomb loc_value n_value witness k_value; |} in
typed ctxt loc_value uncomb after_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GET (cons n_value [])
annot, Script_typed_ir.Item_t comb_ty rest_ty) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? n_value := parse_uint11 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
match make_comb_get_proof_argument n_value comb_ty with
| None ⇒
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_ty in
Error_monad.tzfail
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_GET, 1, whole_stack))
| Some (Comb_get_proof_argument witness ty') ⇒
let after_stack_ty := Script_typed_ir.Item_t ty' rest_ty in
let comb_get :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IComb_get loc_value n_value witness k_value; |} in
typed ctxt loc_value comb_get after_stack_ty
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UPDATE (cons n_value [])
annot,
Script_typed_ir.Item_t value_ty (Script_typed_ir.Item_t comb_ty rest_ty))
⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? n_value := parse_uint11 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
let? 'Comb_set_proof_argument witness after_ty :=
make_comb_set_proof_argument ctxt stack_ty loc_value n_value value_ty
comb_ty in
let after_stack_ty := Script_typed_ir.Item_t after_ty rest_ty in
let comb_set :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IComb_set loc_value n_value witness k_value; |} in
typed ctxt loc_value comb_set after_stack_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UNPAIR [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Pair_t a_value b_value _ _) rest)
⇒
let? '_ := Script_ir_annot.check_unpair_annot loc_value annot in
let unpair :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IUnpair loc_value k_value; |} in
typed ctxt loc_value unpair
(Script_typed_ir.Item_t a_value (Script_typed_ir.Item_t b_value rest))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CAR [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Pair_t a_value _ _ _) rest) ⇒
let? '_ := Script_ir_annot.check_destr_annot loc_value annot in
let car :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICar loc_value k_value; |} in
typed ctxt loc_value car (Script_typed_ir.Item_t a_value rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CDR [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Pair_t _ b_value _ _) rest) ⇒
let? '_ := Script_ir_annot.check_destr_annot loc_value annot in
let cdr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICdr loc_value k_value; |} in
typed ctxt loc_value cdr (Script_typed_ir.Item_t b_value rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LEFT (cons tr []) annot,
Script_typed_ir.Item_t tl rest) ⇒
let? '(Script_typed_ir.Ex_ty tr, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy tr in
let? '_ := Script_ir_annot.check_constr_annot loc_value annot in
let cons_left :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICons_left loc_value tr k_value; |} in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.union_t loc_value tl tr in
let stack_ty := Script_typed_ir.Item_t ty_value rest in
typed ctxt loc_value cons_left stack_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_RIGHT (cons tl []) annot,
Script_typed_ir.Item_t tr rest) ⇒
let? '(Script_typed_ir.Ex_ty tl, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy tl in
let? '_ := Script_ir_annot.check_constr_annot loc_value annot in
let cons_right :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICons_right loc_value tl k_value; |} in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.union_t loc_value tl tr in
let stack_ty := Script_typed_ir.Item_t ty_value rest in
typed ctxt loc_value cons_right stack_ty
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_IF_LEFT
(cons bt (cons bf [])) annot,
(Script_typed_ir.Item_t (Script_typed_ir.Union_t tl tr _ _) rest) as bef)
⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bt in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bf in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(btr, ctxt) :=
non_terminal_recursion tc_context_value ctxt bt
(Script_typed_ir.Item_t tl rest) in
let? '(bfr, ctxt) :=
non_terminal_recursion tc_context_value ctxt bf
(Script_typed_ir.Item_t tr rest) in
let branch (ibt : descr) (ibf : descr) : descr :=
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hloc := Script_typed_ir.kinstr_location k_value in
let branch_if_left : Script_typed_ir.kinstr :=
ibt.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc)
in let branch_if_right : Script_typed_ir.kinstr :=
ibf.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc) in
Script_typed_ir.IIf_left
{| Script_typed_ir.kinstr.IIf_left.loc := loc_value;
Script_typed_ir.kinstr.IIf_left.branch_if_left :=
branch_if_left;
Script_typed_ir.kinstr.IIf_left.branch_if_right :=
branch_if_right;
Script_typed_ir.kinstr.IIf_left.k := k_value; |}; |} in
{| descr.loc := loc_value; descr.bef := bef; descr.aft := ibt.(descr.aft);
descr.instr := instr; |} in
merge_branches ctxt loc_value btr bfr {| branch.branch := branch; |}
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NIL (cons t_value [])
annot, stack_value) ⇒
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy t_value in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let nil :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INil loc_value t_value k_value; |} in
let? ty_value := Script_typed_ir.list_t loc_value t_value in
typed ctxt loc_value nil (Script_typed_ir.Item_t ty_value stack_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CONS [] annot,
Script_typed_ir.Item_t tv
((Script_typed_ir.Item_t (Script_typed_ir.List_t t_value _) _) as
stack_value)) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt tv t_value loc_value Michelson_v1_primitives.I_CONS 1 2
in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let cons_list :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICons_list loc_value k_value; |} in
typed ctxt loc_value cons_list stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_IF_CONS
(cons bt (cons bf [])) annot,
(Script_typed_ir.Item_t (Script_typed_ir.List_t t_value _) rest) as bef)
⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bt in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bf in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(btr, ctxt) :=
non_terminal_recursion tc_context_value ctxt bt
(Script_typed_ir.Item_t t_value bef) in
let? '(bfr, ctxt) := non_terminal_recursion tc_context_value ctxt bf rest in
let branch (ibt : descr) (ibf : descr) : descr :=
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hloc := Script_typed_ir.kinstr_location k_value in
let branch_if_cons : Script_typed_ir.kinstr :=
ibt.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc)
in let branch_if_nil : Script_typed_ir.kinstr :=
ibf.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc) in
Script_typed_ir.IIf_cons
{| Script_typed_ir.kinstr.IIf_cons.loc := loc_value;
Script_typed_ir.kinstr.IIf_cons.branch_if_cons :=
branch_if_cons;
Script_typed_ir.kinstr.IIf_cons.branch_if_nil :=
branch_if_nil; Script_typed_ir.kinstr.IIf_cons.k := k_value;
|}; |} in
{| descr.loc := loc_value; descr.bef := bef; descr.aft := ibt.(descr.aft);
descr.instr := instr; |} in
merge_branches ctxt loc_value btr bfr {| branch.branch := branch; |}
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SIZE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.List_t _ _) rest) ⇒
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let list_size :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IList_size loc_value k_value; |} in
typed ctxt loc_value list_size
(Script_typed_ir.Item_t Script_typed_ir.nat_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MAP (cons body []) annot,
Script_typed_ir.Item_t (Script_typed_ir.List_t elt_value _) starting_rest)
⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t elt_value starting_rest) in
match judgement_value with
|
Typed
({| descr.aft := (Script_typed_ir.Item_t ret_value rest) as aft |} as
kibody) ⇒
let invalid_map_body (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft := Script_ir_unparser.serialize_stack_for_error ctxt aft in
Build_extensible "Invalid_map_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty)
(loc_value, aft) in
Error_monad.record_trace_eval invalid_map_body
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 rest starting_rest in
let hloc := loc_value in
let ibody :=
kibody.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc) in
let? ty_value := Script_typed_ir.list_t loc_value ret_value in
let list_map :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IList_map loc_value ibody
(for_logging_only ty_value) k_value; |} in
let stack_value := Script_typed_ir.Item_t ty_value rest in
typed_no_lwt ctxt loc_value list_map stack_value)
| Typed {| descr.aft := aft |} ⇒
let aft := Script_ir_unparser.serialize_stack_for_error ctxt aft in
Error_monad.error_value
(Build_extensible "Invalid_map_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty)
(loc_value, aft))
| Failed _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_map_block_fail" Alpha_context.Script.location
loc_value)
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ITER (cons body [])
annot, Script_typed_ir.Item_t (Script_typed_ir.List_t elt_value _) rest)
⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t elt_value rest) in
let mk_list_iter (ibody : descr) : cinstr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hinfo := loc_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hinfo)
in
Script_typed_ir.IList_iter loc_value (for_logging_only elt_value)
ibody k_value; |} in
match judgement_value with
| Typed ({| descr.aft := aft |} as ibody) ⇒
let invalid_iter_body (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt ibody.(descr.aft) in
let rest := Script_ir_unparser.serialize_stack_for_error ctxt rest in
Build_extensible "Invalid_iter_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Script_tc_errors.unparsed_stack_ty) (loc_value, rest, aft) in
Error_monad.record_trace_eval invalid_iter_body
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 aft rest in
typed_no_lwt ctxt loc_value (mk_list_iter ibody) rest)
| Failed {| judgement.Failed.descr := descr_value |} ⇒
typed_no_lwt ctxt loc_value (mk_list_iter (descr_value rest)) rest
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EMPTY_SET
(cons t_value []) annot, rest) ⇒
let? '(Ex_comparable_ty t_value, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) t_value in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEmpty_set loc_value t_value k_value; |} in
let? ty_value := Script_typed_ir.set_t loc_value t_value in
typed ctxt loc_value instr (Script_typed_ir.Item_t ty_value rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ITER (cons body [])
annot, Script_typed_ir.Item_t (Script_typed_ir.Set_t elt_value _) rest) ⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t elt_value rest) in
let mk_iset_iter (ibody : descr) : cinstr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hinfo := loc_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hinfo)
in
Script_typed_ir.ISet_iter loc_value (for_logging_only elt_value)
ibody k_value; |} in
match judgement_value with
| Typed ({| descr.aft := aft |} as ibody) ⇒
let invalid_iter_body (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt ibody.(descr.aft) in
let rest := Script_ir_unparser.serialize_stack_for_error ctxt rest in
Build_extensible "Invalid_iter_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Script_tc_errors.unparsed_stack_ty) (loc_value, rest, aft) in
Error_monad.record_trace_eval invalid_iter_body
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 aft rest in
typed_no_lwt ctxt loc_value (mk_iset_iter ibody) rest)
| Failed {| judgement.Failed.descr := descr_value |} ⇒
typed_no_lwt ctxt loc_value (mk_iset_iter (descr_value rest)) rest
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MEM [] annot,
Script_typed_ir.Item_t v_value
(Script_typed_ir.Item_t (Script_typed_ir.Set_t elt_value _) rest)) ⇒
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let? '(Eq, ctxt) :=
check_item_ty ctxt elt_value v_value loc_value
Michelson_v1_primitives.I_MEM 1 2 in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISet_mem loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.bool_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UPDATE [] annot,
Script_typed_ir.Item_t v_value
(Script_typed_ir.Item_t Script_typed_ir.Bool_t
((Script_typed_ir.Item_t (Script_typed_ir.Set_t elt_value _) _) as
stack_value))) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt elt_value v_value loc_value
Michelson_v1_primitives.I_UPDATE 1 3 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISet_update loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SIZE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Set_t _ _) rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISet_size loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.nat_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EMPTY_MAP
(cons tk (cons tv [])) annot, stack_value) ⇒
let? '(Ex_comparable_ty tk, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) tk in
let? '(Script_typed_ir.Ex_ty tv, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy tv in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEmpty_map loc_value tk (for_logging_only tv)
k_value; |} in
let? ty_value := Script_typed_ir.map_t loc_value tk tv in
typed ctxt loc_value instr (Script_typed_ir.Item_t ty_value stack_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MAP (cons body []) annot,
Script_typed_ir.Item_t (Script_typed_ir.Map_t kt elt_value _)
starting_rest) ⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.pair_t loc_value kt elt_value in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t ty_value starting_rest) in
match judgement_value with
|
Typed
({| descr.aft := (Script_typed_ir.Item_t ret_value rest) as aft |} as
ibody) ⇒
let invalid_map_body (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft := Script_ir_unparser.serialize_stack_for_error ctxt aft in
Build_extensible "Invalid_map_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty)
(loc_value, aft) in
Error_monad.record_trace_eval invalid_map_body
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 rest starting_rest in
let? ty_value := Script_typed_ir.map_t loc_value kt ret_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hinfo := loc_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt hinfo) in
Script_typed_ir.IMap_map loc_value (for_logging_only ty_value)
ibody k_value; |} in
let stack_value := Script_typed_ir.Item_t ty_value rest in
typed_no_lwt ctxt loc_value instr stack_value)
| Typed {| descr.aft := aft |} ⇒
let aft := Script_ir_unparser.serialize_stack_for_error ctxt aft in
Error_monad.error_value
(Build_extensible "Invalid_map_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty)
(loc_value, aft))
| Failed _ ⇒
Error_monad.error_value
(Build_extensible "Invalid_map_block_fail" Alpha_context.Script.location
loc_value)
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ITER (cons body [])
annot,
Script_typed_ir.Item_t (Script_typed_ir.Map_t key_value element_ty _) rest)
⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? 'Script_typed_ir.Ty_ex_c ty_value :=
Script_typed_ir.pair_t loc_value key_value element_ty in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t ty_value rest) in
let make_instr (ibody : descr) : cinstr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hinfo := loc_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hinfo)
in
Script_typed_ir.IMap_iter loc_value (for_logging_only ty_value)
ibody k_value; |} in
match judgement_value with
| Typed ({| descr.aft := aft |} as ibody) ⇒
let invalid_iter_body (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt ibody.(descr.aft) in
let rest := Script_ir_unparser.serialize_stack_for_error ctxt rest in
Build_extensible "Invalid_iter_body"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Script_tc_errors.unparsed_stack_ty) (loc_value, rest, aft) in
Error_monad.record_trace_eval invalid_iter_body
(let? '(Eq, ctxt) := stack_eq loc_value ctxt 1 aft rest in
typed_no_lwt ctxt loc_value (make_instr ibody) rest)
| Failed {| judgement.Failed.descr := descr_value |} ⇒
typed_no_lwt ctxt loc_value (make_instr (descr_value rest)) rest
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MEM [] annot,
Script_typed_ir.Item_t vk
(Script_typed_ir.Item_t (Script_typed_ir.Map_t k_value _ _) rest)) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt vk k_value loc_value Michelson_v1_primitives.I_MEM 1 2
in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMap_mem loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.bool_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GET [] annot,
Script_typed_ir.Item_t vk
(Script_typed_ir.Item_t (Script_typed_ir.Map_t k_value elt_value _) rest))
⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt vk k_value loc_value Michelson_v1_primitives.I_GET 1 2
in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMap_get loc_value k_value; |} in
let? ty_value := Script_typed_ir.option_t loc_value elt_value in
typed ctxt loc_value instr (Script_typed_ir.Item_t ty_value rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UPDATE [] annot,
Script_typed_ir.Item_t vk
(Script_typed_ir.Item_t (Script_typed_ir.Option_t vv _ _)
((Script_typed_ir.Item_t (Script_typed_ir.Map_t k_value v_value _) _)
as stack_value))) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt vk k_value loc_value Michelson_v1_primitives.I_UPDATE 1
3 in
let? '(Eq, ctxt) :=
check_item_ty ctxt vv v_value loc_value Michelson_v1_primitives.I_UPDATE 2
3 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMap_update loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GET_AND_UPDATE [] annot,
Script_typed_ir.Item_t vk
((Script_typed_ir.Item_t (Script_typed_ir.Option_t vv _ _)
(Script_typed_ir.Item_t (Script_typed_ir.Map_t k_value v_value _) _))
as stack_value)) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt vk k_value loc_value
Michelson_v1_primitives.I_GET_AND_UPDATE 1 3 in
let? '(Eq, ctxt) :=
check_item_ty ctxt vv v_value loc_value
Michelson_v1_primitives.I_GET_AND_UPDATE 2 3 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMap_get_and_update loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SIZE [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Map_t _ _ _) rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMap_size loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.nat_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EMPTY_BIG_MAP
(cons tk (cons tv [])) annot, stack_value) ⇒
let? '(Ex_comparable_ty tk, ctxt) :=
parse_comparable_ty_aux ctxt (stack_depth +i 1) tk in
let? '(Script_typed_ir.Ex_ty tv, ctxt) :=
parse_big_map_value_ty_aux ctxt (stack_depth +i 1) legacy tv in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEmpty_big_map loc_value tk tv k_value; |} in
let? ty_value := Script_typed_ir.big_map_t loc_value tk tv in
let stack_value := Script_typed_ir.Item_t ty_value stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MEM [] annot,
Script_typed_ir.Item_t set_key
(Script_typed_ir.Item_t (Script_typed_ir.Big_map_t k_value _ _) rest))
⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt set_key k_value loc_value Michelson_v1_primitives.I_MEM
1 2 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBig_map_mem loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GET [] annot,
Script_typed_ir.Item_t vk
(Script_typed_ir.Item_t (Script_typed_ir.Big_map_t k_value elt_value _)
rest)) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt vk k_value loc_value Michelson_v1_primitives.I_GET 1 2
in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBig_map_get loc_value k_value; |} in
let? ty_value := Script_typed_ir.option_t loc_value elt_value in
let stack_value := Script_typed_ir.Item_t ty_value rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UPDATE [] annot,
Script_typed_ir.Item_t set_key
(Script_typed_ir.Item_t (Script_typed_ir.Option_t set_value _ _)
((Script_typed_ir.Item_t
(Script_typed_ir.Big_map_t map_key map_value _) _) as stack_value)))
⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt set_key map_key loc_value
Michelson_v1_primitives.I_UPDATE 1 3 in
let? '(Eq, ctxt) :=
check_item_ty ctxt set_value map_value loc_value
Michelson_v1_primitives.I_UPDATE 2 3 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBig_map_update loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GET_AND_UPDATE [] annot,
Script_typed_ir.Item_t vk
((Script_typed_ir.Item_t (Script_typed_ir.Option_t vv _ _)
(Script_typed_ir.Item_t (Script_typed_ir.Big_map_t k_value v_value _)
_)) as stack_value)) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt vk k_value loc_value
Michelson_v1_primitives.I_GET_AND_UPDATE 1 3 in
let? '(Eq, ctxt) :=
check_item_ty ctxt vv v_value loc_value
Michelson_v1_primitives.I_GET_AND_UPDATE 2 3 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBig_map_get_and_update loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SAPLING_EMPTY_STATE
(cons memo_size []) annot, rest) ⇒
let? memo_size := parse_memo_size memo_size in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISapling_empty_state loc_value memo_size k_value; |}
in
let stack_value :=
Script_typed_ir.Item_t (Script_typed_ir.sapling_state_t memo_size) rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SAPLING_VERIFY_UPDATE []
_,
Script_typed_ir.Item_t
(Script_typed_ir.Sapling_transaction_deprecated_t transaction_memo_size)
(Script_typed_ir.Item_t
((Script_typed_ir.Sapling_state_t state_memo_size) as state_ty) rest))
⇒
if legacy then
let? '_ :=
memo_size_eq (Script_tc_errors.Informative tt) state_memo_size
transaction_memo_size in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISapling_verify_update_deprecated loc_value
k_value; |} in
let? 'Script_typed_ir.Ty_ex_c pair_ty :=
Script_typed_ir.pair_t loc_value Script_typed_ir.int_t state_ty in
let? ty_value := Script_typed_ir.option_t loc_value pair_ty in
let stack_value := Script_typed_ir.Item_t ty_value rest in
typed ctxt loc_value instr stack_value
else
Error_monad.tzfail
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.T_sapling_transaction_deprecated)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SAPLING_VERIFY_UPDATE []
_,
Script_typed_ir.Item_t
(Script_typed_ir.Sapling_transaction_t transaction_memo_size)
(Script_typed_ir.Item_t
((Script_typed_ir.Sapling_state_t state_memo_size) as state_ty) rest))
⇒
let? '_ :=
memo_size_eq (Script_tc_errors.Informative tt) state_memo_size
transaction_memo_size in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISapling_verify_update loc_value k_value; |} in
let? 'Script_typed_ir.Ty_ex_c pair_ty :=
Script_typed_ir.pair_t loc_value Script_typed_ir.int_t state_ty in
let? 'Script_typed_ir.Ty_ex_c pair_ty :=
Script_typed_ir.pair_t loc_value Script_typed_ir.bytes_t pair_ty in
let? ty_value := Script_typed_ir.option_t loc_value pair_ty in
let stack_value := Script_typed_ir.Item_t ty_value rest in
typed ctxt loc_value instr stack_value
| (Micheline.Seq loc_value [], stack_value) ⇒
let instr :=
{| cinstr.apply := fun (k_value : Script_typed_ir.kinstr) ⇒ k_value; |}
in
typed ctxt loc_value instr stack_value
| (Micheline.Seq _ (cons single []), stack_value) ⇒
non_terminal_recursion tc_context_value ctxt single stack_value
| (Micheline.Seq loc_value (cons hd tl), stack_value) ⇒
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt hd stack_value in
match judgement_value with
| Failed _ ⇒
Error_monad.tzfail
(Build_extensible "Fail_not_in_tail_position"
Alpha_context.Script.location (Micheline.location hd))
| Typed ({| descr.aft := middle |} as ihd) ⇒
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt
(Micheline.Seq Micheline.dummy_location tl) middle in
let judgement_value :=
match judgement_value with
| Failed {| judgement.Failed.descr := descr_value |} ⇒
let descr_value (ret_value : Script_typed_ir.stack_ty) : descr :=
compose_descr loc_value ihd (descr_value ret_value) in
Failed {| judgement.Failed.descr := descr_value; |}
| Typed itl ⇒ Typed (compose_descr loc_value ihd itl)
end in
return? (judgement_value, ctxt)
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_IF
(cons bt (cons bf [])) annot,
(Script_typed_ir.Item_t Script_typed_ir.Bool_t rest) as bef) ⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bt in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] bf in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(btr, ctxt) := non_terminal_recursion tc_context_value ctxt bt rest in
let? '(bfr, ctxt) := non_terminal_recursion tc_context_value ctxt bf rest in
let branch (ibt : descr) (ibf : descr) : descr :=
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let hloc := Script_typed_ir.kinstr_location k_value in
let branch_if_true : Script_typed_ir.kinstr :=
ibt.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc)
in let branch_if_false : Script_typed_ir.kinstr :=
ibf.(descr.instr).(cinstr.apply) (Script_typed_ir.IHalt hloc) in
Script_typed_ir.IIf
{| Script_typed_ir.kinstr.IIf.loc := loc_value;
Script_typed_ir.kinstr.IIf.branch_if_true := branch_if_true;
Script_typed_ir.kinstr.IIf.branch_if_false := branch_if_false;
Script_typed_ir.kinstr.IIf.k := k_value; |}; |} in
{| descr.loc := loc_value; descr.bef := bef; descr.aft := ibt.(descr.aft);
descr.instr := instr; |} in
merge_branches ctxt loc_value btr bfr {| branch.branch := branch; |}
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LOOP (cons body [])
annot, (Script_typed_ir.Item_t Script_typed_ir.Bool_t rest) as stack_value)
⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body rest in
match judgement_value with
| Typed ibody ⇒
let unmatched_branches (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt ibody.(descr.aft) in
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Build_extensible "Unmatched_branches"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Script_tc_errors.unparsed_stack_ty) (loc_value, aft, stack_value) in
Error_monad.record_trace_eval unmatched_branches
(let? '(Eq, ctxt) :=
stack_eq loc_value ctxt 1 ibody.(descr.aft) stack_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let loc_value := Script_typed_ir.kinstr_location k_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt loc_value) in
Script_typed_ir.ILoop loc_value ibody k_value; |} in
typed_no_lwt ctxt loc_value instr rest)
| Failed {| judgement.Failed.descr := descr_value |} ⇒
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let loc_value := Script_typed_ir.kinstr_location k_value in
let ibody := descr_value stack_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt loc_value) in
Script_typed_ir.ILoop loc_value ibody k_value; |} in
typed_no_lwt ctxt loc_value instr rest
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LOOP_LEFT (cons body [])
annot,
(Script_typed_ir.Item_t (Script_typed_ir.Union_t tl tr _ _) rest) as
stack_value) ⇒
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] body in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt body
(Script_typed_ir.Item_t tl rest) in
match judgement_value with
| Typed ibody ⇒
let unmatched_branches (function_parameter : unit) : Error_monad._error :=
let '_ := function_parameter in
let aft :=
Script_ir_unparser.serialize_stack_for_error ctxt ibody.(descr.aft) in
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Build_extensible "Unmatched_branches"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Script_tc_errors.unparsed_stack_ty) (loc_value, aft, stack_value) in
Error_monad.record_trace_eval unmatched_branches
(let? '(Eq, ctxt) :=
stack_eq loc_value ctxt 1 ibody.(descr.aft) stack_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let loc_value := Script_typed_ir.kinstr_location k_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt loc_value) in
Script_typed_ir.ILoop_left loc_value ibody k_value; |} in
let stack_value := Script_typed_ir.Item_t tr rest in
typed_no_lwt ctxt loc_value instr stack_value)
| Failed {| judgement.Failed.descr := descr_value |} ⇒
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let loc_value := Script_typed_ir.kinstr_location k_value in
let ibody := descr_value stack_value in
let ibody :=
ibody.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt loc_value) in
Script_typed_ir.ILoop_left loc_value ibody k_value; |} in
let stack_value := Script_typed_ir.Item_t tr rest in
typed_no_lwt ctxt loc_value instr stack_value
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LAMBDA
(cons arg (cons ret_value (cons code []))) annot, stack_value) ⇒
let? '(Script_typed_ir.Ex_ty arg, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy arg in
let? '(Script_typed_ir.Ex_ty ret_value, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy ret_value in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] code in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? '(kdescr, ctxt) :=
parse_kdescr elab_conf (stack_depth +i 1)
(Tc_context.add_lambda tc_context_value) ctxt arg ret_value code in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILambda loc_value (Script_typed_ir.Lam kdescr code)
k_value; |} in
let? ty_value := Script_typed_ir.lambda_t loc_value arg ret_value in
let stack_value := Script_typed_ir.Item_t ty_value stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LAMBDA_REC
(cons arg_ty_expr (cons ret_ty_expr (cons lambda_expr []))) annot,
stack_value) ⇒
let? '(Script_typed_ir.Ex_ty arg, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy arg_ty_expr in
let? '(Script_typed_ir.Ex_ty ret_value, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy ret_ty_expr in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] lambda_expr in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? lambda_rec_ty := Script_typed_ir.lambda_t loc_value arg ret_value in
let? '(code, ctxt) :=
parse_lam_rec elab_conf (stack_depth +i 1)
(Tc_context.add_lambda tc_context_value) ctxt arg ret_value
lambda_rec_ty lambda_expr in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILambda loc_value code k_value; |} in
let stack_value := Script_typed_ir.Item_t lambda_rec_ty stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EXEC [] annot,
Script_typed_ir.Item_t arg
(Script_typed_ir.Item_t (Script_typed_ir.Lambda_t param ret_value _)
rest)) ⇒
let? '(Eq, ctxt) :=
check_item_ty ctxt arg param loc_value Michelson_v1_primitives.I_EXEC 1 2
in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let stack_value := Script_typed_ir.Item_t ret_value rest in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IExec loc_value (for_logging_only stack_value)
k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_APPLY [] annot,
Script_typed_ir.Item_t capture
(Script_typed_ir.Item_t
(Script_typed_ir.Lambda_t
(Script_typed_ir.Pair_t capture_ty arg_ty _ _) ret_value _) rest))
⇒
let? '_ := check_packable false loc_value capture_ty in
let? '(Eq, ctxt) :=
check_item_ty ctxt capture capture_ty loc_value
Michelson_v1_primitives.I_APPLY 1 2 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IApply loc_value capture_ty k_value; |} in
let? res_ty := Script_typed_ir.lambda_t loc_value arg_ty ret_value in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DIP (cons code []) annot,
Script_typed_ir.Item_t v_value rest) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '_ := check_kind [ Script_tc_errors.Seq_kind ] code in
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt code rest in
match judgement_value with
| Typed descr_value ⇒
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
let b_value :=
descr_value.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt descr_value.(descr.loc)) in
Script_typed_ir.IDip loc_value b_value (for_logging_only v_value)
k_value; |} in
let stack_value := Script_typed_ir.Item_t v_value descr_value.(descr.aft)
in
typed ctxt loc_value instr stack_value
| Failed _ ⇒
Error_monad.tzfail
(Build_extensible "Fail_not_in_tail_position"
Alpha_context.Script.location loc_value)
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DIP
(cons n_value (cons code [])) result_annot, stack_value) ⇒
let? n_value := parse_uint10 n_value in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Typecheck_costs.proof_argument n_value) in
let fix make_proof_argument (n_value : int) (stk : Script_typed_ir.stack_ty)
: M? dipn_proof_argument :=
match ((n_value =i 0), stk) with
| (true, rest) ⇒
let? '(judgement_value, ctxt) :=
non_terminal_recursion tc_context_value ctxt code rest in
match judgement_value with
| Typed descr_value ⇒
return?
(Dipn_proof_argument Script_typed_ir.KRest ctxt descr_value
descr_value.(descr.aft))
| Failed _ ⇒
Error_monad.error_value
(Build_extensible "Fail_not_in_tail_position"
Alpha_context.Script.location loc_value)
end
| (false, Script_typed_ir.Item_t v_value rest) ⇒
let? 'Dipn_proof_argument n' ctxt descr_value aft' :=
make_proof_argument (n_value -i 1) rest in
let w_value := Script_typed_ir.KPrefix loc_value v_value n' in
return?
(Dipn_proof_argument w_value ctxt descr_value
(Script_typed_ir.Item_t v_value aft'))
| (_, _) ⇒
let whole_stack :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_DIP, 1, whole_stack))
end in
let? '_ := Script_ir_annot.error_unexpected_annot loc_value result_annot in
let? 'Dipn_proof_argument n' ctxt descr_value aft :=
make_proof_argument n_value stack_value in
let b_value :=
descr_value.(descr.instr).(cinstr.apply)
(Script_typed_ir.IHalt descr_value.(descr.loc)) in
let res :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDipn loc_value n_value n' b_value k_value; |} in
typed ctxt loc_value res aft
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_DIP
(([] | cons _ (cons _ (cons _ _))) as l_value) _, _) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.I_DIP, 2, (List.length l_value)))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_FAILWITH [] annot,
Script_typed_ir.Item_t v_value _rest) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let? '_ :=
if legacy then
Result.return_unit
else
check_packable false loc_value v_value in
let instr :=
{|
cinstr.apply :=
fun (_k : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IFailwith loc_value v_value; |} in
return?
(let descr_value (aft : Script_typed_ir.stack_ty) : descr :=
{| descr.loc := loc_value; descr.bef := stack_ty; descr.aft := aft;
descr.instr := instr; |} in
let '_ := log_stack loc_value stack_ty Script_typed_ir.Bot_t in
((Failed {| judgement.Failed.descr := descr_value; |}), ctxt))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEVER [] annot,
Script_typed_ir.Item_t Script_typed_ir.Never_t _rest) ⇒
let? '_ := Script_ir_annot.error_unexpected_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (_k : Script_typed_ir.kinstr) ⇒ Script_typed_ir.INever loc_value;
|} in
return?
(let descr_value (aft : Script_typed_ir.stack_ty) : descr :=
{| descr.loc := loc_value; descr.bef := stack_ty; descr.aft := aft;
descr.instr := instr; |} in
let '_ := log_stack loc_value stack_ty Script_typed_ir.Bot_t in
((Failed {| judgement.Failed.descr := descr_value; |}), ctxt))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Timestamp_t
(Script_typed_ir.Item_t Script_typed_ir.Int_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_timestamp_to_seconds loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.Timestamp_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
((Script_typed_ir.Item_t Script_typed_ir.Timestamp_t _) as stack_value))
⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_seconds_to_timestamp loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Timestamp_t
(Script_typed_ir.Item_t Script_typed_ir.Int_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_timestamp_seconds loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Timestamp_t rest
in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Timestamp_t
(Script_typed_ir.Item_t Script_typed_ir.Timestamp_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IDiff_timestamps loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CONCAT [] annot,
Script_typed_ir.Item_t Script_typed_ir.String_t
((Script_typed_ir.Item_t Script_typed_ir.String_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IConcat_string_pair loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CONCAT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.List_t Script_typed_ir.String_t _)
rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IConcat_string loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.String_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SLICE [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.String_t rest))) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISlice_string loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_string_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SIZE [] annot,
Script_typed_ir.Item_t Script_typed_ir.String_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IString_size loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CONCAT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t
((Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IConcat_bytes_pair loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CONCAT [] annot,
Script_typed_ir.Item_t (Script_typed_ir.List_t Script_typed_ir.Bytes_t _)
rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IConcat_bytes loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SLICE [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest))) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISlice_bytes loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_bytes_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SIZE [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBytes_size loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Mutez_t
((Script_typed_ir.Item_t Script_typed_ir.Mutez_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_tez loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Mutez_t
((Script_typed_ir.Item_t Script_typed_ir.Mutez_t _) as stack_value)) ⇒
if legacy then
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_tez_legacy loc_value k_value; |} in
typed ctxt loc_value instr stack_value
else
Error_monad.tzfail
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.I_SUB)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB_MUTEZ [] annot,
Script_typed_ir.Item_t Script_typed_ir.Mutez_t
(Script_typed_ir.Item_t Script_typed_ir.Mutez_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_tez loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_mutez_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Mutez_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_teznat loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Mutez_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Mutez_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_nattez loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_OR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bool_t
((Script_typed_ir.Item_t Script_typed_ir.Bool_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IOr loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_AND [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bool_t
((Script_typed_ir.Item_t Script_typed_ir.Bool_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAnd loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_XOR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bool_t
((Script_typed_ir.Item_t Script_typed_ir.Bool_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IXor loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NOT [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bool_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INot loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ABS [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAbs_int loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ISNAT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IIs_nat loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.option_nat_t rest
in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_INT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IInt_nat loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEG [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INeg loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEG [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INeg loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
((Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_int loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_int loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_int loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
((Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_int loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_int loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_int loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SUB [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISub_int loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
((Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_int loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_int loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EDIV [] annot,
Script_typed_ir.Item_t Script_typed_ir.Mutez_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEdiv_teznat loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_pair_mutez_mutez_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EDIV [] annot,
Script_typed_ir.Item_t Script_typed_ir.Mutez_t
(Script_typed_ir.Item_t Script_typed_ir.Mutez_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEdiv_tez loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_pair_nat_mutez_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EDIV [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
(Script_typed_ir.Item_t Script_typed_ir.Int_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEdiv_int loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_pair_int_nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EDIV [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEdiv_int loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_pair_int_nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EDIV [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.Int_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEdiv_nat loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_pair_int_nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EDIV [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEdiv_nat loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.option_pair_nat_nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LSL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILsl_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LSL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILsl_bytes loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LSR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILsr_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LSR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILsr_bytes loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_OR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IOr_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_OR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t
((Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IOr_bytes loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_AND [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAnd_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_AND [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAnd_int_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_AND [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t
((Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAnd_bytes loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_XOR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Nat_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IXor_nat loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_XOR [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t
((Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IXor_bytes loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NOT [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Int_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INot_int loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NOT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INot_int loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NOT [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INot_bytes loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_COMPARE [] annot,
Script_typed_ir.Item_t t1 (Script_typed_ir.Item_t t2 rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? '(Eq, ctxt) :=
check_item_ty ctxt t1 t2 loc_value Michelson_v1_primitives.I_COMPARE 1 2
in
let? 'Eq := check_comparable loc_value t1 in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICompare loc_value t1 k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EQ [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEq loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEQ [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INeq loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILt loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IGt loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LE [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILe loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_GE [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IGe loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CAST (cons cast_t [])
annot, (Script_typed_ir.Item_t t_value _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? '(Script_typed_ir.Ex_ty cast_t, ctxt) :=
parse_any_ty_aux ctxt (stack_depth +i 1) legacy cast_t in
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(ty_eq (Script_tc_errors.Informative loc_value) cast_t t_value) in
let? 'Eq := eq_value in
let instr :=
{| cinstr.apply := fun (k_value : Script_typed_ir.kinstr) ⇒ k_value; |}
in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_RENAME [] annot,
(Script_typed_ir.Item_t _ _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{| cinstr.apply := fun (k_value : Script_typed_ir.kinstr) ⇒ k_value; |}
in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_PACK [] annot,
Script_typed_ir.Item_t t_value rest) ⇒
let? '_ := check_packable true loc_value t_value in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IPack loc_value t_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bytes_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_UNPACK
(cons ty_value []) annot,
Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest) ⇒
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_packable_ty_aux ctxt (stack_depth +i 1) legacy ty_value in
let? '_ := Script_ir_annot.check_var_type_annot loc_value annot in
let? res_ty := Script_typed_ir.option_t loc_value t_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IUnpack loc_value t_value k_value; |} in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADDRESS [] annot,
Script_typed_ir.Item_t (Script_typed_ir.Contract_t _ _) rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAddress loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.address_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CONTRACT
(cons ty_value []) annot,
Script_typed_ir.Item_t Script_typed_ir.Address_t rest) ⇒
let? '(Script_typed_ir.Ex_ty t_value, ctxt) :=
parse_passable_ty_aux ctxt (stack_depth +i 1) legacy ty_value in
let? contract_ty := Script_typed_ir.contract_t loc_value t_value in
let? res_ty := Script_typed_ir.option_t loc_value contract_ty in
let? entrypoint :=
Script_ir_annot.parse_entrypoint_annot_strict loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IContract loc_value t_value entrypoint k_value; |}
in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_VIEW
(cons name (cons output_ty [])) annot,
Script_typed_ir.Item_t input_ty
(Script_typed_ir.Item_t Script_typed_ir.Address_t rest)) ⇒
let output_ty_loc := location output_ty in
let? '(name, ctxt) := parse_view_name ctxt name in
let? '(Script_typed_ir.Ex_ty output_ty, ctxt) :=
parse_view_output_ty ctxt 0 legacy output_ty in
let? res_ty := Script_typed_ir.option_t output_ty_loc output_ty in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IView loc_value
(Script_typed_ir.View_signature
{| Script_typed_ir.view_signature.View_signature.name := name;
Script_typed_ir.view_signature.View_signature.input_ty :=
input_ty;
Script_typed_ir.view_signature.View_signature.output_ty :=
output_ty; |}) (for_logging_only rest) k_value; |} in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value
(Michelson_v1_primitives.I_TRANSFER_TOKENS as prim) [] annot,
Script_typed_ir.Item_t p_value
(Script_typed_ir.Item_t Script_typed_ir.Mutez_t
(Script_typed_ir.Item_t (Script_typed_ir.Contract_t cp _) rest))) ⇒
let? '_ :=
Tc_context.check_not_in_view loc_value legacy tc_context_value prim in
let? '(Eq, ctxt) := check_item_ty ctxt p_value cp loc_value prim 1 4 in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ITransfer_tokens loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.operation_t rest
in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value (Michelson_v1_primitives.I_SET_DELEGATE as prim)
[] annot,
Script_typed_ir.Item_t
(Script_typed_ir.Option_t Script_typed_ir.Key_hash_t _ _) rest) ⇒
let? '_ :=
Tc_context.check_not_in_view loc_value legacy tc_context_value prim in
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISet_delegate loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.operation_t rest
in
typed ctxt loc_value instr stack_value
| (Micheline.Prim _ Michelson_v1_primitives.I_CREATE_ACCOUNT _ _, _) ⇒
Error_monad.tzfail
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.I_CREATE_ACCOUNT)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_IMPLICIT_ACCOUNT []
annot, Script_typed_ir.Item_t Script_typed_ir.Key_hash_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IImplicit_account loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.contract_unit_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value
(Michelson_v1_primitives.I_CREATE_CONTRACT as prim)
(cons ((Micheline.Seq _ _) as code) []) annot,
Script_typed_ir.Item_t
(Script_typed_ir.Option_t Script_typed_ir.Key_hash_t _ _)
(Script_typed_ir.Item_t Script_typed_ir.Mutez_t
(Script_typed_ir.Item_t ginit rest))) ⇒
let? '_ :=
Tc_context.check_not_in_view loc_value legacy tc_context_value prim in
let? '_ := Script_ir_annot.check_two_var_annot loc_value annot in
let canonical_code := Micheline.strip_locations code in
let?
'({|
toplevel.code_field := code_field;
toplevel.arg_type := arg_type;
toplevel.storage_type := storage_type;
toplevel.views := views
|}, ctxt) := parse_toplevel_aux ctxt legacy canonical_code in
let?
'(Ex_parameter_ty_and_entrypoints {|
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.arg_type :=
arg_type;
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.entrypoints
:= entrypoints
|}, ctxt) :=
Error_monad.record_trace
(Build_extensible "Ill_formed_type"
(option string × Micheline.canonical Alpha_context.Script.prim ×
Alpha_context.Script.location)
((Some "parameter"), canonical_code, (location arg_type)))
(parse_parameter_ty_and_entrypoints_aux ctxt (stack_depth +i 1) legacy
arg_type) in
let? '(Script_typed_ir.Ex_ty storage_type, ctxt) :=
Error_monad.record_trace
(Build_extensible "Ill_formed_type"
(option string × Micheline.canonical Alpha_context.Script.prim ×
Alpha_context.Script.location)
((Some "storage"), canonical_code, (location storage_type)))
(parse_storage_ty ctxt (stack_depth +i 1) legacy storage_type) in
let? 'Script_typed_ir.Ty_ex_c arg_type_full :=
Script_typed_ir.pair_t loc_value arg_type storage_type in
let? 'Script_typed_ir.Ty_ex_c ret_type_full :=
Script_typed_ir.pair_t loc_value Script_typed_ir.list_operation_t
storage_type in
let? function_parameter :=
Error_monad.trace_value
(Build_extensible "Ill_typed_contract"
(Micheline.canonical Alpha_context.Script.prim ×
Script_tc_errors.type_map) (canonical_code, nil))
(parse_kdescr elab_conf (stack_depth +i 1)
(Tc_context.toplevel_value storage_type arg_type entrypoints) ctxt
arg_type_full ret_type_full code_field) in
match function_parameter with
|
({|
Script_typed_ir.kdescr.kbef :=
Script_typed_ir.Item_t arg Script_typed_ir.Bot_t;
Script_typed_ir.kdescr.kaft :=
Script_typed_ir.Item_t ret_value Script_typed_ir.Bot_t
|}, ctxt) ⇒
let views_result := parse_views elab_conf ctxt storage_type views in
let? '(_typed_views, ctxt) :=
Error_monad.trace_value
(Build_extensible "Ill_typed_contract"
(Micheline.canonical Alpha_context.Script.prim ×
Script_tc_errors.type_map) (canonical_code, nil)) views_result in
let? '(storage_eq, ctxt) :=
let error_details := Script_tc_errors.Informative loc_value in
Gas_monad.run ctxt
(Gas_monad.Syntax.op_letstar (ty_eq error_details arg arg_type_full)
(fun function_parameter ⇒
let 'Eq := function_parameter in
Gas_monad.Syntax.op_letstar
(ty_eq error_details ret_value ret_type_full)
(fun function_parameter ⇒
let 'Eq := function_parameter in
ty_eq error_details storage_type ginit))) in
let? 'Eq := storage_eq in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICreate_contract
{| Script_typed_ir.kinstr.ICreate_contract.loc := loc_value;
Script_typed_ir.kinstr.ICreate_contract.storage_type :=
storage_type;
Script_typed_ir.kinstr.ICreate_contract.code :=
canonical_code;
Script_typed_ir.kinstr.ICreate_contract.k := k_value; |}; |}
in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.operation_t
(Script_typed_ir.Item_t Script_typed_ir.address_t rest) in
typed ctxt loc_value instr stack_value
| _ ⇒ unreachable_gadt_branch
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NOW [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INow loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.timestamp_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MIN_BLOCK_TIME [] _,
stack_value) ⇒
typed ctxt loc_value
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMin_block_time loc_value k_value; |}
(Script_typed_ir.Item_t Script_typed_ir.nat_t stack_value)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_AMOUNT [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAmount loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.mutez_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CHAIN_ID [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IChainId loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.chain_id_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_BALANCE [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBalance loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.mutez_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LEVEL [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ILevel loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.nat_t stack_value
in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_VOTING_POWER [] annot,
Script_typed_ir.Item_t Script_typed_ir.Key_hash_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IVoting_power loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.nat_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_TOTAL_VOTING_POWER []
annot, stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ITotal_voting_power loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.nat_t stack_value
in
typed ctxt loc_value instr stack_value
| (Micheline.Prim _ Michelson_v1_primitives.I_STEPS_TO_QUOTA _ _, _) ⇒
Error_monad.tzfail
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.I_STEPS_TO_QUOTA)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SOURCE [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISource loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.address_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SENDER [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISender loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.address_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value (Michelson_v1_primitives.I_SELF as prim) [] annot,
stack_value) ⇒
let? entrypoint :=
Script_ir_annot.parse_entrypoint_annot_lax loc_value annot in
match
(tc_context_value.(Script_tc_context.t.callsite),
(let '_ := tc_context_value.(Script_tc_context.t.callsite) in
Tc_context.is_in_lambda tc_context_value)) with
| (_, true) ⇒
Error_monad.error_value
(Build_extensible "Forbidden_instr_in_context"
(Alpha_context.Script.location × Script_tc_errors.context_desc ×
Alpha_context.Script.prim)
(loc_value, Script_tc_errors.Lambda, prim))
| (Script_tc_context.Data, _) ⇒
Error_monad.error_value
(Build_extensible "Forbidden_instr_in_context"
(Alpha_context.Script.location × Script_tc_errors.context_desc ×
Alpha_context.Script.prim)
(loc_value, Script_tc_errors.Lambda, prim))
| (Script_tc_context.View, _) ⇒
Error_monad.error_value
(Build_extensible "Forbidden_instr_in_context"
(Alpha_context.Script.location × Script_tc_errors.context_desc ×
Alpha_context.Script.prim) (loc_value, Script_tc_errors.View, prim))
|
(Script_tc_context.Toplevel {|
Tc_context.callsite.Toplevel.storage_type := _;
Tc_context.callsite.Toplevel.param_type := param_type;
Tc_context.callsite.Toplevel.entrypoints := entrypoints
|}, _) ⇒
let 'existT _ __Toplevel_'param [entrypoints, param_type] :=
cast_exists (Es := Set)
(fun __Toplevel_'param ⇒
[Script_typed_ir.entrypoints ** Script_typed_ir.ty])
[entrypoints, param_type] in
let? '(r_value, ctxt) :=
Gas_monad.run ctxt
((find_entrypoint (Script_tc_errors.Informative tt) param_type
entrypoints entrypoint) :
Gas_monad.t (ex_ty_cstr __Toplevel_'param)
(Error_monad.trace Error_monad._error)) in
let? 'Ex_ty_cstr {| ex_ty_cstr.Ex_ty_cstr.ty := param_type |} := r_value
in
let? res_ty := Script_typed_ir.contract_t loc_value param_type in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISelf loc_value param_type entrypoint k_value; |}
in
let stack_value := Script_typed_ir.Item_t res_ty stack_value in
typed_no_lwt ctxt loc_value instr stack_value
end
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SELF_ADDRESS [] annot,
stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISelf_address loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.address_t stack_value in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_HASH_KEY [] annot,
Script_typed_ir.Item_t Script_typed_ir.Key_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IHash_key loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.key_hash_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CHECK_SIGNATURE [] annot,
Script_typed_ir.Item_t Script_typed_ir.Key_t
(Script_typed_ir.Item_t Script_typed_ir.Signature_t
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t rest))) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ICheck_signature loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_BLAKE2B [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IBlake2b loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SHA256 [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISha256 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SHA512 [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISha512 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_KECCAK [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IKeccak loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SHA3 [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bytes_t _) as stack_value) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISha3 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g1_t
((Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g1_t _) as
stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_bls12_381_g1 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g2_t
((Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g2_t _) as
stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_bls12_381_g2 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_ADD [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t
((Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t _) as
stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IAdd_bls12_381_fr loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g1_t
(Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_g1 loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g1_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g2_t
(Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_g2 loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g2_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t
((Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t _) as
stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_fr loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Nat_t
((Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t _) as
stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_fr_z loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Int_t
((Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t _) as
stack_value)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_fr_z loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t
(Script_typed_ir.Item_t Script_typed_ir.Int_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_z_fr loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_MUL [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IMul_bls12_381_z_fr loc_value k_value; |} in
let stack_value :=
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_INT [] annot,
Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IInt_bls12_381_fr loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.int_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEG [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g1_t _) as stack_value)
⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INeg_bls12_381_g1 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEG [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bls12_381_g2_t _) as stack_value)
⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INeg_bls12_381_g2 loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_NEG [] annot,
(Script_typed_ir.Item_t Script_typed_ir.Bls12_381_fr_t _) as stack_value)
⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.INeg_bls12_381_fr loc_value k_value; |} in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_PAIRING_CHECK [] annot,
Script_typed_ir.Item_t
(Script_typed_ir.List_t
(Script_typed_ir.Pair_t Script_typed_ir.Bls12_381_g1_t
Script_typed_ir.Bls12_381_g2_t _ _) _) rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IPairing_check_bls12_381 loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t Script_typed_ir.bool_t rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_TICKET [] annot,
Script_typed_ir.Item_t t_value
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? 'Eq := check_comparable loc_value t_value in
let? res_ty := Script_typed_ir.ticket_t loc_value t_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ITicket loc_value (for_logging_only t_value) k_value;
|} in
let? res_ty := Script_typed_ir.option_t loc_value res_ty in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_TICKET_DEPRECATED []
annot,
Script_typed_ir.Item_t t_value
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest)) ⇒
if legacy then
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? 'Eq := check_comparable loc_value t_value in
let? res_ty := Script_typed_ir.ticket_t loc_value t_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ITicket_deprecated loc_value
(for_logging_only t_value) k_value; |} in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
else
Error_monad.tzfail
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.I_TICKET_DEPRECATED)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_READ_TICKET [] annot,
(Script_typed_ir.Item_t (Script_typed_ir.Ticket_t t_value _) _) as
full_stack) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let '_ := check_dupable_comparable_ty t_value in
let? result_value := opened_ticket_type loc_value t_value in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IRead_ticket loc_value (for_logging_only t_value)
k_value; |} in
let stack_value := Script_typed_ir.Item_t result_value full_stack in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_SPLIT_TICKET [] annot,
Script_typed_ir.Item_t ((Script_typed_ir.Ticket_t t_value _) as ticket_t)
(Script_typed_ir.Item_t
(Script_typed_ir.Pair_t Script_typed_ir.Nat_t Script_typed_ir.Nat_t _
_) rest)) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let '_ := check_dupable_comparable_ty t_value in
let? 'Script_typed_ir.Ty_ex_c pair_tickets_ty :=
Script_typed_ir.pair_t loc_value ticket_t ticket_t in
let? res_ty := Script_typed_ir.option_t loc_value pair_tickets_ty in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.ISplit_ticket loc_value k_value; |} in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_JOIN_TICKETS [] annot,
Script_typed_ir.Item_t
(Script_typed_ir.Pair_t
((Script_typed_ir.Ticket_t contents_ty_a _) as ty_a)
(Script_typed_ir.Ticket_t contents_ty_b _) _ _) rest) ⇒
let? '_ := Script_ir_annot.check_var_annot loc_value annot in
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(ty_eq (Script_tc_errors.Informative loc_value) contents_ty_a
contents_ty_b) in
let? 'Eq := eq_value in
let? res_ty := Script_typed_ir.option_t loc_value ty_a in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IJoin_tickets loc_value contents_ty_a k_value; |} in
let stack_value := Script_typed_ir.Item_t res_ty rest in
typed ctxt loc_value instr stack_value
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_OPEN_CHEST [] _,
Script_typed_ir.Item_t Script_typed_ir.Chest_key_t
(Script_typed_ir.Item_t Script_typed_ir.Chest_t
(Script_typed_ir.Item_t Script_typed_ir.Nat_t rest))) ⇒
if legacy then
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IOpen_chest loc_value k_value; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.union_bytes_bool_t rest)
else
Error_monad.tzfail
(Build_extensible "Deprecated_instruction" Alpha_context.Script.prim
Michelson_v1_primitives.I_OPEN_CHEST)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EMIT [] annot,
Script_typed_ir.Item_t data rest) ⇒
let? '_ := check_packable legacy loc_value data in
let? tag := Script_ir_annot.parse_entrypoint_annot_strict loc_value annot in
let? '(unparsed_ty, ctxt) := Script_ir_unparser.unparse_ty tt ctxt data in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Alpha_context.Script.strip_locations_cost unparsed_ty) in
let unparsed_ty := Micheline.strip_locations unparsed_ty in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEmit
{| Script_typed_ir.kinstr.IEmit.loc := loc_value;
Script_typed_ir.kinstr.IEmit.tag := tag;
Script_typed_ir.kinstr.IEmit.ty := data;
Script_typed_ir.kinstr.IEmit.unparsed_ty := unparsed_ty;
Script_typed_ir.kinstr.IEmit.k := k_value; |}; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.Operation_t rest)
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_EMIT (cons ty_node [])
annot, Script_typed_ir.Item_t data rest) ⇒
let? '(Script_typed_ir.Ex_ty ty_value, ctxt) :=
parse_packable_ty_aux ctxt (stack_depth +i 1) legacy ty_node in
let? '(Eq, ctxt) :=
check_item_ty ctxt ty_value data loc_value Michelson_v1_primitives.I_EMIT
1 2 in
let? tag := Script_ir_annot.parse_entrypoint_annot_strict loc_value annot in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Alpha_context.Script.strip_locations_cost ty_node) in
let unparsed_ty := Micheline.strip_locations ty_node in
let instr :=
{|
cinstr.apply :=
fun (k_value : Script_typed_ir.kinstr) ⇒
Script_typed_ir.IEmit
{| Script_typed_ir.kinstr.IEmit.loc := loc_value;
Script_typed_ir.kinstr.IEmit.tag := tag;
Script_typed_ir.kinstr.IEmit.ty := data;
Script_typed_ir.kinstr.IEmit.unparsed_ty := unparsed_ty;
Script_typed_ir.kinstr.IEmit.k := k_value; |}; |} in
typed ctxt loc_value instr
(Script_typed_ir.Item_t Script_typed_ir.Operation_t rest)
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_DUP | Michelson_v1_primitives.I_SWAP |
Michelson_v1_primitives.I_SOME | Michelson_v1_primitives.I_UNIT |
Michelson_v1_primitives.I_PAIR | Michelson_v1_primitives.I_UNPAIR |
Michelson_v1_primitives.I_CAR | Michelson_v1_primitives.I_CDR |
Michelson_v1_primitives.I_CONS | Michelson_v1_primitives.I_CONCAT |
Michelson_v1_primitives.I_SLICE | Michelson_v1_primitives.I_MEM |
Michelson_v1_primitives.I_UPDATE | Michelson_v1_primitives.I_GET |
Michelson_v1_primitives.I_EXEC | Michelson_v1_primitives.I_FAILWITH |
Michelson_v1_primitives.I_SIZE | Michelson_v1_primitives.I_ADD |
Michelson_v1_primitives.I_SUB | Michelson_v1_primitives.I_SUB_MUTEZ |
Michelson_v1_primitives.I_MUL | Michelson_v1_primitives.I_EDIV |
Michelson_v1_primitives.I_OR | Michelson_v1_primitives.I_AND |
Michelson_v1_primitives.I_XOR | Michelson_v1_primitives.I_NOT |
Michelson_v1_primitives.I_ABS | Michelson_v1_primitives.I_NEG |
Michelson_v1_primitives.I_LSL | Michelson_v1_primitives.I_LSR |
Michelson_v1_primitives.I_COMPARE | Michelson_v1_primitives.I_EQ |
Michelson_v1_primitives.I_NEQ | Michelson_v1_primitives.I_LT |
Michelson_v1_primitives.I_GT | Michelson_v1_primitives.I_LE |
Michelson_v1_primitives.I_GE | Michelson_v1_primitives.I_TRANSFER_TOKENS |
Michelson_v1_primitives.I_SET_DELEGATE | Michelson_v1_primitives.I_NOW |
Michelson_v1_primitives.I_MIN_BLOCK_TIME |
Michelson_v1_primitives.I_IMPLICIT_ACCOUNT |
Michelson_v1_primitives.I_AMOUNT | Michelson_v1_primitives.I_BALANCE |
Michelson_v1_primitives.I_LEVEL |
Michelson_v1_primitives.I_CHECK_SIGNATURE |
Michelson_v1_primitives.I_HASH_KEY | Michelson_v1_primitives.I_SOURCE |
Michelson_v1_primitives.I_SENDER | Michelson_v1_primitives.I_BLAKE2B |
Michelson_v1_primitives.I_SHA256 | Michelson_v1_primitives.I_SHA512 |
Michelson_v1_primitives.I_ADDRESS | Michelson_v1_primitives.I_RENAME |
Michelson_v1_primitives.I_PACK | Michelson_v1_primitives.I_ISNAT |
Michelson_v1_primitives.I_INT | Michelson_v1_primitives.I_SELF |
Michelson_v1_primitives.I_CHAIN_ID | Michelson_v1_primitives.I_NEVER |
Michelson_v1_primitives.I_VOTING_POWER |
Michelson_v1_primitives.I_TOTAL_VOTING_POWER |
Michelson_v1_primitives.I_KECCAK | Michelson_v1_primitives.I_SHA3 |
Michelson_v1_primitives.I_PAIRING_CHECK | Michelson_v1_primitives.I_TICKET
| Michelson_v1_primitives.I_READ_TICKET |
Michelson_v1_primitives.I_SPLIT_TICKET |
Michelson_v1_primitives.I_JOIN_TICKETS |
Michelson_v1_primitives.I_OPEN_CHEST) as name) ((cons _ _) as l_value) _,
_) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, name, 0, (List.length l_value)))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_NONE | Michelson_v1_primitives.I_LEFT |
Michelson_v1_primitives.I_RIGHT | Michelson_v1_primitives.I_NIL |
Michelson_v1_primitives.I_MAP | Michelson_v1_primitives.I_ITER |
Michelson_v1_primitives.I_EMPTY_SET | Michelson_v1_primitives.I_LOOP |
Michelson_v1_primitives.I_LOOP_LEFT | Michelson_v1_primitives.I_CONTRACT |
Michelson_v1_primitives.I_CAST | Michelson_v1_primitives.I_UNPACK |
Michelson_v1_primitives.I_CREATE_CONTRACT | Michelson_v1_primitives.I_EMIT)
as name) (([] | cons _ (cons _ _)) as l_value) _, _) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, name, 1, (List.length l_value)))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_PUSH | Michelson_v1_primitives.I_VIEW |
Michelson_v1_primitives.I_IF_NONE | Michelson_v1_primitives.I_IF_LEFT |
Michelson_v1_primitives.I_IF_CONS | Michelson_v1_primitives.I_EMPTY_MAP |
Michelson_v1_primitives.I_EMPTY_BIG_MAP | Michelson_v1_primitives.I_IF) as
name) (([] | cons _ [] | cons _ (cons _ (cons _ _))) as l_value) _, _)
⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, name, 2, (List.length l_value)))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_LAMBDA
(([] | cons _ [] | cons _ (cons _ []) |
cons _ (cons _ (cons _ (cons _ _)))) as l_value) _, _) ⇒
Error_monad.tzfail
(Build_extensible "Invalid_arity"
(Alpha_context.Script.location × Alpha_context.Script.prim × int × int)
(loc_value, Michelson_v1_primitives.I_LAMBDA, 3, (List.length l_value)))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_ADD | Michelson_v1_primitives.I_SUB |
Michelson_v1_primitives.I_SUB_MUTEZ | Michelson_v1_primitives.I_MUL |
Michelson_v1_primitives.I_EDIV | Michelson_v1_primitives.I_AND |
Michelson_v1_primitives.I_OR | Michelson_v1_primitives.I_XOR |
Michelson_v1_primitives.I_LSL | Michelson_v1_primitives.I_LSR |
Michelson_v1_primitives.I_CONCAT | Michelson_v1_primitives.I_PAIRING_CHECK)
as name) [] _, Script_typed_ir.Item_t ta (Script_typed_ir.Item_t tb _))
⇒
let ta := Script_ir_unparser.serialize_ty_for_error ta in
let tb := Script_ir_unparser.serialize_ty_for_error tb in
Error_monad.tzfail
(Build_extensible "Undefined_binop"
(Alpha_context.Script.location × Alpha_context.Script.prim ×
Alpha_context.Script.expr × Alpha_context.Script.expr)
(loc_value, name, ta, tb))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_NEG | Michelson_v1_primitives.I_ABS |
Michelson_v1_primitives.I_NOT | Michelson_v1_primitives.I_SIZE |
Michelson_v1_primitives.I_EQ | Michelson_v1_primitives.I_NEQ |
Michelson_v1_primitives.I_LT | Michelson_v1_primitives.I_GT |
Michelson_v1_primitives.I_LE | Michelson_v1_primitives.I_GE |
Michelson_v1_primitives.I_CONCAT) as name) [] _,
Script_typed_ir.Item_t t_value _) ⇒
let t_value := Script_ir_unparser.serialize_ty_for_error t_value in
Error_monad.tzfail
(Build_extensible "Undefined_unop"
(Alpha_context.Script.location × Alpha_context.Script.prim ×
Alpha_context.Script.expr) (loc_value, name, t_value))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_UPDATE | Michelson_v1_primitives.I_SLICE |
Michelson_v1_primitives.I_OPEN_CHEST) as name) [] _, stack_value) ⇒
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty) (loc_value, name, 3, stack_value))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_CREATE_CONTRACT _ _,
stack_value) ⇒
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.tzfail
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_CREATE_CONTRACT, 7, stack_value))
|
(Micheline.Prim loc_value Michelson_v1_primitives.I_TRANSFER_TOKENS [] _,
stack_value) ⇒
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty)
(loc_value, Michelson_v1_primitives.I_TRANSFER_TOKENS, 4, stack_value))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_DROP | Michelson_v1_primitives.I_DUP |
Michelson_v1_primitives.I_CAR | Michelson_v1_primitives.I_CDR |
Michelson_v1_primitives.I_UNPAIR | Michelson_v1_primitives.I_SOME |
Michelson_v1_primitives.I_BLAKE2B | Michelson_v1_primitives.I_SHA256 |
Michelson_v1_primitives.I_SHA512 | Michelson_v1_primitives.I_DIP |
Michelson_v1_primitives.I_IF_NONE | Michelson_v1_primitives.I_LEFT |
Michelson_v1_primitives.I_RIGHT | Michelson_v1_primitives.I_IF_LEFT |
Michelson_v1_primitives.I_IF | Michelson_v1_primitives.I_LOOP |
Michelson_v1_primitives.I_IF_CONS |
Michelson_v1_primitives.I_IMPLICIT_ACCOUNT | Michelson_v1_primitives.I_NEG
| Michelson_v1_primitives.I_ABS | Michelson_v1_primitives.I_INT |
Michelson_v1_primitives.I_NOT | Michelson_v1_primitives.I_HASH_KEY |
Michelson_v1_primitives.I_EQ | Michelson_v1_primitives.I_NEQ |
Michelson_v1_primitives.I_LT | Michelson_v1_primitives.I_GT |
Michelson_v1_primitives.I_LE | Michelson_v1_primitives.I_GE |
Michelson_v1_primitives.I_SIZE | Michelson_v1_primitives.I_FAILWITH |
Michelson_v1_primitives.I_RENAME | Michelson_v1_primitives.I_PACK |
Michelson_v1_primitives.I_ISNAT | Michelson_v1_primitives.I_ADDRESS |
Michelson_v1_primitives.I_SET_DELEGATE | Michelson_v1_primitives.I_CAST |
Michelson_v1_primitives.I_MAP | Michelson_v1_primitives.I_ITER |
Michelson_v1_primitives.I_LOOP_LEFT | Michelson_v1_primitives.I_UNPACK |
Michelson_v1_primitives.I_CONTRACT | Michelson_v1_primitives.I_NEVER |
Michelson_v1_primitives.I_KECCAK | Michelson_v1_primitives.I_SHA3 |
Michelson_v1_primitives.I_READ_TICKET |
Michelson_v1_primitives.I_JOIN_TICKETS) as name) _ _, stack_value) ⇒
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty) (loc_value, name, 1, stack_value))
|
(Micheline.Prim loc_value
((Michelson_v1_primitives.I_SWAP | Michelson_v1_primitives.I_PAIR |
Michelson_v1_primitives.I_CONS | Michelson_v1_primitives.I_GET |
Michelson_v1_primitives.I_MEM | Michelson_v1_primitives.I_EXEC |
Michelson_v1_primitives.I_CHECK_SIGNATURE | Michelson_v1_primitives.I_ADD
| Michelson_v1_primitives.I_SUB | Michelson_v1_primitives.I_SUB_MUTEZ |
Michelson_v1_primitives.I_MUL | Michelson_v1_primitives.I_EDIV |
Michelson_v1_primitives.I_AND | Michelson_v1_primitives.I_OR |
Michelson_v1_primitives.I_XOR | Michelson_v1_primitives.I_LSL |
Michelson_v1_primitives.I_LSR | Michelson_v1_primitives.I_COMPARE |
Michelson_v1_primitives.I_PAIRING_CHECK | Michelson_v1_primitives.I_TICKET
| Michelson_v1_primitives.I_SPLIT_TICKET) as name) _ _, stack_value) ⇒
let stack_value :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_value in
Error_monad.error_value
(Build_extensible "Bad_stack"
(Alpha_context.Script.location × Alpha_context.Script.prim × int ×
Script_tc_errors.unparsed_stack_ty) (loc_value, name, 2, stack_value))
| (expr, _) ⇒
Error_monad.tzfail
(unexpected expr [ Script_tc_errors.Seq_kind ]
Michelson_v1_primitives.Instr_namespace
[
Michelson_v1_primitives.I_ABS;
Michelson_v1_primitives.I_ADD;
Michelson_v1_primitives.I_AMOUNT;
Michelson_v1_primitives.I_AND;
Michelson_v1_primitives.I_BALANCE;
Michelson_v1_primitives.I_BLAKE2B;
Michelson_v1_primitives.I_CAR;
Michelson_v1_primitives.I_CDR;
Michelson_v1_primitives.I_CHECK_SIGNATURE;
Michelson_v1_primitives.I_COMPARE;
Michelson_v1_primitives.I_CONCAT;
Michelson_v1_primitives.I_CONS;
Michelson_v1_primitives.I_CREATE_CONTRACT;
Michelson_v1_primitives.I_DIG;
Michelson_v1_primitives.I_DIP;
Michelson_v1_primitives.I_DROP;
Michelson_v1_primitives.I_DUG;
Michelson_v1_primitives.I_DUP;
Michelson_v1_primitives.I_EDIV;
Michelson_v1_primitives.I_EMPTY_BIG_MAP;
Michelson_v1_primitives.I_EMPTY_MAP;
Michelson_v1_primitives.I_EMPTY_SET;
Michelson_v1_primitives.I_EQ;
Michelson_v1_primitives.I_EXEC;
Michelson_v1_primitives.I_FAILWITH;
Michelson_v1_primitives.I_GE;
Michelson_v1_primitives.I_GET;
Michelson_v1_primitives.I_GET_AND_UPDATE;
Michelson_v1_primitives.I_GT;
Michelson_v1_primitives.I_HASH_KEY;
Michelson_v1_primitives.I_IF;
Michelson_v1_primitives.I_IF_CONS;
Michelson_v1_primitives.I_IF_LEFT;
Michelson_v1_primitives.I_IF_NONE;
Michelson_v1_primitives.I_IMPLICIT_ACCOUNT;
Michelson_v1_primitives.I_INT;
Michelson_v1_primitives.I_ITER;
Michelson_v1_primitives.I_JOIN_TICKETS;
Michelson_v1_primitives.I_KECCAK;
Michelson_v1_primitives.I_LAMBDA;
Michelson_v1_primitives.I_LE;
Michelson_v1_primitives.I_LEFT;
Michelson_v1_primitives.I_LEVEL;
Michelson_v1_primitives.I_LOOP;
Michelson_v1_primitives.I_LSL;
Michelson_v1_primitives.I_LSR;
Michelson_v1_primitives.I_LT;
Michelson_v1_primitives.I_MAP;
Michelson_v1_primitives.I_MEM;
Michelson_v1_primitives.I_MIN_BLOCK_TIME;
Michelson_v1_primitives.I_MUL;
Michelson_v1_primitives.I_NEG;
Michelson_v1_primitives.I_NEQ;
Michelson_v1_primitives.I_NEVER;
Michelson_v1_primitives.I_NIL;
Michelson_v1_primitives.I_NONE;
Michelson_v1_primitives.I_NOT;
Michelson_v1_primitives.I_NOW;
Michelson_v1_primitives.I_OPEN_CHEST;
Michelson_v1_primitives.I_OR;
Michelson_v1_primitives.I_PAIR;
Michelson_v1_primitives.I_PAIRING_CHECK;
Michelson_v1_primitives.I_PUSH;
Michelson_v1_primitives.I_READ_TICKET;
Michelson_v1_primitives.I_RIGHT;
Michelson_v1_primitives.I_SAPLING_EMPTY_STATE;
Michelson_v1_primitives.I_SAPLING_VERIFY_UPDATE;
Michelson_v1_primitives.I_SELF;
Michelson_v1_primitives.I_SELF_ADDRESS;
Michelson_v1_primitives.I_SENDER;
Michelson_v1_primitives.I_SHA256;
Michelson_v1_primitives.I_SHA3;
Michelson_v1_primitives.I_SHA512;
Michelson_v1_primitives.I_SIZE;
Michelson_v1_primitives.I_SOME;
Michelson_v1_primitives.I_SOURCE;
Michelson_v1_primitives.I_SPLIT_TICKET;
Michelson_v1_primitives.I_SUB;
Michelson_v1_primitives.I_SUB_MUTEZ;
Michelson_v1_primitives.I_SWAP;
Michelson_v1_primitives.I_TICKET;
Michelson_v1_primitives.I_TOTAL_VOTING_POWER;
Michelson_v1_primitives.I_TRANSFER_TOKENS;
Michelson_v1_primitives.I_UNIT;
Michelson_v1_primitives.I_UNPAIR;
Michelson_v1_primitives.I_UPDATE;
Michelson_v1_primitives.I_VIEW;
Michelson_v1_primitives.I_VOTING_POWER;
Michelson_v1_primitives.I_XOR
])
end
where "'parse_views" :=
(fun
(elab_conf : elab_conf) (ctxt : Alpha_context.context)
(storage_type : Script_typed_ir.ty) (views : Script_typed_ir.view_map) ⇒
let aux
(ctxt : Alpha_context.context) (name : Script_string.t)
(cur_view : Script_typed_ir.view)
: M? (typed_view × Alpha_context.context) :=
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Interpreter.view_update name views) in
parse_view elab_conf ctxt storage_type cur_view in
Script_map.map_es_in_context aux ctxt views)
and "'parse_kdescr" :=
(fun
(elab_conf : elab_conf) (stack_depth : int) (tc_context_value : tc_context)
(ctxt : Alpha_context.context) (arg : Script_typed_ir.ty)
(ret_value : Script_typed_ir.ty) (script_instr : Alpha_context.Script.node)
⇒
let? function_parameter :=
parse_instr_aux elab_conf (stack_depth +i 1) tc_context_value ctxt
script_instr (Script_typed_ir.Item_t arg Script_typed_ir.Bot_t) in
match function_parameter with
|
(Typed
({|
descr.loc := loc_value;
descr.aft :=
(Script_typed_ir.Item_t ty_value Script_typed_ir.Bot_t) as
stack_ty
|} as descr_value), ctxt) ⇒
let error_details := Script_tc_errors.Informative loc_value in
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(Gas_monad.record_trace_eval error_details
(fun (loc_value : Alpha_context.Script.location) ⇒
let ret_value :=
Script_ir_unparser.serialize_ty_for_error ret_value in
let stack_ty :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_ty in
Build_extensible "Bad_return"
(Alpha_context.Script.location ×
Script_tc_errors.unparsed_stack_ty × Alpha_context.Script.expr)
(loc_value, stack_ty, ret_value))
(ty_eq error_details ty_value ret_value)) in
let? 'Eq := eq_value in
return? ((close_descr descr_value), ctxt)
| (Typed {| descr.loc := loc_value; descr.aft := stack_ty |}, ctxt) ⇒
let ret_value := Script_ir_unparser.serialize_ty_for_error ret_value in
let stack_ty := Script_ir_unparser.serialize_stack_for_error ctxt stack_ty
in
Error_monad.tzfail
(Build_extensible "Bad_return"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Alpha_context.Script.expr) (loc_value, stack_ty, ret_value))
| (Failed {| judgement.Failed.descr := descr_value |}, ctxt) ⇒
return?
((close_descr
(descr_value (Script_typed_ir.Item_t ret_value Script_typed_ir.Bot_t))),
ctxt)
end)
and "'parse_lam_rec" :=
(fun
(elab_conf : elab_conf) (stack_depth : int) (tc_context_value : tc_context)
(ctxt : Alpha_context.context) (arg : Script_typed_ir.ty)
(ret_value : Script_typed_ir.ty) (lambda_rec_ty : Script_typed_ir.ty)
(script_instr : Alpha_context.Script.node) ⇒
let? function_parameter :=
parse_instr_aux elab_conf (stack_depth +i 1) tc_context_value ctxt
script_instr
(Script_typed_ir.Item_t arg
(Script_typed_ir.Item_t lambda_rec_ty Script_typed_ir.Bot_t)) in
match function_parameter with
|
(Typed
({|
descr.loc := loc_value;
descr.aft :=
(Script_typed_ir.Item_t ty_value Script_typed_ir.Bot_t) as
stack_ty
|} as descr_value), ctxt) ⇒
let error_details := Script_tc_errors.Informative loc_value in
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt
(Gas_monad.record_trace_eval error_details
(fun (loc_value : Alpha_context.Script.location) ⇒
let ret_value :=
Script_ir_unparser.serialize_ty_for_error ret_value in
let stack_ty :=
Script_ir_unparser.serialize_stack_for_error ctxt stack_ty in
Build_extensible "Bad_return"
(Alpha_context.Script.location ×
Script_tc_errors.unparsed_stack_ty × Alpha_context.Script.expr)
(loc_value, stack_ty, ret_value))
(ty_eq error_details ty_value ret_value)) in
let? 'Eq := eq_value in
return?
((Script_typed_ir.LamRec (close_descr descr_value) script_instr), ctxt)
| (Typed {| descr.loc := loc_value; descr.aft := stack_ty |}, ctxt) ⇒
let ret_value := Script_ir_unparser.serialize_ty_for_error ret_value in
let stack_ty := Script_ir_unparser.serialize_stack_for_error ctxt stack_ty
in
Error_monad.tzfail
(Build_extensible "Bad_return"
(Alpha_context.Script.location × Script_tc_errors.unparsed_stack_ty ×
Alpha_context.Script.expr) (loc_value, stack_ty, ret_value))
| (Failed {| judgement.Failed.descr := descr_value |}, ctxt) ⇒
return?
((Script_typed_ir.LamRec
(close_descr
(descr_value
(Script_typed_ir.Item_t ret_value Script_typed_ir.Bot_t)))
script_instr), ctxt)
end)
and "'parse_contract" :=
(fun (err : Set) ⇒ fun
(stack_depth : int) (ctxt : Alpha_context.context)
(error_details :
Script_tc_errors.error_details Alpha_context.Script.location)
(loc_value : Alpha_context.Script.location) (arg : Script_typed_ir.ty)
(destination : Alpha_context.Destination.t)
(entrypoint : Alpha_context.Entrypoint.t) ⇒
let error_value {B : Set}
(ctxt : Alpha_context.context)
(f_err : Alpha_context.Script.location → Error_monad._error)
: Alpha_context.context × Pervasives.result B err :=
(ctxt,
(Pervasives.Error
match error_details with
| Script_tc_errors.Fast ⇒
cast err Script_tc_errors.Inconsistent_types_fast
| Script_tc_errors.Informative loc_value ⇒
let loc_value := cast Alpha_context.Script.location loc_value in
cast err (Error_monad.trace_of_error (f_err loc_value))
end)) in
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle in
match destination with
| Alpha_context.Destination.Contract contract ⇒
match contract with
| Contract_repr.Implicit pkh ⇒
if Alpha_context.Entrypoint.is_default entrypoint then
let? '(eq_value, ctxt) :=
Gas_monad.run ctxt (ty_eq error_details arg Script_typed_ir.unit_t)
in
return?
(ctxt,
(let? 'Eq := eq_value in
return? (Script_typed_ir.Typed_implicit pkh)))
else
return?
(error_value ctxt
(fun (_loc : Alpha_context.Script.location) ⇒
Build_extensible "No_such_entrypoint" Alpha_context.Entrypoint.t
entrypoint))
| Contract_repr.Originated contract_hash ⇒
Error_monad.trace_value
(Build_extensible "Invalid_contract"
(Alpha_context.Script.location × Alpha_context.Contract.t)
(loc_value, contract))
(let? '(ctxt, code) :=
Alpha_context.Contract.get_script_code ctxt contract_hash in
match code with
| None ⇒
return?
(error_value ctxt
(fun (loc_value : Alpha_context.Script.location) ⇒
Build_extensible "Invalid_contract"
(Alpha_context.Script.location × Alpha_context.Contract.t)
(loc_value, contract)))
| Some code ⇒
let? '(code, ctxt) :=
Alpha_context.Script.force_decode_in_context
Alpha_context.Script.When_needed ctxt code in
let? '({| toplevel.arg_type := arg_type |}, ctxt) :=
parse_toplevel_aux ctxt true code in
let?
'(Ex_parameter_ty_and_entrypoints {|
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.arg_type :=
targ;
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.entrypoints
:= entrypoints
|}, ctxt) :=
parse_parameter_ty_and_entrypoints_aux ctxt (stack_depth +i 1)
true arg_type in
let 'existT _ __Ex_parameter_ty_and_entrypoints_'a1
[ctxt, entrypoints, targ] :=
cast_exists (Es := Set)
(fun __Ex_parameter_ty_and_entrypoints_'a1 ⇒
[Alpha_context.context ** Script_typed_ir.entrypoints **
Script_typed_ir.ty]) [ctxt, entrypoints, targ] in
let? '(entrypoint_arg, ctxt) :=
Gas_monad.run ctxt
((find_entrypoint_for_type
(full := __Ex_parameter_ty_and_entrypoints_'a1)) error_details
targ arg entrypoints entrypoint) in
return?
(ctxt,
(let? '(entrypoint, arg_ty) := entrypoint_arg in
return?
(Script_typed_ir.Typed_originated
{|
Script_typed_ir.typed_contract.Typed_originated.arg_ty :=
arg_ty;
Script_typed_ir.typed_contract.Typed_originated.contract_hash
:= contract_hash;
Script_typed_ir.typed_contract.Typed_originated.entrypoint
:= entrypoint; |})))
end)
end
| Alpha_context.Destination.Tx_rollup tx_rollup ⇒
let? ctxt := Alpha_context.Tx_rollup_state.assert_exist ctxt tx_rollup in
return?
(if Alpha_context.Entrypoint.is_deposit entrypoint then
match arg with
|
Script_typed_ir.Pair_t (Script_typed_ir.Ticket_t _ _)
Script_typed_ir.Tx_rollup_l2_address_t _ _ ⇒
(ctxt,
(return?
(Script_typed_ir.Typed_tx_rollup
{|
Script_typed_ir.typed_contract.Typed_tx_rollup.arg_ty :=
arg;
Script_typed_ir.typed_contract.Typed_tx_rollup.tx_rollup :=
tx_rollup; |})))
| _ ⇒
error_value ctxt
(fun (loc_value : Alpha_context.Script.location) ⇒
Build_extensible "Tx_rollup_bad_deposit_parameter"
(Alpha_context.Script.location × Alpha_context.Script.expr)
(loc_value, (Script_ir_unparser.serialize_ty_for_error arg)))
end
else
error_value ctxt
(fun (_loc : Alpha_context.Script.location) ⇒
Build_extensible "No_such_entrypoint" Alpha_context.Entrypoint.t
entrypoint))
| Alpha_context.Destination.Zk_rollup zk_rollup ⇒
let? ctxt := Alpha_context.Zk_rollup.assert_exist ctxt zk_rollup in
return?
(if Alpha_context.Entrypoint.is_deposit entrypoint then
match arg with
|
Script_typed_ir.Pair_t (Script_typed_ir.Ticket_t _ _)
Script_typed_ir.Bytes_t _ _ ⇒
(ctxt,
(return?
(Script_typed_ir.Typed_zk_rollup
{|
Script_typed_ir.typed_contract.Typed_zk_rollup.arg_ty :=
arg;
Script_typed_ir.typed_contract.Typed_zk_rollup.zk_rollup :=
zk_rollup; |})))
| _ ⇒
error_value ctxt
(fun (loc_value : Alpha_context.Script.location) ⇒
Build_extensible "Zk_rollup_bad_deposit_parameter"
(Alpha_context.Script.location × Alpha_context.Script.expr)
(loc_value, (Script_ir_unparser.serialize_ty_for_error arg)))
end
else
error_value ctxt
(fun (_loc : Alpha_context.Script.location) ⇒
Build_extensible "No_such_entrypoint" Alpha_context.Entrypoint.t
entrypoint))
| Alpha_context.Destination.Sc_rollup sc_rollup ⇒
let? '(parameters_type, ctxt) :=
Alpha_context.Sc_rollup.parameters_type ctxt sc_rollup in
match parameters_type with
| None ⇒
return?
(error_value ctxt
(fun (_loc : Alpha_context.Script.location) ⇒
Build_extensible "Sc_rollup_does_not_exist"
Alpha_context.Sc_rollup.t sc_rollup))
| Some parameters_type ⇒
let? '(parameters_type, ctxt) :=
Alpha_context.Script.force_decode_in_context
Alpha_context.Script.When_needed ctxt parameters_type in
let?
'(Ex_parameter_ty_and_entrypoints {|
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.arg_type :=
full_value;
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.entrypoints
:= entrypoints
|}, ctxt) :=
parse_parameter_ty_and_entrypoints_aux ctxt (stack_depth +i 1) true
(Micheline.root_value parameters_type) in
let 'existT _ __Ex_parameter_ty_and_entrypoints_'a2
[ctxt, entrypoints, full_value] :=
cast_exists (Es := Set)
(fun __Ex_parameter_ty_and_entrypoints_'a2 ⇒
[Alpha_context.context ** Script_typed_ir.entrypoints **
Script_typed_ir.ty]) [ctxt, entrypoints, full_value] in
let? '(entrypoint_arg, ctxt) :=
Gas_monad.run ctxt
((find_entrypoint_for_type
(full := __Ex_parameter_ty_and_entrypoints_'a2)) error_details
full_value arg entrypoints entrypoint) in
return?
(ctxt,
(let? '(entrypoint, arg_ty) := entrypoint_arg in
return?
(Script_typed_ir.Typed_sc_rollup
{|
Script_typed_ir.typed_contract.Typed_sc_rollup.arg_ty :=
arg_ty;
Script_typed_ir.typed_contract.Typed_sc_rollup.sc_rollup :=
sc_rollup;
Script_typed_ir.typed_contract.Typed_sc_rollup.entrypoint :=
entrypoint; |})))
end
end)
and "'parse_contract_data_aux" :=
(fun
(stack_depth : int) (ctxt : Alpha_context.context)
(loc_value : Alpha_context.Script.location) (arg : Script_typed_ir.ty)
(destination : Alpha_context.Destination.t)
(entrypoint : Alpha_context.Entrypoint.t) ⇒
let parse_contract {err} := 'parse_contract err in
let error_details := Script_tc_errors.Informative loc_value in
let? '(ctxt, res) :=
parse_contract (stack_depth +i 1) ctxt error_details loc_value arg
destination entrypoint in
let? res := res in
return? (ctxt, res)).
Definition parse_views := 'parse_views.
Definition parse_kdescr := 'parse_kdescr.
Definition parse_lam_rec := 'parse_lam_rec.
Definition parse_contract {err : Set} := 'parse_contract err.
Definition parse_contract_data_aux := 'parse_contract_data_aux.
Definition parse_contract_for_script
(ctxt : Alpha_context.context) (loc_value : Alpha_context.Script.location)
(arg : Script_typed_ir.ty) (destination : Alpha_context.Destination.t)
(entrypoint : Alpha_context.Entrypoint.t)
: M? (Alpha_context.context × option Script_typed_ir.typed_contract) :=
let? '(ctxt, res) :=
parse_contract 0 ctxt Script_tc_errors.Fast loc_value arg destination
entrypoint in
return?
(ctxt,
match res with
| Pervasives.Ok res ⇒ Some res
| Pervasives.Error Script_tc_errors.Inconsistent_types_fast ⇒ None
end).
Definition view_size (view : Script_typed_ir.view)
: Cache_memory_helpers.nodes_and_size :=
Script_typed_ir_size.op_plusplus
(Script_typed_ir_size.op_plusplus
(Script_typed_ir_size.node_size view.(Script_typed_ir.view.view_code))
(Script_typed_ir_size.node_size view.(Script_typed_ir.view.input_ty)))
(Script_typed_ir_size.node_size view.(Script_typed_ir.view.output_ty)).
Definition code_size {A : Set}
(ctxt : Alpha_context.context) (code : Script_typed_ir.lambda)
(views : Script_typed_ir.map A Script_typed_ir.view)
: M? (Cache_memory_helpers.sint × Alpha_context.context) :=
let views_size :=
Script_map.fold
(fun (function_parameter : A) ⇒
let '_ := function_parameter in
fun (v_value : Script_typed_ir.view) ⇒
fun (s_value : Cache_memory_helpers.nodes_and_size) ⇒
Script_typed_ir_size.op_plusplus (view_size v_value) s_value) views
Script_typed_ir_size.zero in
let ir_size := Script_typed_ir_size.lambda_size code in
let '(nodes, code_size) := Script_typed_ir_size.op_plusplus views_size ir_size
in
let? ctxt :=
Alpha_context.Gas.consume ctxt (Script_typed_ir_size_costs.nodes_cost nodes)
in
return? (code_size, ctxt).
Definition parse_code
(elab_conf : elab_conf) (ctxt : Alpha_context.context)
(code : Alpha_context.Script.lazy_expr)
: M? (ex_code × Alpha_context.context) :=
let? '(code, ctxt) :=
Alpha_context.Script.force_decode_in_context
Alpha_context.Script.When_needed ctxt code in
let legacy := elab_conf.(Script_ir_translator_config.elab_config.legacy) in
let? '(ctxt, code) := Alpha_context.Global_constants_storage.expand ctxt code
in
let?
'({|
toplevel.code_field := code_field;
toplevel.arg_type := arg_type;
toplevel.storage_type := storage_type;
toplevel.views := views
|}, ctxt) := parse_toplevel_aux ctxt legacy code in
let arg_type_loc := location arg_type in
let?
'(Ex_parameter_ty_and_entrypoints {|
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.arg_type :=
arg_type;
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.entrypoints
:= entrypoints
|}, ctxt) :=
Error_monad.record_trace
(Build_extensible "Ill_formed_type"
(option string × Alpha_context.Script.expr ×
Alpha_context.Script.location)
((Some "parameter"), code, arg_type_loc))
(parse_parameter_ty_and_entrypoints_aux ctxt 0 legacy arg_type) in
let storage_type_loc := location storage_type in
let? '(Script_typed_ir.Ex_ty storage_type, ctxt) :=
Error_monad.record_trace
(Build_extensible "Ill_formed_type"
(option string × Alpha_context.Script.expr ×
Alpha_context.Script.location)
((Some "storage"), code, storage_type_loc))
(parse_storage_ty ctxt 0 legacy storage_type) in
let? 'Script_typed_ir.Ty_ex_c arg_type_full :=
Script_typed_ir.pair_t storage_type_loc arg_type storage_type in
let? 'Script_typed_ir.Ty_ex_c ret_type_full :=
Script_typed_ir.pair_t storage_type_loc Script_typed_ir.list_operation_t
storage_type in
let? '(kdescr, ctxt) :=
Error_monad.trace_value
(Build_extensible "Ill_typed_contract"
(Alpha_context.Script.expr × Script_tc_errors.type_map) (code, nil))
(parse_kdescr elab_conf 0
(Tc_context.toplevel_value storage_type arg_type entrypoints) ctxt
arg_type_full ret_type_full code_field) in
let code := Script_typed_ir.Lam kdescr code_field in
let? '(code_size, ctxt) := code_size ctxt code views in
return?
((Ex_code
(Code
{| code.Code.code := code; code.Code.arg_type := arg_type;
code.Code.storage_type := storage_type; code.Code.views := views;
code.Code.entrypoints := entrypoints;
code.Code.code_size := code_size; |})), ctxt).
Definition parse_storage {storage : Set}
(elab_conf : elab_conf) (ctxt : Alpha_context.context) (allow_forged : bool)
(storage_type : Script_typed_ir.ty)
(storage_value : Alpha_context.Script.lazy_expr)
: M? (storage × Alpha_context.context) :=
let? '(storage_value, ctxt) :=
Alpha_context.Script.force_decode_in_context
Alpha_context.Script.When_needed ctxt storage_value in
Error_monad.trace_eval
(fun (function_parameter : unit) ⇒
let '_ := function_parameter in
let storage_type := Script_ir_unparser.serialize_ty_for_error storage_type
in
Build_extensible "Ill_typed_data"
(option string × Alpha_context.Script.expr × Alpha_context.Script.expr)
(None, storage_value, storage_type))
(parse_data_aux elab_conf 0 ctxt allow_forged storage_type
(Micheline.root_value storage_value)).
Definition parse_script
(elab_conf : elab_conf) (ctxt : Alpha_context.context)
(allow_forged_in_storage : bool) (function_parameter : Alpha_context.Script.t)
: M? (ex_script × Alpha_context.context) :=
let '{|
Alpha_context.Script.t.code := code;
Alpha_context.Script.t.storage := storage_value
|} := function_parameter in
let?
'(Ex_code
(Code {|
code.Code.code := code;
code.Code.arg_type := arg_type;
code.Code.storage_type := storage_type;
code.Code.views := views;
code.Code.entrypoints := entrypoints;
code.Code.code_size := code_size
|}), ctxt) := parse_code elab_conf ctxt code in
let 'existT _ __Ex_code_'c
[ctxt, code_size, entrypoints, views, storage_type, arg_type, code] :=
cast_exists (Es := Set)
(fun __Ex_code_'c ⇒
[Alpha_context.context ** Cache_memory_helpers.sint **
Script_typed_ir.entrypoints ** Script_typed_ir.view_map **
Script_typed_ir.ty ** Script_typed_ir.ty ** Script_typed_ir.lambda])
[ctxt, code_size, entrypoints, views, storage_type, arg_type, code] in
let? '(storage_value, ctxt) :=
parse_storage elab_conf ctxt allow_forged_in_storage storage_type
storage_value in
return?
((Ex_script
(Script_typed_ir.Script
{| Script_typed_ir.script.Script.code := code;
Script_typed_ir.script.Script.arg_type := arg_type;
Script_typed_ir.script.Script.storage :=
(storage_value : __Ex_code_'c);
Script_typed_ir.script.Script.storage_type := storage_type;
Script_typed_ir.script.Script.views := views;
Script_typed_ir.script.Script.entrypoints := entrypoints;
Script_typed_ir.script.Script.code_size := code_size; |})), ctxt).
Records for the constructor parameters
Module ConstructorRecords_typechecked_code_internal.
Module typechecked_code_internal.
Module Typechecked_code_internal.
Record record {toplevel arg_type storage_type entrypoints typed_views
type_map : Set} : Set := Build {
toplevel : toplevel;
arg_type : arg_type;
storage_type : storage_type;
entrypoints : entrypoints;
typed_views : typed_views;
type_map : type_map;
}.
Arguments record : clear implicits.
Definition with_toplevel
{t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map} toplevel
(r :
record t_toplevel t_arg_type t_storage_type t_entrypoints
t_typed_views t_type_map) :=
Build t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map toplevel r.(arg_type) r.(storage_type) r.(entrypoints)
r.(typed_views) r.(type_map).
Definition with_arg_type
{t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map} arg_type
(r :
record t_toplevel t_arg_type t_storage_type t_entrypoints
t_typed_views t_type_map) :=
Build t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map r.(toplevel) arg_type r.(storage_type) r.(entrypoints)
r.(typed_views) r.(type_map).
Definition with_storage_type
{t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map} storage_type
(r :
record t_toplevel t_arg_type t_storage_type t_entrypoints
t_typed_views t_type_map) :=
Build t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map r.(toplevel) r.(arg_type) storage_type r.(entrypoints)
r.(typed_views) r.(type_map).
Definition with_entrypoints
{t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map} entrypoints
(r :
record t_toplevel t_arg_type t_storage_type t_entrypoints
t_typed_views t_type_map) :=
Build t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map r.(toplevel) r.(arg_type) r.(storage_type) entrypoints
r.(typed_views) r.(type_map).
Definition with_typed_views
{t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map} typed_views
(r :
record t_toplevel t_arg_type t_storage_type t_entrypoints
t_typed_views t_type_map) :=
Build t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map r.(toplevel) r.(arg_type) r.(storage_type) r.(entrypoints)
typed_views r.(type_map).
Definition with_type_map
{t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map} type_map
(r :
record t_toplevel t_arg_type t_storage_type t_entrypoints
t_typed_views t_type_map) :=
Build t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map r.(toplevel) r.(arg_type) r.(storage_type) r.(entrypoints)
r.(typed_views) type_map.
End Typechecked_code_internal.
Definition Typechecked_code_internal_skeleton :=
Typechecked_code_internal.record.
End typechecked_code_internal.
End ConstructorRecords_typechecked_code_internal.
Import ConstructorRecords_typechecked_code_internal.
Reserved Notation "'typechecked_code_internal.Typechecked_code_internal".
Inductive typechecked_code_internal : Set :=
| Typechecked_code_internal :
'typechecked_code_internal.Typechecked_code_internal →
typechecked_code_internal
where "'typechecked_code_internal.Typechecked_code_internal" :=
(typechecked_code_internal.Typechecked_code_internal_skeleton toplevel
Script_typed_ir.ty Script_typed_ir.ty Script_typed_ir.entrypoints
typed_view_map Script_tc_errors.type_map).
Module typechecked_code_internal.
Include ConstructorRecords_typechecked_code_internal.typechecked_code_internal.
Definition Typechecked_code_internal :=
'typechecked_code_internal.Typechecked_code_internal.
End typechecked_code_internal.
Definition typecheck_code_aux
(legacy : bool) (show_types : bool) (ctxt : Alpha_context.context)
(code : Alpha_context.Script.expr)
: M? (typechecked_code_internal × Alpha_context.context) :=
let? '(ctxt, code) := Alpha_context.Global_constants_storage.expand ctxt code
in
let? '(toplevel_value, ctxt) := parse_toplevel_aux ctxt legacy code in
let '{|
toplevel.code_field := code_field;
toplevel.arg_type := arg_type;
toplevel.storage_type := storage_type;
toplevel.views := views
|} := toplevel_value in
let type_map := Pervasives.ref_value nil in
let arg_type_loc := location arg_type in
let?
'(Ex_parameter_ty_and_entrypoints {|
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.arg_type :=
arg_type;
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.entrypoints
:= entrypoints
|}, ctxt) :=
Error_monad.record_trace
(Build_extensible "Ill_formed_type"
(option string × Alpha_context.Script.expr ×
Alpha_context.Script.location)
((Some "parameter"), code, arg_type_loc))
(parse_parameter_ty_and_entrypoints_aux ctxt 0 legacy arg_type) in
let storage_type_loc := location storage_type in
let? '(ex_storage_type, ctxt) :=
Error_monad.record_trace
(Build_extensible "Ill_formed_type"
(option string × Alpha_context.Script.expr ×
Alpha_context.Script.location)
((Some "storage"), code, storage_type_loc))
(parse_storage_ty ctxt 0 legacy storage_type) in
let 'Script_typed_ir.Ex_ty storage_type := ex_storage_type in
let? 'Script_typed_ir.Ty_ex_c arg_type_full :=
Script_typed_ir.pair_t storage_type_loc arg_type storage_type in
let? 'Script_typed_ir.Ty_ex_c ret_type_full :=
Script_typed_ir.pair_t storage_type_loc Script_typed_ir.list_operation_t
storage_type in
let type_logger_value
(loc_value : Alpha_context.Script.location)
(stack_ty_before : Script_tc_errors.unparsed_stack_ty)
(stack_ty_after : Script_tc_errors.unparsed_stack_ty) : unit :=
Pervasives.op_coloneq type_map
(cons (loc_value, (stack_ty_before, stack_ty_after))
(Pervasives.op_exclamation type_map)) in
let type_logger_value :=
if show_types then
Some type_logger_value
else
None in
let elab_conf :=
Script_ir_translator_config.make type_logger_value None legacy tt in
let result_value :=
parse_kdescr elab_conf 0
(Tc_context.toplevel_value storage_type arg_type entrypoints) ctxt
arg_type_full ret_type_full code_field in
let? '(_, ctxt) :=
Error_monad.trace_value
(Build_extensible "Ill_typed_contract"
(Alpha_context.Script.expr × Script_tc_errors.type_map)
(code, (Pervasives.op_exclamation type_map))) result_value in
let views_result := parse_views elab_conf ctxt storage_type views in
let? '(typed_views, ctxt) :=
Error_monad.trace_value
(Build_extensible "Ill_typed_contract"
(Alpha_context.Script.expr × Script_tc_errors.type_map)
(code, (Pervasives.op_exclamation type_map))) views_result in
return?
((Typechecked_code_internal
{|
typechecked_code_internal.Typechecked_code_internal.toplevel :=
toplevel_value;
typechecked_code_internal.Typechecked_code_internal.arg_type :=
arg_type;
typechecked_code_internal.Typechecked_code_internal.storage_type :=
storage_type;
typechecked_code_internal.Typechecked_code_internal.entrypoints :=
entrypoints;
typechecked_code_internal.Typechecked_code_internal.typed_views :=
typed_views;
typechecked_code_internal.Typechecked_code_internal.type_map :=
Pervasives.op_exclamation type_map; |}), ctxt).
Definition list_entrypoints_uncarbonated
(full_value : Script_typed_ir.ty) (entrypoints : Script_typed_ir.entrypoints)
: list (list Alpha_context.Script.prim) ×
Entrypoint_repr.Map.(Map.S.t)
(Script_typed_ir.ex_ty × Alpha_context.Script.node) :=
let merge {A : Set}
(path : list A) (ty_value : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints_node) (reachable : bool)
(function_parameter :
list (list A) ×
Entrypoint_repr.Map.(Map.S.t)
(Script_typed_ir.ex_ty × Alpha_context.Script.node))
: (list (list A) ×
Entrypoint_repr.Map.(Map.S.t)
(Script_typed_ir.ex_ty × Alpha_context.Script.node)) × bool :=
let '(unreachables, all) as acc_value := function_parameter in
match entrypoints.(Script_typed_ir.entrypoints_node.at_node) with
| None ⇒
((if reachable then
acc_value
else
match ty_value with
| Script_typed_ir.Union_t _ _ _ _ ⇒ acc_value
| _ ⇒ ((cons (List.rev path) unreachables), all)
end), reachable)
|
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr :=
original_type_expr
|} ⇒
((if Alpha_context.Entrypoint.Map.(Map.S.mem) name all then
((cons (List.rev path) unreachables), all)
else
(unreachables,
(Alpha_context.Entrypoint.Map.(Map.S.add) name
((Script_typed_ir.Ex_ty ty_value), original_type_expr) all))), true)
end in
let fix fold_tree
(t_value : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints_node)
(path : list Alpha_context.Script.prim) (reachable : bool)
(acc_value :
list (list Alpha_context.Script.prim) ×
Entrypoint_repr.Map.(Map.S.t)
(Script_typed_ir.ex_ty × Alpha_context.Script.node))
: list (list Alpha_context.Script.prim) ×
Entrypoint_repr.Map.(Map.S.t)
(Script_typed_ir.ex_ty × Alpha_context.Script.node) :=
match (t_value, entrypoints) with
|
(Script_typed_ir.Union_t tl tr _ _, {|
Script_typed_ir.entrypoints_node.nested :=
Script_typed_ir.Entrypoints_Union {|
Script_typed_ir.nested_entrypoints.Entrypoints_Union._left := _left;
Script_typed_ir.nested_entrypoints.Entrypoints_Union._right
:= _right
|}
|}) ⇒
let '(acc_value, l_reachable) :=
merge (cons Michelson_v1_primitives.D_Left path) tl _left reachable
acc_value in
let '(acc_value, r_reachable) :=
merge (cons Michelson_v1_primitives.D_Right path) tr _right reachable
acc_value in
let acc_value :=
fold_tree tl _left (cons Michelson_v1_primitives.D_Left path)
l_reachable acc_value in
fold_tree tr _right (cons Michelson_v1_primitives.D_Right path)
r_reachable acc_value
| _ ⇒ acc_value
end in
let '(init_value, reachable) :=
match
entrypoints.(Script_typed_ir.entrypoints.root).(Script_typed_ir.entrypoints_node.at_node)
with
| None ⇒ (Alpha_context.Entrypoint.Map.(Map.S.empty), false)
|
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr :=
original_type_expr
|} ⇒
((Alpha_context.Entrypoint.Map.(Map.S.singleton) name
((Script_typed_ir.Ex_ty full_value), original_type_expr)), true)
end in
fold_tree full_value entrypoints.(Script_typed_ir.entrypoints.root) nil
reachable (nil, init_value).
Module Michelson_Parser.
Definition opened_ticket_type
: Alpha_context.Script.location → Script_typed_ir.comparable_ty →
M? Script_typed_ir.comparable_ty := opened_ticket_type.
Definition parse_packable_ty_aux
: Alpha_context.context → int → bool → Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) := parse_packable_ty_aux.
Definition parse_data_aux {A : Set}
: elab_conf → int → Alpha_context.context → bool → Script_typed_ir.ty →
Alpha_context.Script.node → M? (A × Alpha_context.context) :=
parse_data_aux.
(* Michelson_Parser *)
Definition module :=
{|
Script_ir_unparser.MICHELSON_PARSER.opened_ticket_type :=
opened_ticket_type;
Script_ir_unparser.MICHELSON_PARSER.parse_packable_ty_aux :=
parse_packable_ty_aux;
Script_ir_unparser.MICHELSON_PARSER.parse_data_aux _ := parse_data_aux
|}.
End Michelson_Parser.
Definition Michelson_Parser := Michelson_Parser.module.
Definition Data_unparser_Michelson :=
Script_ir_unparser.Data_unparser Michelson_Parser.
Definition Internal_for_benchmarking :=
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.Internal_for_benchmarking).
Definition parse_and_unparse_script_unaccounted {a : Set}
(ctxt : Alpha_context.context) (legacy : bool)
(allow_forged_in_storage : bool) (mode : Script_ir_unparser.unparsing_mode)
(normalize_types : bool) (function_parameter : Alpha_context.Script.t)
: M? (Alpha_context.Script.t × Alpha_context.context) :=
let '{|
Alpha_context.Script.t.code := code;
Alpha_context.Script.t.storage := storage_value
|} := function_parameter in
let? '(code, ctxt) :=
Alpha_context.Script.force_decode_in_context
Alpha_context.Script.When_needed ctxt code in
let?
'(Typechecked_code_internal {|
typechecked_code_internal.Typechecked_code_internal.toplevel := {|
toplevel.code_field := code_field;
toplevel.arg_type := original_arg_type_expr;
toplevel.storage_type := original_storage_type_expr;
toplevel.views := views
|};
typechecked_code_internal.Typechecked_code_internal.arg_type := arg_type;
typechecked_code_internal.Typechecked_code_internal.storage_type :=
storage_type;
typechecked_code_internal.Typechecked_code_internal.entrypoints :=
entrypoints;
typechecked_code_internal.Typechecked_code_internal.typed_views :=
typed_views;
typechecked_code_internal.Typechecked_code_internal.type_map := _
|}, ctxt) := typecheck_code_aux legacy false ctxt code in
let? '(storage_value, ctxt) :=
parse_storage (Script_ir_translator_config.make None None legacy tt) ctxt
allow_forged_in_storage storage_type storage_value in
let? '(code, ctxt) :=
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_code_aux)
ctxt 0 mode code_field in
let? '(storage_value, ctxt) :=
(Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_data_aux)
(a := a)) ctxt 0 mode storage_type storage_value in
let loc_value := Micheline.dummy_location in
let? '(arg_type, storage_type, views, ctxt) :=
if normalize_types then
let? '(arg_type, ctxt) :=
Script_ir_unparser.unparse_parameter_ty loc_value ctxt arg_type
entrypoints in
let? '(storage_type, ctxt) :=
Script_ir_unparser.unparse_ty loc_value ctxt storage_type in
let? '(views, ctxt) :=
Script_map.map_es_in_context
(fun (ctxt : Alpha_context.context) ⇒
fun (_name : Script_string.t) ⇒
fun (function_parameter : typed_view) ⇒
let
'Typed_view {|
typed_view.Typed_view.input_ty := input_ty;
typed_view.Typed_view.output_ty := output_ty;
typed_view.Typed_view.kinstr := _;
typed_view.Typed_view.original_code_expr :=
original_code_expr
|} := function_parameter in
let? '(input_ty, ctxt) :=
Script_ir_unparser.unparse_ty loc_value ctxt input_ty in
let? '(output_ty, ctxt) :=
Script_ir_unparser.unparse_ty loc_value ctxt output_ty in
return?
({| Script_typed_ir.view.input_ty := input_ty;
Script_typed_ir.view.output_ty := output_ty;
Script_typed_ir.view.view_code := original_code_expr; |},
ctxt)) ctxt typed_views in
return? (arg_type, storage_type, views, ctxt)
else
return? (original_arg_type_expr, original_storage_type_expr, views, ctxt)
in
let? '(views, ctxt) :=
Script_map.map_es_in_context
(fun (ctxt : Alpha_context.context) ⇒
fun (_name : Script_string.t) ⇒
fun (function_parameter : Script_typed_ir.view) ⇒
let '{|
Script_typed_ir.view.input_ty := input_ty;
Script_typed_ir.view.output_ty := output_ty;
Script_typed_ir.view.view_code := view_code
|} := function_parameter in
let? '(view_code, ctxt) :=
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_code_aux)
ctxt 0 mode view_code in
let view_code := Micheline.root_value view_code in
return?
({| Script_typed_ir.view.input_ty := input_ty;
Script_typed_ir.view.output_ty := output_ty;
Script_typed_ir.view.view_code := view_code; |}, ctxt)) ctxt
views in
let unparse_view_unaccounted
(name : Script_string.t) (function_parameter : Script_typed_ir.view)
: list
(Micheline.node Micheline.canonical_location Alpha_context.Script.prim) →
list (Micheline.node Micheline.canonical_location Alpha_context.Script.prim) :=
let '{|
Script_typed_ir.view.input_ty := input_ty;
Script_typed_ir.view.output_ty := output_ty;
Script_typed_ir.view.view_code := view_code
|} := function_parameter in
fun (views :
list
(Micheline.node Micheline.canonical_location Alpha_context.Script.prim))
⇒
cons
(Micheline.Prim loc_value Michelson_v1_primitives.K_view
[
Micheline.String loc_value (Script_string.to_string name);
input_ty;
output_ty;
view_code
] nil) views in
let views := List.rev (Script_map.fold unparse_view_unaccounted views nil) in
let code :=
Micheline.Seq loc_value
(Pervasives.op_at
[
Micheline.Prim loc_value Michelson_v1_primitives.K_parameter
[ arg_type ] nil;
Micheline.Prim loc_value Michelson_v1_primitives.K_storage
[ storage_type ] nil;
Micheline.Prim loc_value Michelson_v1_primitives.K_code
[ Micheline.root_value code ] nil
] views) in
return?
({|
Alpha_context.Script.t.code :=
Alpha_context.Script.lazy_expr_value (Micheline.strip_locations code);
Alpha_context.Script.t.storage :=
Alpha_context.Script.lazy_expr_value storage_value; |}, ctxt).
Definition pack_data_with_mode {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty) (data : A)
(mode : Script_ir_unparser.unparsing_mode)
: M? (bytes × Alpha_context.context) :=
let? '(unparsed, ctxt) :=
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_data_aux)
ctxt 0 mode ty_value data in
return? (pack_node unparsed ctxt).
Definition hash_data {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty) (data : A)
: M? (Script_expr_hash.t × Alpha_context.context) :=
let? '(bytes_value, ctxt) :=
pack_data_with_mode ctxt ty_value data Script_ir_unparser.Optimized_legacy
in
hash_bytes ctxt bytes_value.
Definition pack_data {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty) (data : A)
: M? (bytes × Alpha_context.context) :=
pack_data_with_mode ctxt ty_value data Script_ir_unparser.Optimized_legacy.
Definition lazy_storage_ids : Set := Alpha_context.Lazy_storage.IdSet.t.
Definition no_lazy_storage_id : Alpha_context.Lazy_storage.IdSet.t :=
Alpha_context.Lazy_storage.IdSet.empty.
Definition diff_of_big_map
(ctxt : Alpha_context.context) (mode : Script_ir_unparser.unparsing_mode)
(temporary : bool) (ids_to_copy : Alpha_context.Lazy_storage.IdSet.t)
(big_map : Script_typed_ir.big_map)
: M?
(Alpha_context.Lazy_storage.diff Alpha_context.Big_map.Id.t
Alpha_context.Big_map.alloc (list Alpha_context.Big_map.update) ×
Alpha_context.Big_map.Id.t × Alpha_context.context) :=
let
'Script_typed_ir.Big_map {|
Script_typed_ir.big_map.Big_map.id := id;
Script_typed_ir.big_map.Big_map.diff := diff_value;
Script_typed_ir.big_map.Big_map.key_type := key_type;
Script_typed_ir.big_map.Big_map.value_type := value_type
|} := big_map in
let 'existT _ [b, a] [value_type, key_type, diff_value, id] :=
cast_exists (Es := [Set ** Set])
(fun '[b, a] ⇒
[Script_typed_ir.ty ** Script_typed_ir.comparable_ty **
Script_typed_ir.big_map_overlay a b **
option Alpha_context.Big_map.Id.t])
[value_type, key_type, diff_value, id] in
let? '(ctxt, init_value, id) :=
match id with
| Some id ⇒
if
Alpha_context.Lazy_storage.IdSet.mem
Alpha_context.Lazy_storage.Kind.Big_map id ids_to_copy
then
let? '(ctxt, duplicate) := Alpha_context.Big_map.fresh temporary ctxt in
return?
(ctxt,
(Alpha_context.Lazy_storage.Copy
{| Alpha_context.Lazy_storage.init.Copy.src := id; |}), duplicate)
else
return? (ctxt, Alpha_context.Lazy_storage.Existing, id)
| None ⇒
let? '(ctxt, id) := Alpha_context.Big_map.fresh temporary ctxt in
let kt :=
Script_ir_unparser.unparse_comparable_ty_uncarbonated tt key_type in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Alpha_context.Script.strip_locations_cost kt) in
let? '(kv, ctxt) := Script_ir_unparser.unparse_ty tt ctxt value_type in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Alpha_context.Script.strip_locations_cost kv) in
let key_type := Micheline.strip_locations kt in
let value_type := Micheline.strip_locations kv in
return?
(ctxt,
(Alpha_context.Lazy_storage.Alloc
{| Lazy_storage_kind.Big_map.alloc.key_type := key_type;
Lazy_storage_kind.Big_map.alloc.value_type := value_type; |}), id)
end in
let pairs : list (Script_expr_hash.t × a × option b) :=
Script_typed_ir.Big_map_overlay.(Map.S.fold)
(fun (key_hash : Script_expr_hash.t) ⇒
fun (function_parameter : a × option b) ⇒
let '(key_value, value_value) := function_parameter in
fun (acc_value : list (Script_expr_hash.t × a × option b)) ⇒
cons (key_hash, key_value, value_value) acc_value)
diff_value.(Script_typed_ir.big_map_overlay.map) nil in
let? '(updates, ctxt) :=
List.fold_left_es
(fun (function_parameter :
list Alpha_context.Big_map.update × Alpha_context.context) ⇒
let '(acc_value, ctxt) := function_parameter in
fun (function_parameter : Script_expr_hash.t × a × option b) ⇒
let '(key_hash, key_value, value_value) := function_parameter in
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle in
let? '(key_value, ctxt) :=
Script_ir_unparser.unparse_comparable_data ctxt mode key_type
key_value in
let? '(value_value, ctxt) :=
match value_value with
| None ⇒ return? (None, ctxt)
| Some x_value ⇒
let? '(node_value, ctxt) :=
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_data_aux)
ctxt 0 mode value_type x_value in
return? ((Some node_value), ctxt)
end in
let diff_item :=
{| Lazy_storage_kind.Big_map.update.key := key_value;
Lazy_storage_kind.Big_map.update.key_hash := key_hash;
Lazy_storage_kind.Big_map.update.value := value_value; |} in
return? ((cons diff_item acc_value), ctxt)) (nil, ctxt)
(List.rev pairs) in
return?
((Alpha_context.Lazy_storage.Update
{| Alpha_context.Lazy_storage.diff.Update.init := init_value;
Alpha_context.Lazy_storage.diff.Update.updates := updates; |}), id, ctxt).
Definition diff_of_sapling_state
(ctxt : Alpha_context.context) (temporary : bool)
(ids_to_copy : Alpha_context.Lazy_storage.IdSet.t)
(function_parameter : Alpha_context.Sapling.state)
: M?
(Alpha_context.Lazy_storage.diff Alpha_context.Sapling.Id.t
Alpha_context.Sapling.alloc Alpha_context.Sapling.diff ×
Alpha_context.Sapling.Id.t × Alpha_context.context) :=
let '{|
Alpha_context.Sapling.state.id := id;
Alpha_context.Sapling.state.diff := diff_value;
Alpha_context.Sapling.state.memo_size := memo_size
|} := function_parameter in
let? '(ctxt, init_value, id) :=
match id with
| Some id ⇒
if
Alpha_context.Lazy_storage.IdSet.mem
Alpha_context.Lazy_storage.Kind.Sapling_state id ids_to_copy
then
let? '(ctxt, duplicate) := Alpha_context.Sapling.fresh temporary ctxt in
return?
(ctxt,
(Alpha_context.Lazy_storage.Copy
{| Alpha_context.Lazy_storage.init.Copy.src := id; |}), duplicate)
else
return? (ctxt, Alpha_context.Lazy_storage.Existing, id)
| None ⇒
let? '(ctxt, id) := Alpha_context.Sapling.fresh temporary ctxt in
return?
(ctxt,
(Alpha_context.Lazy_storage.Alloc
{| Lazy_storage_kind.Sapling_state.alloc.memo_size := memo_size; |}),
id)
end in
return?
((Alpha_context.Lazy_storage.Update
{| Alpha_context.Lazy_storage.diff.Update.init := init_value;
Alpha_context.Lazy_storage.diff.Update.updates := diff_value; |}), id,
ctxt).
Inductive has_lazy_storage : Set :=
| Big_map_f : has_lazy_storage
| Sapling_state_f : has_lazy_storage
| False_f : has_lazy_storage
| Pair_f : has_lazy_storage → has_lazy_storage → has_lazy_storage
| Union_f : has_lazy_storage → has_lazy_storage → has_lazy_storage
| Option_f : has_lazy_storage → has_lazy_storage
| List_f : has_lazy_storage → has_lazy_storage
| Map_f : has_lazy_storage → has_lazy_storage.
Module typechecked_code_internal.
Module Typechecked_code_internal.
Record record {toplevel arg_type storage_type entrypoints typed_views
type_map : Set} : Set := Build {
toplevel : toplevel;
arg_type : arg_type;
storage_type : storage_type;
entrypoints : entrypoints;
typed_views : typed_views;
type_map : type_map;
}.
Arguments record : clear implicits.
Definition with_toplevel
{t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map} toplevel
(r :
record t_toplevel t_arg_type t_storage_type t_entrypoints
t_typed_views t_type_map) :=
Build t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map toplevel r.(arg_type) r.(storage_type) r.(entrypoints)
r.(typed_views) r.(type_map).
Definition with_arg_type
{t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map} arg_type
(r :
record t_toplevel t_arg_type t_storage_type t_entrypoints
t_typed_views t_type_map) :=
Build t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map r.(toplevel) arg_type r.(storage_type) r.(entrypoints)
r.(typed_views) r.(type_map).
Definition with_storage_type
{t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map} storage_type
(r :
record t_toplevel t_arg_type t_storage_type t_entrypoints
t_typed_views t_type_map) :=
Build t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map r.(toplevel) r.(arg_type) storage_type r.(entrypoints)
r.(typed_views) r.(type_map).
Definition with_entrypoints
{t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map} entrypoints
(r :
record t_toplevel t_arg_type t_storage_type t_entrypoints
t_typed_views t_type_map) :=
Build t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map r.(toplevel) r.(arg_type) r.(storage_type) entrypoints
r.(typed_views) r.(type_map).
Definition with_typed_views
{t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map} typed_views
(r :
record t_toplevel t_arg_type t_storage_type t_entrypoints
t_typed_views t_type_map) :=
Build t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map r.(toplevel) r.(arg_type) r.(storage_type) r.(entrypoints)
typed_views r.(type_map).
Definition with_type_map
{t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map} type_map
(r :
record t_toplevel t_arg_type t_storage_type t_entrypoints
t_typed_views t_type_map) :=
Build t_toplevel t_arg_type t_storage_type t_entrypoints t_typed_views
t_type_map r.(toplevel) r.(arg_type) r.(storage_type) r.(entrypoints)
r.(typed_views) type_map.
End Typechecked_code_internal.
Definition Typechecked_code_internal_skeleton :=
Typechecked_code_internal.record.
End typechecked_code_internal.
End ConstructorRecords_typechecked_code_internal.
Import ConstructorRecords_typechecked_code_internal.
Reserved Notation "'typechecked_code_internal.Typechecked_code_internal".
Inductive typechecked_code_internal : Set :=
| Typechecked_code_internal :
'typechecked_code_internal.Typechecked_code_internal →
typechecked_code_internal
where "'typechecked_code_internal.Typechecked_code_internal" :=
(typechecked_code_internal.Typechecked_code_internal_skeleton toplevel
Script_typed_ir.ty Script_typed_ir.ty Script_typed_ir.entrypoints
typed_view_map Script_tc_errors.type_map).
Module typechecked_code_internal.
Include ConstructorRecords_typechecked_code_internal.typechecked_code_internal.
Definition Typechecked_code_internal :=
'typechecked_code_internal.Typechecked_code_internal.
End typechecked_code_internal.
Definition typecheck_code_aux
(legacy : bool) (show_types : bool) (ctxt : Alpha_context.context)
(code : Alpha_context.Script.expr)
: M? (typechecked_code_internal × Alpha_context.context) :=
let? '(ctxt, code) := Alpha_context.Global_constants_storage.expand ctxt code
in
let? '(toplevel_value, ctxt) := parse_toplevel_aux ctxt legacy code in
let '{|
toplevel.code_field := code_field;
toplevel.arg_type := arg_type;
toplevel.storage_type := storage_type;
toplevel.views := views
|} := toplevel_value in
let type_map := Pervasives.ref_value nil in
let arg_type_loc := location arg_type in
let?
'(Ex_parameter_ty_and_entrypoints {|
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.arg_type :=
arg_type;
ex_parameter_ty_and_entrypoints.Ex_parameter_ty_and_entrypoints.entrypoints
:= entrypoints
|}, ctxt) :=
Error_monad.record_trace
(Build_extensible "Ill_formed_type"
(option string × Alpha_context.Script.expr ×
Alpha_context.Script.location)
((Some "parameter"), code, arg_type_loc))
(parse_parameter_ty_and_entrypoints_aux ctxt 0 legacy arg_type) in
let storage_type_loc := location storage_type in
let? '(ex_storage_type, ctxt) :=
Error_monad.record_trace
(Build_extensible "Ill_formed_type"
(option string × Alpha_context.Script.expr ×
Alpha_context.Script.location)
((Some "storage"), code, storage_type_loc))
(parse_storage_ty ctxt 0 legacy storage_type) in
let 'Script_typed_ir.Ex_ty storage_type := ex_storage_type in
let? 'Script_typed_ir.Ty_ex_c arg_type_full :=
Script_typed_ir.pair_t storage_type_loc arg_type storage_type in
let? 'Script_typed_ir.Ty_ex_c ret_type_full :=
Script_typed_ir.pair_t storage_type_loc Script_typed_ir.list_operation_t
storage_type in
let type_logger_value
(loc_value : Alpha_context.Script.location)
(stack_ty_before : Script_tc_errors.unparsed_stack_ty)
(stack_ty_after : Script_tc_errors.unparsed_stack_ty) : unit :=
Pervasives.op_coloneq type_map
(cons (loc_value, (stack_ty_before, stack_ty_after))
(Pervasives.op_exclamation type_map)) in
let type_logger_value :=
if show_types then
Some type_logger_value
else
None in
let elab_conf :=
Script_ir_translator_config.make type_logger_value None legacy tt in
let result_value :=
parse_kdescr elab_conf 0
(Tc_context.toplevel_value storage_type arg_type entrypoints) ctxt
arg_type_full ret_type_full code_field in
let? '(_, ctxt) :=
Error_monad.trace_value
(Build_extensible "Ill_typed_contract"
(Alpha_context.Script.expr × Script_tc_errors.type_map)
(code, (Pervasives.op_exclamation type_map))) result_value in
let views_result := parse_views elab_conf ctxt storage_type views in
let? '(typed_views, ctxt) :=
Error_monad.trace_value
(Build_extensible "Ill_typed_contract"
(Alpha_context.Script.expr × Script_tc_errors.type_map)
(code, (Pervasives.op_exclamation type_map))) views_result in
return?
((Typechecked_code_internal
{|
typechecked_code_internal.Typechecked_code_internal.toplevel :=
toplevel_value;
typechecked_code_internal.Typechecked_code_internal.arg_type :=
arg_type;
typechecked_code_internal.Typechecked_code_internal.storage_type :=
storage_type;
typechecked_code_internal.Typechecked_code_internal.entrypoints :=
entrypoints;
typechecked_code_internal.Typechecked_code_internal.typed_views :=
typed_views;
typechecked_code_internal.Typechecked_code_internal.type_map :=
Pervasives.op_exclamation type_map; |}), ctxt).
Definition list_entrypoints_uncarbonated
(full_value : Script_typed_ir.ty) (entrypoints : Script_typed_ir.entrypoints)
: list (list Alpha_context.Script.prim) ×
Entrypoint_repr.Map.(Map.S.t)
(Script_typed_ir.ex_ty × Alpha_context.Script.node) :=
let merge {A : Set}
(path : list A) (ty_value : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints_node) (reachable : bool)
(function_parameter :
list (list A) ×
Entrypoint_repr.Map.(Map.S.t)
(Script_typed_ir.ex_ty × Alpha_context.Script.node))
: (list (list A) ×
Entrypoint_repr.Map.(Map.S.t)
(Script_typed_ir.ex_ty × Alpha_context.Script.node)) × bool :=
let '(unreachables, all) as acc_value := function_parameter in
match entrypoints.(Script_typed_ir.entrypoints_node.at_node) with
| None ⇒
((if reachable then
acc_value
else
match ty_value with
| Script_typed_ir.Union_t _ _ _ _ ⇒ acc_value
| _ ⇒ ((cons (List.rev path) unreachables), all)
end), reachable)
|
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr :=
original_type_expr
|} ⇒
((if Alpha_context.Entrypoint.Map.(Map.S.mem) name all then
((cons (List.rev path) unreachables), all)
else
(unreachables,
(Alpha_context.Entrypoint.Map.(Map.S.add) name
((Script_typed_ir.Ex_ty ty_value), original_type_expr) all))), true)
end in
let fix fold_tree
(t_value : Script_typed_ir.ty)
(entrypoints : Script_typed_ir.entrypoints_node)
(path : list Alpha_context.Script.prim) (reachable : bool)
(acc_value :
list (list Alpha_context.Script.prim) ×
Entrypoint_repr.Map.(Map.S.t)
(Script_typed_ir.ex_ty × Alpha_context.Script.node))
: list (list Alpha_context.Script.prim) ×
Entrypoint_repr.Map.(Map.S.t)
(Script_typed_ir.ex_ty × Alpha_context.Script.node) :=
match (t_value, entrypoints) with
|
(Script_typed_ir.Union_t tl tr _ _, {|
Script_typed_ir.entrypoints_node.nested :=
Script_typed_ir.Entrypoints_Union {|
Script_typed_ir.nested_entrypoints.Entrypoints_Union._left := _left;
Script_typed_ir.nested_entrypoints.Entrypoints_Union._right
:= _right
|}
|}) ⇒
let '(acc_value, l_reachable) :=
merge (cons Michelson_v1_primitives.D_Left path) tl _left reachable
acc_value in
let '(acc_value, r_reachable) :=
merge (cons Michelson_v1_primitives.D_Right path) tr _right reachable
acc_value in
let acc_value :=
fold_tree tl _left (cons Michelson_v1_primitives.D_Left path)
l_reachable acc_value in
fold_tree tr _right (cons Michelson_v1_primitives.D_Right path)
r_reachable acc_value
| _ ⇒ acc_value
end in
let '(init_value, reachable) :=
match
entrypoints.(Script_typed_ir.entrypoints.root).(Script_typed_ir.entrypoints_node.at_node)
with
| None ⇒ (Alpha_context.Entrypoint.Map.(Map.S.empty), false)
|
Some {|
Script_typed_ir.entrypoint_info.name := name;
Script_typed_ir.entrypoint_info.original_type_expr :=
original_type_expr
|} ⇒
((Alpha_context.Entrypoint.Map.(Map.S.singleton) name
((Script_typed_ir.Ex_ty full_value), original_type_expr)), true)
end in
fold_tree full_value entrypoints.(Script_typed_ir.entrypoints.root) nil
reachable (nil, init_value).
Module Michelson_Parser.
Definition opened_ticket_type
: Alpha_context.Script.location → Script_typed_ir.comparable_ty →
M? Script_typed_ir.comparable_ty := opened_ticket_type.
Definition parse_packable_ty_aux
: Alpha_context.context → int → bool → Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) := parse_packable_ty_aux.
Definition parse_data_aux {A : Set}
: elab_conf → int → Alpha_context.context → bool → Script_typed_ir.ty →
Alpha_context.Script.node → M? (A × Alpha_context.context) :=
parse_data_aux.
(* Michelson_Parser *)
Definition module :=
{|
Script_ir_unparser.MICHELSON_PARSER.opened_ticket_type :=
opened_ticket_type;
Script_ir_unparser.MICHELSON_PARSER.parse_packable_ty_aux :=
parse_packable_ty_aux;
Script_ir_unparser.MICHELSON_PARSER.parse_data_aux _ := parse_data_aux
|}.
End Michelson_Parser.
Definition Michelson_Parser := Michelson_Parser.module.
Definition Data_unparser_Michelson :=
Script_ir_unparser.Data_unparser Michelson_Parser.
Definition Internal_for_benchmarking :=
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.Internal_for_benchmarking).
Definition parse_and_unparse_script_unaccounted {a : Set}
(ctxt : Alpha_context.context) (legacy : bool)
(allow_forged_in_storage : bool) (mode : Script_ir_unparser.unparsing_mode)
(normalize_types : bool) (function_parameter : Alpha_context.Script.t)
: M? (Alpha_context.Script.t × Alpha_context.context) :=
let '{|
Alpha_context.Script.t.code := code;
Alpha_context.Script.t.storage := storage_value
|} := function_parameter in
let? '(code, ctxt) :=
Alpha_context.Script.force_decode_in_context
Alpha_context.Script.When_needed ctxt code in
let?
'(Typechecked_code_internal {|
typechecked_code_internal.Typechecked_code_internal.toplevel := {|
toplevel.code_field := code_field;
toplevel.arg_type := original_arg_type_expr;
toplevel.storage_type := original_storage_type_expr;
toplevel.views := views
|};
typechecked_code_internal.Typechecked_code_internal.arg_type := arg_type;
typechecked_code_internal.Typechecked_code_internal.storage_type :=
storage_type;
typechecked_code_internal.Typechecked_code_internal.entrypoints :=
entrypoints;
typechecked_code_internal.Typechecked_code_internal.typed_views :=
typed_views;
typechecked_code_internal.Typechecked_code_internal.type_map := _
|}, ctxt) := typecheck_code_aux legacy false ctxt code in
let? '(storage_value, ctxt) :=
parse_storage (Script_ir_translator_config.make None None legacy tt) ctxt
allow_forged_in_storage storage_type storage_value in
let? '(code, ctxt) :=
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_code_aux)
ctxt 0 mode code_field in
let? '(storage_value, ctxt) :=
(Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_data_aux)
(a := a)) ctxt 0 mode storage_type storage_value in
let loc_value := Micheline.dummy_location in
let? '(arg_type, storage_type, views, ctxt) :=
if normalize_types then
let? '(arg_type, ctxt) :=
Script_ir_unparser.unparse_parameter_ty loc_value ctxt arg_type
entrypoints in
let? '(storage_type, ctxt) :=
Script_ir_unparser.unparse_ty loc_value ctxt storage_type in
let? '(views, ctxt) :=
Script_map.map_es_in_context
(fun (ctxt : Alpha_context.context) ⇒
fun (_name : Script_string.t) ⇒
fun (function_parameter : typed_view) ⇒
let
'Typed_view {|
typed_view.Typed_view.input_ty := input_ty;
typed_view.Typed_view.output_ty := output_ty;
typed_view.Typed_view.kinstr := _;
typed_view.Typed_view.original_code_expr :=
original_code_expr
|} := function_parameter in
let? '(input_ty, ctxt) :=
Script_ir_unparser.unparse_ty loc_value ctxt input_ty in
let? '(output_ty, ctxt) :=
Script_ir_unparser.unparse_ty loc_value ctxt output_ty in
return?
({| Script_typed_ir.view.input_ty := input_ty;
Script_typed_ir.view.output_ty := output_ty;
Script_typed_ir.view.view_code := original_code_expr; |},
ctxt)) ctxt typed_views in
return? (arg_type, storage_type, views, ctxt)
else
return? (original_arg_type_expr, original_storage_type_expr, views, ctxt)
in
let? '(views, ctxt) :=
Script_map.map_es_in_context
(fun (ctxt : Alpha_context.context) ⇒
fun (_name : Script_string.t) ⇒
fun (function_parameter : Script_typed_ir.view) ⇒
let '{|
Script_typed_ir.view.input_ty := input_ty;
Script_typed_ir.view.output_ty := output_ty;
Script_typed_ir.view.view_code := view_code
|} := function_parameter in
let? '(view_code, ctxt) :=
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_code_aux)
ctxt 0 mode view_code in
let view_code := Micheline.root_value view_code in
return?
({| Script_typed_ir.view.input_ty := input_ty;
Script_typed_ir.view.output_ty := output_ty;
Script_typed_ir.view.view_code := view_code; |}, ctxt)) ctxt
views in
let unparse_view_unaccounted
(name : Script_string.t) (function_parameter : Script_typed_ir.view)
: list
(Micheline.node Micheline.canonical_location Alpha_context.Script.prim) →
list (Micheline.node Micheline.canonical_location Alpha_context.Script.prim) :=
let '{|
Script_typed_ir.view.input_ty := input_ty;
Script_typed_ir.view.output_ty := output_ty;
Script_typed_ir.view.view_code := view_code
|} := function_parameter in
fun (views :
list
(Micheline.node Micheline.canonical_location Alpha_context.Script.prim))
⇒
cons
(Micheline.Prim loc_value Michelson_v1_primitives.K_view
[
Micheline.String loc_value (Script_string.to_string name);
input_ty;
output_ty;
view_code
] nil) views in
let views := List.rev (Script_map.fold unparse_view_unaccounted views nil) in
let code :=
Micheline.Seq loc_value
(Pervasives.op_at
[
Micheline.Prim loc_value Michelson_v1_primitives.K_parameter
[ arg_type ] nil;
Micheline.Prim loc_value Michelson_v1_primitives.K_storage
[ storage_type ] nil;
Micheline.Prim loc_value Michelson_v1_primitives.K_code
[ Micheline.root_value code ] nil
] views) in
return?
({|
Alpha_context.Script.t.code :=
Alpha_context.Script.lazy_expr_value (Micheline.strip_locations code);
Alpha_context.Script.t.storage :=
Alpha_context.Script.lazy_expr_value storage_value; |}, ctxt).
Definition pack_data_with_mode {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty) (data : A)
(mode : Script_ir_unparser.unparsing_mode)
: M? (bytes × Alpha_context.context) :=
let? '(unparsed, ctxt) :=
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_data_aux)
ctxt 0 mode ty_value data in
return? (pack_node unparsed ctxt).
Definition hash_data {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty) (data : A)
: M? (Script_expr_hash.t × Alpha_context.context) :=
let? '(bytes_value, ctxt) :=
pack_data_with_mode ctxt ty_value data Script_ir_unparser.Optimized_legacy
in
hash_bytes ctxt bytes_value.
Definition pack_data {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty) (data : A)
: M? (bytes × Alpha_context.context) :=
pack_data_with_mode ctxt ty_value data Script_ir_unparser.Optimized_legacy.
Definition lazy_storage_ids : Set := Alpha_context.Lazy_storage.IdSet.t.
Definition no_lazy_storage_id : Alpha_context.Lazy_storage.IdSet.t :=
Alpha_context.Lazy_storage.IdSet.empty.
Definition diff_of_big_map
(ctxt : Alpha_context.context) (mode : Script_ir_unparser.unparsing_mode)
(temporary : bool) (ids_to_copy : Alpha_context.Lazy_storage.IdSet.t)
(big_map : Script_typed_ir.big_map)
: M?
(Alpha_context.Lazy_storage.diff Alpha_context.Big_map.Id.t
Alpha_context.Big_map.alloc (list Alpha_context.Big_map.update) ×
Alpha_context.Big_map.Id.t × Alpha_context.context) :=
let
'Script_typed_ir.Big_map {|
Script_typed_ir.big_map.Big_map.id := id;
Script_typed_ir.big_map.Big_map.diff := diff_value;
Script_typed_ir.big_map.Big_map.key_type := key_type;
Script_typed_ir.big_map.Big_map.value_type := value_type
|} := big_map in
let 'existT _ [b, a] [value_type, key_type, diff_value, id] :=
cast_exists (Es := [Set ** Set])
(fun '[b, a] ⇒
[Script_typed_ir.ty ** Script_typed_ir.comparable_ty **
Script_typed_ir.big_map_overlay a b **
option Alpha_context.Big_map.Id.t])
[value_type, key_type, diff_value, id] in
let? '(ctxt, init_value, id) :=
match id with
| Some id ⇒
if
Alpha_context.Lazy_storage.IdSet.mem
Alpha_context.Lazy_storage.Kind.Big_map id ids_to_copy
then
let? '(ctxt, duplicate) := Alpha_context.Big_map.fresh temporary ctxt in
return?
(ctxt,
(Alpha_context.Lazy_storage.Copy
{| Alpha_context.Lazy_storage.init.Copy.src := id; |}), duplicate)
else
return? (ctxt, Alpha_context.Lazy_storage.Existing, id)
| None ⇒
let? '(ctxt, id) := Alpha_context.Big_map.fresh temporary ctxt in
let kt :=
Script_ir_unparser.unparse_comparable_ty_uncarbonated tt key_type in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Alpha_context.Script.strip_locations_cost kt) in
let? '(kv, ctxt) := Script_ir_unparser.unparse_ty tt ctxt value_type in
let? ctxt :=
Alpha_context.Gas.consume ctxt
(Alpha_context.Script.strip_locations_cost kv) in
let key_type := Micheline.strip_locations kt in
let value_type := Micheline.strip_locations kv in
return?
(ctxt,
(Alpha_context.Lazy_storage.Alloc
{| Lazy_storage_kind.Big_map.alloc.key_type := key_type;
Lazy_storage_kind.Big_map.alloc.value_type := value_type; |}), id)
end in
let pairs : list (Script_expr_hash.t × a × option b) :=
Script_typed_ir.Big_map_overlay.(Map.S.fold)
(fun (key_hash : Script_expr_hash.t) ⇒
fun (function_parameter : a × option b) ⇒
let '(key_value, value_value) := function_parameter in
fun (acc_value : list (Script_expr_hash.t × a × option b)) ⇒
cons (key_hash, key_value, value_value) acc_value)
diff_value.(Script_typed_ir.big_map_overlay.map) nil in
let? '(updates, ctxt) :=
List.fold_left_es
(fun (function_parameter :
list Alpha_context.Big_map.update × Alpha_context.context) ⇒
let '(acc_value, ctxt) := function_parameter in
fun (function_parameter : Script_expr_hash.t × a × option b) ⇒
let '(key_hash, key_value, value_value) := function_parameter in
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle in
let? '(key_value, ctxt) :=
Script_ir_unparser.unparse_comparable_data ctxt mode key_type
key_value in
let? '(value_value, ctxt) :=
match value_value with
| None ⇒ return? (None, ctxt)
| Some x_value ⇒
let? '(node_value, ctxt) :=
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_data_aux)
ctxt 0 mode value_type x_value in
return? ((Some node_value), ctxt)
end in
let diff_item :=
{| Lazy_storage_kind.Big_map.update.key := key_value;
Lazy_storage_kind.Big_map.update.key_hash := key_hash;
Lazy_storage_kind.Big_map.update.value := value_value; |} in
return? ((cons diff_item acc_value), ctxt)) (nil, ctxt)
(List.rev pairs) in
return?
((Alpha_context.Lazy_storage.Update
{| Alpha_context.Lazy_storage.diff.Update.init := init_value;
Alpha_context.Lazy_storage.diff.Update.updates := updates; |}), id, ctxt).
Definition diff_of_sapling_state
(ctxt : Alpha_context.context) (temporary : bool)
(ids_to_copy : Alpha_context.Lazy_storage.IdSet.t)
(function_parameter : Alpha_context.Sapling.state)
: M?
(Alpha_context.Lazy_storage.diff Alpha_context.Sapling.Id.t
Alpha_context.Sapling.alloc Alpha_context.Sapling.diff ×
Alpha_context.Sapling.Id.t × Alpha_context.context) :=
let '{|
Alpha_context.Sapling.state.id := id;
Alpha_context.Sapling.state.diff := diff_value;
Alpha_context.Sapling.state.memo_size := memo_size
|} := function_parameter in
let? '(ctxt, init_value, id) :=
match id with
| Some id ⇒
if
Alpha_context.Lazy_storage.IdSet.mem
Alpha_context.Lazy_storage.Kind.Sapling_state id ids_to_copy
then
let? '(ctxt, duplicate) := Alpha_context.Sapling.fresh temporary ctxt in
return?
(ctxt,
(Alpha_context.Lazy_storage.Copy
{| Alpha_context.Lazy_storage.init.Copy.src := id; |}), duplicate)
else
return? (ctxt, Alpha_context.Lazy_storage.Existing, id)
| None ⇒
let? '(ctxt, id) := Alpha_context.Sapling.fresh temporary ctxt in
return?
(ctxt,
(Alpha_context.Lazy_storage.Alloc
{| Lazy_storage_kind.Sapling_state.alloc.memo_size := memo_size; |}),
id)
end in
return?
((Alpha_context.Lazy_storage.Update
{| Alpha_context.Lazy_storage.diff.Update.init := init_value;
Alpha_context.Lazy_storage.diff.Update.updates := diff_value; |}), id,
ctxt).
Inductive has_lazy_storage : Set :=
| Big_map_f : has_lazy_storage
| Sapling_state_f : has_lazy_storage
| False_f : has_lazy_storage
| Pair_f : has_lazy_storage → has_lazy_storage → has_lazy_storage
| Union_f : has_lazy_storage → has_lazy_storage → has_lazy_storage
| Option_f : has_lazy_storage → has_lazy_storage
| List_f : has_lazy_storage → has_lazy_storage
| Map_f : has_lazy_storage → has_lazy_storage.
This function is called only on storage and parameter types of contracts,
once per typechecked contract. It has a complexity linear in the size of
the types, which happen to be literally written types, so the gas for them
has already been paid.
Fixpoint has_lazy_storage_value (ty_value : Script_typed_ir.ty)
: has_lazy_storage :=
let aux1
(cons_value : has_lazy_storage → has_lazy_storage)
(t_value : Script_typed_ir.ty) : has_lazy_storage :=
match has_lazy_storage_value t_value with
| False_f ⇒ False_f
| h_value ⇒ cons_value h_value
end in
let aux2
(cons_value : has_lazy_storage → has_lazy_storage → has_lazy_storage)
(t1 : Script_typed_ir.ty) (t2 : Script_typed_ir.ty) : has_lazy_storage :=
match ((has_lazy_storage_value t1), (has_lazy_storage_value t2)) with
| (False_f, False_f) ⇒ False_f
| (h1, h2) ⇒ cons_value h1 h2
end in
match ty_value with
| Script_typed_ir.Big_map_t _ _ _ ⇒ Big_map_f
| Script_typed_ir.Sapling_state_t _ ⇒ Sapling_state_f
| Script_typed_ir.Unit_t ⇒ False_f
| Script_typed_ir.Int_t ⇒ False_f
| Script_typed_ir.Nat_t ⇒ False_f
| Script_typed_ir.Signature_t ⇒ False_f
| Script_typed_ir.String_t ⇒ False_f
| Script_typed_ir.Bytes_t ⇒ False_f
| Script_typed_ir.Mutez_t ⇒ False_f
| Script_typed_ir.Key_hash_t ⇒ False_f
| Script_typed_ir.Key_t ⇒ False_f
| Script_typed_ir.Timestamp_t ⇒ False_f
| Script_typed_ir.Address_t ⇒ False_f
| Script_typed_ir.Tx_rollup_l2_address_t ⇒ False_f
| Script_typed_ir.Bool_t ⇒ False_f
| Script_typed_ir.Lambda_t _ _ _ ⇒ False_f
| Script_typed_ir.Set_t _ _ ⇒ False_f
| Script_typed_ir.Contract_t _ _ ⇒ False_f
| Script_typed_ir.Operation_t ⇒ False_f
| Script_typed_ir.Chain_id_t ⇒ False_f
| Script_typed_ir.Never_t ⇒ False_f
| Script_typed_ir.Bls12_381_g1_t ⇒ False_f
| Script_typed_ir.Bls12_381_g2_t ⇒ False_f
| Script_typed_ir.Bls12_381_fr_t ⇒ False_f
| Script_typed_ir.Sapling_transaction_t _ ⇒ False_f
| Script_typed_ir.Sapling_transaction_deprecated_t _ ⇒ False_f
| Script_typed_ir.Ticket_t _ _ ⇒ False_f
| Script_typed_ir.Chest_key_t ⇒ False_f
| Script_typed_ir.Chest_t ⇒ False_f
| Script_typed_ir.Pair_t l_value r_value _ _ ⇒
aux2
(fun (l_value : has_lazy_storage) ⇒
fun (r_value : has_lazy_storage) ⇒ Pair_f l_value r_value) l_value
r_value
| Script_typed_ir.Union_t l_value r_value _ _ ⇒
aux2
(fun (l_value : has_lazy_storage) ⇒
fun (r_value : has_lazy_storage) ⇒ Union_f l_value r_value) l_value
r_value
| Script_typed_ir.Option_t t_value _ _ ⇒
aux1 (fun (h_value : has_lazy_storage) ⇒ Option_f h_value) t_value
| Script_typed_ir.List_t t_value _ ⇒
aux1 (fun (h_value : has_lazy_storage) ⇒ List_f h_value) t_value
| Script_typed_ir.Map_t _ t_value _ ⇒
aux1 (fun (h_value : has_lazy_storage) ⇒ Map_f h_value) t_value
end.
: has_lazy_storage :=
let aux1
(cons_value : has_lazy_storage → has_lazy_storage)
(t_value : Script_typed_ir.ty) : has_lazy_storage :=
match has_lazy_storage_value t_value with
| False_f ⇒ False_f
| h_value ⇒ cons_value h_value
end in
let aux2
(cons_value : has_lazy_storage → has_lazy_storage → has_lazy_storage)
(t1 : Script_typed_ir.ty) (t2 : Script_typed_ir.ty) : has_lazy_storage :=
match ((has_lazy_storage_value t1), (has_lazy_storage_value t2)) with
| (False_f, False_f) ⇒ False_f
| (h1, h2) ⇒ cons_value h1 h2
end in
match ty_value with
| Script_typed_ir.Big_map_t _ _ _ ⇒ Big_map_f
| Script_typed_ir.Sapling_state_t _ ⇒ Sapling_state_f
| Script_typed_ir.Unit_t ⇒ False_f
| Script_typed_ir.Int_t ⇒ False_f
| Script_typed_ir.Nat_t ⇒ False_f
| Script_typed_ir.Signature_t ⇒ False_f
| Script_typed_ir.String_t ⇒ False_f
| Script_typed_ir.Bytes_t ⇒ False_f
| Script_typed_ir.Mutez_t ⇒ False_f
| Script_typed_ir.Key_hash_t ⇒ False_f
| Script_typed_ir.Key_t ⇒ False_f
| Script_typed_ir.Timestamp_t ⇒ False_f
| Script_typed_ir.Address_t ⇒ False_f
| Script_typed_ir.Tx_rollup_l2_address_t ⇒ False_f
| Script_typed_ir.Bool_t ⇒ False_f
| Script_typed_ir.Lambda_t _ _ _ ⇒ False_f
| Script_typed_ir.Set_t _ _ ⇒ False_f
| Script_typed_ir.Contract_t _ _ ⇒ False_f
| Script_typed_ir.Operation_t ⇒ False_f
| Script_typed_ir.Chain_id_t ⇒ False_f
| Script_typed_ir.Never_t ⇒ False_f
| Script_typed_ir.Bls12_381_g1_t ⇒ False_f
| Script_typed_ir.Bls12_381_g2_t ⇒ False_f
| Script_typed_ir.Bls12_381_fr_t ⇒ False_f
| Script_typed_ir.Sapling_transaction_t _ ⇒ False_f
| Script_typed_ir.Sapling_transaction_deprecated_t _ ⇒ False_f
| Script_typed_ir.Ticket_t _ _ ⇒ False_f
| Script_typed_ir.Chest_key_t ⇒ False_f
| Script_typed_ir.Chest_t ⇒ False_f
| Script_typed_ir.Pair_t l_value r_value _ _ ⇒
aux2
(fun (l_value : has_lazy_storage) ⇒
fun (r_value : has_lazy_storage) ⇒ Pair_f l_value r_value) l_value
r_value
| Script_typed_ir.Union_t l_value r_value _ _ ⇒
aux2
(fun (l_value : has_lazy_storage) ⇒
fun (r_value : has_lazy_storage) ⇒ Union_f l_value r_value) l_value
r_value
| Script_typed_ir.Option_t t_value _ _ ⇒
aux1 (fun (h_value : has_lazy_storage) ⇒ Option_f h_value) t_value
| Script_typed_ir.List_t t_value _ ⇒
aux1 (fun (h_value : has_lazy_storage) ⇒ List_f h_value) t_value
| Script_typed_ir.Map_t _ t_value _ ⇒
aux1 (fun (h_value : has_lazy_storage) ⇒ Map_f h_value) t_value
end.
Transforms a value potentially containing lazy storage in an intermediary
state to a value containing lazy storage only represented by identifiers.
Returns the updated value, the updated set of ids to copy, and the lazy
storage diff to show on the receipt and apply on the storage.
#[bypass_check(guard)]
Definition extract_lazy_storage_updates {A : Set}
(ctxt : Alpha_context.context) (mode : Script_ir_unparser.unparsing_mode)
(temporary : bool) (ids_to_copy : Alpha_context.Lazy_storage.IdSet.t)
(acc_value : Alpha_context.Lazy_storage.diffs) (ty_value : Script_typed_ir.ty)
(x_value : A)
: M?
(Alpha_context.context × A × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs) :=
let fix aux {a : Set}
(ctxt : Alpha_context.context) (mode : Script_ir_unparser.unparsing_mode)
(temporary : bool) (ids_to_copy : Alpha_context.Lazy_storage.IdSet.t)
(acc_value : Alpha_context.Lazy_storage.diffs)
(ty_value : Script_typed_ir.ty) (x_value : a)
(has_lazy_storage_value : has_lazy_storage) {struct has_lazy_storage_value}
: M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs) :=
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle in
match (has_lazy_storage_value, ty_value, x_value) with
| (False_f, _, _) ⇒
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
((return? (ctxt, x_value, ids_to_copy, acc_value)) :
M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
| (Big_map_f, Script_typed_ir.Big_map_t _ _ _, map) ⇒
let map := cast Script_typed_ir.big_map map in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
(let? '(diff_value, id, ctxt) :=
diff_of_big_map ctxt mode temporary ids_to_copy map in
let map :=
let 'Script_typed_ir.Big_map map := map in
Script_typed_ir.Big_map
(Script_typed_ir.big_map.Big_map.with_diff
{|
Script_typed_ir.big_map_overlay.map :=
Script_typed_ir.Big_map_overlay.(Map.S.empty);
Script_typed_ir.big_map_overlay.size := 0; |}
(Script_typed_ir.big_map.Big_map.with_id (Some id) map)) in
let diff_value :=
Alpha_context.Lazy_storage.make Alpha_context.Lazy_storage.Kind.Big_map
id diff_value in
let ids_to_copy :=
Alpha_context.Lazy_storage.IdSet.add
Alpha_context.Lazy_storage.Kind.Big_map id ids_to_copy in
return? (ctxt, map, ids_to_copy, (cons diff_value acc_value)))
| (Sapling_state_f, Script_typed_ir.Sapling_state_t _, sapling_state) ⇒
let sapling_state := cast Alpha_context.Sapling.state sapling_state in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
(let? '(diff_value, id, ctxt) :=
diff_of_sapling_state ctxt temporary ids_to_copy sapling_state in
let sapling_state :=
Alpha_context.Sapling.empty_state (Some id)
sapling_state.(Alpha_context.Sapling.state.memo_size) tt in
let diff_value :=
Alpha_context.Lazy_storage.make
Alpha_context.Lazy_storage.Kind.Sapling_state id diff_value in
let ids_to_copy :=
Alpha_context.Lazy_storage.IdSet.add
Alpha_context.Lazy_storage.Kind.Sapling_state id ids_to_copy in
return? (ctxt, sapling_state, ids_to_copy, (cons diff_value acc_value)))
| (Pair_f hl hr, Script_typed_ir.Pair_t tyl tyr _ _, x_value) ⇒
let 'existT _ [__2, __3] [x_value, tyr, tyl, hr, hl] :=
cast_exists (Es := [Set ** Set])
(fun '[__2, __3] ⇒
[__2 × __3 ** Script_typed_ir.ty ** Script_typed_ir.ty **
has_lazy_storage ** has_lazy_storage]) [x_value, tyr, tyl, hr, hl]
in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
(let '(xl, xr) := x_value in
let? '(ctxt, xl, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value tyl xl hl in
let? '(ctxt, xr, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value tyr xr hr in
return? (ctxt, (xl, xr), ids_to_copy, acc_value))
|
(Union_f has_lazy_storage_l has_lazy_storage_r,
Script_typed_ir.Union_t tyl tyr _ _, x_value) ⇒
let 'existT _ [__4, __5]
[x_value, tyr, tyl, has_lazy_storage_r, has_lazy_storage_l] :=
cast_exists (Es := [Set ** Set])
(fun '[__4, __5] ⇒
[Script_typed_ir.union __4 __5 ** Script_typed_ir.ty **
Script_typed_ir.ty ** has_lazy_storage ** has_lazy_storage])
[x_value, tyr, tyl, has_lazy_storage_r, has_lazy_storage_l] in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
match x_value with
| Script_typed_ir.L x_value ⇒
let? '(ctxt, x_value, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value tyl x_value
has_lazy_storage_l in
return? (ctxt, (Script_typed_ir.L x_value), ids_to_copy, acc_value)
| Script_typed_ir.R x_value ⇒
let? '(ctxt, x_value, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value tyr x_value
has_lazy_storage_r in
return? (ctxt, (Script_typed_ir.R x_value), ids_to_copy, acc_value)
end
|
(Option_f has_lazy_storage_value, Script_typed_ir.Option_t ty_value _ _,
x_value) ⇒
let 'existT _ __6 [x_value, ty_value, has_lazy_storage_value] :=
cast_exists (Es := Set)
(fun __6 ⇒ [option __6 ** Script_typed_ir.ty ** has_lazy_storage])
[x_value, ty_value, has_lazy_storage_value] in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
match x_value with
| Some x_value ⇒
let? '(ctxt, x_value, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value ty_value x_value
has_lazy_storage_value in
return? (ctxt, (Some x_value), ids_to_copy, acc_value)
| None ⇒ return? (ctxt, None, ids_to_copy, acc_value)
end
|
(List_f has_lazy_storage_value, Script_typed_ir.List_t ty_value _, l_value)
⇒
let 'existT _ __7 [l_value, ty_value, has_lazy_storage_value] :=
cast_exists (Es := Set)
(fun __7 ⇒
[Script_list.t __7 ** Script_typed_ir.ty ** has_lazy_storage])
[l_value, ty_value, has_lazy_storage_value] in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
(let? '(ctxt, l_value, ids_to_copy, acc_value) :=
List.fold_left_es
(fun (function_parameter :
Alpha_context.context × Script_list.t __7 ×
Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs) ⇒
let '(ctxt, l_value, ids_to_copy, acc_value) := function_parameter
in
fun (x_value : __7) ⇒
let? '(ctxt, x_value, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value ty_value x_value
has_lazy_storage_value in
return?
(ctxt, (Script_list.cons_value x_value l_value), ids_to_copy,
acc_value)) (ctxt, Script_list.empty, ids_to_copy, acc_value)
l_value.(Script_list.t.elements) in
let reversed := Script_list.rev l_value in
return? (ctxt, reversed, ids_to_copy, acc_value))
| (Map_f has_lazy_storage_value, Script_typed_ir.Map_t _ ty_value _, map) ⇒
let 'existT _ [__8, __9] [map, ty_value, has_lazy_storage_value] :=
cast_exists (Es := [Set ** Set])
(fun '[__8, __9] ⇒
[Script_typed_ir.map __8 __9 ** Script_typed_ir.ty **
has_lazy_storage]) [map, ty_value, has_lazy_storage_value] in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
(let M := Script_map.get_module map in
let 'existS _ _ M := M in
let bindings {C : Set}
(m_value :
M.(Script_typed_ir.Boxed_map.OPS).(Script_typed_ir.Boxed_map_OPS.t) C)
: list (__8 × C) :=
M.(Script_typed_ir.Boxed_map.OPS).(Script_typed_ir.Boxed_map_OPS.fold)
(fun (k_value : __8) ⇒
fun (v_value : C) ⇒
fun (bs : list (__8 × C)) ⇒ cons (k_value, v_value) bs) m_value
nil in
let? '(ctxt, m_value, ids_to_copy, acc_value) :=
List.fold_left_es
(fun (function_parameter :
Alpha_context.context ×
M.(Script_typed_ir.Boxed_map.OPS).(Script_typed_ir.Boxed_map_OPS.t)
__9 × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs) ⇒
let '(ctxt, m_value, ids_to_copy, acc_value) := function_parameter
in
fun (function_parameter : __8 × __9) ⇒
let '(k_value, x_value) := function_parameter in
let? '(ctxt, x_value, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value ty_value x_value
has_lazy_storage_value in
return?
(ctxt,
(M.(Script_typed_ir.Boxed_map.OPS).(Script_typed_ir.Boxed_map_OPS.add)
k_value x_value m_value), ids_to_copy, acc_value))
(ctxt,
M.(Script_typed_ir.Boxed_map.OPS).(Script_typed_ir.Boxed_map_OPS.empty),
ids_to_copy, acc_value)
(bindings M.(Script_typed_ir.Boxed_map.boxed)) in
let M :=
let OPS := M.(Script_typed_ir.Boxed_map.OPS) in
let key : Set := __8 in
let value : Set := __9 in
let boxed := m_value in
let size_value := M.(Script_typed_ir.Boxed_map.size_value) in
let boxed_map_tag := tt in
{|
Script_typed_ir.Boxed_map.OPS := OPS;
Script_typed_ir.Boxed_map.boxed := boxed;
Script_typed_ir.Boxed_map.size_value := size_value;
Script_typed_ir.Boxed_map.boxed_map_tag := boxed_map_tag
|} in
return?
(ctxt, (Script_map.make (existS (A := Set → Set) _ _ M)), ids_to_copy,
acc_value))
| _ ⇒ unreachable_gadt_branch
end in
let has_lazy_storage_value := has_lazy_storage_value ty_value in
aux ctxt mode temporary ids_to_copy acc_value ty_value x_value
has_lazy_storage_value.
Definition extract_lazy_storage_updates {A : Set}
(ctxt : Alpha_context.context) (mode : Script_ir_unparser.unparsing_mode)
(temporary : bool) (ids_to_copy : Alpha_context.Lazy_storage.IdSet.t)
(acc_value : Alpha_context.Lazy_storage.diffs) (ty_value : Script_typed_ir.ty)
(x_value : A)
: M?
(Alpha_context.context × A × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs) :=
let fix aux {a : Set}
(ctxt : Alpha_context.context) (mode : Script_ir_unparser.unparsing_mode)
(temporary : bool) (ids_to_copy : Alpha_context.Lazy_storage.IdSet.t)
(acc_value : Alpha_context.Lazy_storage.diffs)
(ty_value : Script_typed_ir.ty) (x_value : a)
(has_lazy_storage_value : has_lazy_storage) {struct has_lazy_storage_value}
: M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs) :=
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle in
match (has_lazy_storage_value, ty_value, x_value) with
| (False_f, _, _) ⇒
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
((return? (ctxt, x_value, ids_to_copy, acc_value)) :
M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
| (Big_map_f, Script_typed_ir.Big_map_t _ _ _, map) ⇒
let map := cast Script_typed_ir.big_map map in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
(let? '(diff_value, id, ctxt) :=
diff_of_big_map ctxt mode temporary ids_to_copy map in
let map :=
let 'Script_typed_ir.Big_map map := map in
Script_typed_ir.Big_map
(Script_typed_ir.big_map.Big_map.with_diff
{|
Script_typed_ir.big_map_overlay.map :=
Script_typed_ir.Big_map_overlay.(Map.S.empty);
Script_typed_ir.big_map_overlay.size := 0; |}
(Script_typed_ir.big_map.Big_map.with_id (Some id) map)) in
let diff_value :=
Alpha_context.Lazy_storage.make Alpha_context.Lazy_storage.Kind.Big_map
id diff_value in
let ids_to_copy :=
Alpha_context.Lazy_storage.IdSet.add
Alpha_context.Lazy_storage.Kind.Big_map id ids_to_copy in
return? (ctxt, map, ids_to_copy, (cons diff_value acc_value)))
| (Sapling_state_f, Script_typed_ir.Sapling_state_t _, sapling_state) ⇒
let sapling_state := cast Alpha_context.Sapling.state sapling_state in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
(let? '(diff_value, id, ctxt) :=
diff_of_sapling_state ctxt temporary ids_to_copy sapling_state in
let sapling_state :=
Alpha_context.Sapling.empty_state (Some id)
sapling_state.(Alpha_context.Sapling.state.memo_size) tt in
let diff_value :=
Alpha_context.Lazy_storage.make
Alpha_context.Lazy_storage.Kind.Sapling_state id diff_value in
let ids_to_copy :=
Alpha_context.Lazy_storage.IdSet.add
Alpha_context.Lazy_storage.Kind.Sapling_state id ids_to_copy in
return? (ctxt, sapling_state, ids_to_copy, (cons diff_value acc_value)))
| (Pair_f hl hr, Script_typed_ir.Pair_t tyl tyr _ _, x_value) ⇒
let 'existT _ [__2, __3] [x_value, tyr, tyl, hr, hl] :=
cast_exists (Es := [Set ** Set])
(fun '[__2, __3] ⇒
[__2 × __3 ** Script_typed_ir.ty ** Script_typed_ir.ty **
has_lazy_storage ** has_lazy_storage]) [x_value, tyr, tyl, hr, hl]
in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
(let '(xl, xr) := x_value in
let? '(ctxt, xl, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value tyl xl hl in
let? '(ctxt, xr, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value tyr xr hr in
return? (ctxt, (xl, xr), ids_to_copy, acc_value))
|
(Union_f has_lazy_storage_l has_lazy_storage_r,
Script_typed_ir.Union_t tyl tyr _ _, x_value) ⇒
let 'existT _ [__4, __5]
[x_value, tyr, tyl, has_lazy_storage_r, has_lazy_storage_l] :=
cast_exists (Es := [Set ** Set])
(fun '[__4, __5] ⇒
[Script_typed_ir.union __4 __5 ** Script_typed_ir.ty **
Script_typed_ir.ty ** has_lazy_storage ** has_lazy_storage])
[x_value, tyr, tyl, has_lazy_storage_r, has_lazy_storage_l] in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
match x_value with
| Script_typed_ir.L x_value ⇒
let? '(ctxt, x_value, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value tyl x_value
has_lazy_storage_l in
return? (ctxt, (Script_typed_ir.L x_value), ids_to_copy, acc_value)
| Script_typed_ir.R x_value ⇒
let? '(ctxt, x_value, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value tyr x_value
has_lazy_storage_r in
return? (ctxt, (Script_typed_ir.R x_value), ids_to_copy, acc_value)
end
|
(Option_f has_lazy_storage_value, Script_typed_ir.Option_t ty_value _ _,
x_value) ⇒
let 'existT _ __6 [x_value, ty_value, has_lazy_storage_value] :=
cast_exists (Es := Set)
(fun __6 ⇒ [option __6 ** Script_typed_ir.ty ** has_lazy_storage])
[x_value, ty_value, has_lazy_storage_value] in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
match x_value with
| Some x_value ⇒
let? '(ctxt, x_value, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value ty_value x_value
has_lazy_storage_value in
return? (ctxt, (Some x_value), ids_to_copy, acc_value)
| None ⇒ return? (ctxt, None, ids_to_copy, acc_value)
end
|
(List_f has_lazy_storage_value, Script_typed_ir.List_t ty_value _, l_value)
⇒
let 'existT _ __7 [l_value, ty_value, has_lazy_storage_value] :=
cast_exists (Es := Set)
(fun __7 ⇒
[Script_list.t __7 ** Script_typed_ir.ty ** has_lazy_storage])
[l_value, ty_value, has_lazy_storage_value] in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
(let? '(ctxt, l_value, ids_to_copy, acc_value) :=
List.fold_left_es
(fun (function_parameter :
Alpha_context.context × Script_list.t __7 ×
Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs) ⇒
let '(ctxt, l_value, ids_to_copy, acc_value) := function_parameter
in
fun (x_value : __7) ⇒
let? '(ctxt, x_value, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value ty_value x_value
has_lazy_storage_value in
return?
(ctxt, (Script_list.cons_value x_value l_value), ids_to_copy,
acc_value)) (ctxt, Script_list.empty, ids_to_copy, acc_value)
l_value.(Script_list.t.elements) in
let reversed := Script_list.rev l_value in
return? (ctxt, reversed, ids_to_copy, acc_value))
| (Map_f has_lazy_storage_value, Script_typed_ir.Map_t _ ty_value _, map) ⇒
let 'existT _ [__8, __9] [map, ty_value, has_lazy_storage_value] :=
cast_exists (Es := [Set ** Set])
(fun '[__8, __9] ⇒
[Script_typed_ir.map __8 __9 ** Script_typed_ir.ty **
has_lazy_storage]) [map, ty_value, has_lazy_storage_value] in
cast
(M?
(Alpha_context.context × a × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs))
(let M := Script_map.get_module map in
let 'existS _ _ M := M in
let bindings {C : Set}
(m_value :
M.(Script_typed_ir.Boxed_map.OPS).(Script_typed_ir.Boxed_map_OPS.t) C)
: list (__8 × C) :=
M.(Script_typed_ir.Boxed_map.OPS).(Script_typed_ir.Boxed_map_OPS.fold)
(fun (k_value : __8) ⇒
fun (v_value : C) ⇒
fun (bs : list (__8 × C)) ⇒ cons (k_value, v_value) bs) m_value
nil in
let? '(ctxt, m_value, ids_to_copy, acc_value) :=
List.fold_left_es
(fun (function_parameter :
Alpha_context.context ×
M.(Script_typed_ir.Boxed_map.OPS).(Script_typed_ir.Boxed_map_OPS.t)
__9 × Alpha_context.Lazy_storage.IdSet.t ×
Alpha_context.Lazy_storage.diffs) ⇒
let '(ctxt, m_value, ids_to_copy, acc_value) := function_parameter
in
fun (function_parameter : __8 × __9) ⇒
let '(k_value, x_value) := function_parameter in
let? '(ctxt, x_value, ids_to_copy, acc_value) :=
aux ctxt mode temporary ids_to_copy acc_value ty_value x_value
has_lazy_storage_value in
return?
(ctxt,
(M.(Script_typed_ir.Boxed_map.OPS).(Script_typed_ir.Boxed_map_OPS.add)
k_value x_value m_value), ids_to_copy, acc_value))
(ctxt,
M.(Script_typed_ir.Boxed_map.OPS).(Script_typed_ir.Boxed_map_OPS.empty),
ids_to_copy, acc_value)
(bindings M.(Script_typed_ir.Boxed_map.boxed)) in
let M :=
let OPS := M.(Script_typed_ir.Boxed_map.OPS) in
let key : Set := __8 in
let value : Set := __9 in
let boxed := m_value in
let size_value := M.(Script_typed_ir.Boxed_map.size_value) in
let boxed_map_tag := tt in
{|
Script_typed_ir.Boxed_map.OPS := OPS;
Script_typed_ir.Boxed_map.boxed := boxed;
Script_typed_ir.Boxed_map.size_value := size_value;
Script_typed_ir.Boxed_map.boxed_map_tag := boxed_map_tag
|} in
return?
(ctxt, (Script_map.make (existS (A := Set → Set) _ _ M)), ids_to_copy,
acc_value))
| _ ⇒ unreachable_gadt_branch
end in
let has_lazy_storage_value := has_lazy_storage_value ty_value in
aux ctxt mode temporary ids_to_copy acc_value ty_value x_value
has_lazy_storage_value.
We namespace an error type for [fold_lazy_storage]. The error case is only
available when the ['error] parameter is equal to unit.
Module Fold_lazy_storage.
Inductive result (acc : Set) : Set :=
| Ok : acc → result acc
| Error : result acc.
Arguments Ok {_}.
Arguments Error {_}.
End Fold_lazy_storage.
Inductive result (acc : Set) : Set :=
| Ok : acc → result acc
| Error : result acc.
Arguments Ok {_}.
Arguments Error {_}.
End Fold_lazy_storage.
Prematurely abort if [f] generates an error. Use this function without the
[unit] type for [error] if you are in a case where errors are impossible.
#[bypass_check(guard)]
Fixpoint fold_lazy_storage {acc a : Set}
(f_value :
Alpha_context.Lazy_storage.IdSet.fold_f (Fold_lazy_storage.result acc))
(init_value : acc) (ctxt : Alpha_context.context)
(ty_value : Script_typed_ir.ty) (x_value : a)
(has_lazy_storage_value : has_lazy_storage) {struct has_lazy_storage_value}
: M? (Fold_lazy_storage.result acc × Alpha_context.context) :=
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle
in
match (has_lazy_storage_value, ty_value, x_value) with
| (Big_map_f, Script_typed_ir.Big_map_t _ _ _, x_value) ⇒
let x_value := cast Script_typed_ir.big_map x_value in
match x_value with
|
Script_typed_ir.Big_map {|
Script_typed_ir.big_map.Big_map.id := Some id |} ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle in
return?
((f_value.(Alpha_context.Lazy_storage.IdSet.fold_f.f)
Alpha_context.Lazy_storage.Kind.Big_map id
(Fold_lazy_storage.Ok init_value)), ctxt)
| Script_typed_ir.Big_map {| Script_typed_ir.big_map.Big_map.id := None |}
⇒ return? ((Fold_lazy_storage.Ok init_value), ctxt)
end
| (Sapling_state_f, Script_typed_ir.Sapling_state_t _, x_value) ⇒
let x_value := cast Alpha_context.Sapling.state x_value in
match x_value with
| {| Alpha_context.Sapling.state.id := Some id |} ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle in
return?
((f_value.(Alpha_context.Lazy_storage.IdSet.fold_f.f)
Alpha_context.Lazy_storage.Kind.Sapling_state id
(Fold_lazy_storage.Ok init_value)), ctxt)
| {| Alpha_context.Sapling.state.id := None |} ⇒
return? ((Fold_lazy_storage.Ok init_value), ctxt)
end
| (False_f, _, _) ⇒ return? ((Fold_lazy_storage.Ok init_value), ctxt)
| (Pair_f hl hr, Script_typed_ir.Pair_t tyl tyr _ _, x_value) ⇒
let 'existT _ [__2, __3] [x_value, tyr, tyl, hr, hl] :=
cast_exists (Es := [Set ** Set])
(fun '[__2, __3] ⇒
[Script_typed_ir.pair __2 __3 ** Script_typed_ir.ty **
Script_typed_ir.ty ** has_lazy_storage ** has_lazy_storage])
[x_value, tyr, tyl, hr, hl] in
let '(xl, xr) := x_value in
let? '(init_value, ctxt) :=
fold_lazy_storage f_value init_value ctxt tyl xl hl in
match init_value with
| Fold_lazy_storage.Ok init_value ⇒
fold_lazy_storage f_value init_value ctxt tyr xr hr
| Fold_lazy_storage.Error ⇒ return? (init_value, ctxt)
end
|
(Union_f has_lazy_storage_l has_lazy_storage_r,
Script_typed_ir.Union_t tyl tyr _ _, x_value) ⇒
let 'existT _ [__4, __5]
[x_value, tyr, tyl, has_lazy_storage_r, has_lazy_storage_l] :=
cast_exists (Es := [Set ** Set])
(fun '[__4, __5] ⇒
[Script_typed_ir.union __4 __5 ** Script_typed_ir.ty **
Script_typed_ir.ty ** has_lazy_storage ** has_lazy_storage])
[x_value, tyr, tyl, has_lazy_storage_r, has_lazy_storage_l] in
match x_value with
| Script_typed_ir.L x_value ⇒
fold_lazy_storage f_value init_value ctxt tyl x_value has_lazy_storage_l
| Script_typed_ir.R x_value ⇒
fold_lazy_storage f_value init_value ctxt tyr x_value has_lazy_storage_r
end
|
(Option_f has_lazy_storage_value, Script_typed_ir.Option_t ty_value _ _,
x_value) ⇒
let 'existT _ __6 [x_value, ty_value, has_lazy_storage_value] :=
cast_exists (Es := Set)
(fun __6 ⇒ [option __6 ** Script_typed_ir.ty ** has_lazy_storage])
[x_value, ty_value, has_lazy_storage_value] in
match x_value with
| Some x_value ⇒
fold_lazy_storage f_value init_value ctxt ty_value x_value
has_lazy_storage_value
| None ⇒ return? ((Fold_lazy_storage.Ok init_value), ctxt)
end
| (List_f has_lazy_storage_value, Script_typed_ir.List_t ty_value _, l_value)
⇒
let 'existT _ __7 [l_value, ty_value, has_lazy_storage_value] :=
cast_exists (Es := Set)
(fun __7 ⇒
[Script_list.t __7 ** Script_typed_ir.ty ** has_lazy_storage])
[l_value, ty_value, has_lazy_storage_value] in
List.fold_left_e
(fun (function_parameter :
Fold_lazy_storage.result acc × Alpha_context.context) ⇒
let '(init_value, ctxt) := function_parameter in
fun (x_value : __7) ⇒
match init_value with
| Fold_lazy_storage.Ok init_value ⇒
fold_lazy_storage f_value init_value ctxt ty_value x_value
has_lazy_storage_value
| Fold_lazy_storage.Error ⇒ return? (init_value, ctxt)
end) ((Fold_lazy_storage.Ok init_value), ctxt)
l_value.(Script_list.t.elements)
| (Map_f has_lazy_storage_value, Script_typed_ir.Map_t _ ty_value _, m_value)
⇒
let 'existT _ [__8, __9] [m_value, ty_value, has_lazy_storage_value] :=
cast_exists (Es := [Set ** Set])
(fun '[__8, __9] ⇒
[Script_typed_ir.map __8 __9 ** Script_typed_ir.ty **
has_lazy_storage]) [m_value, ty_value, has_lazy_storage_value] in
Script_map.fold
(fun (function_parameter : __8) ⇒
let '_ := function_parameter in
fun (v_value : __9) ⇒
fun (acc_value :
M? (Fold_lazy_storage.result acc × Alpha_context.context)) ⇒
let? '(init_value, ctxt) := acc_value in
match init_value with
| Fold_lazy_storage.Ok init_value ⇒
fold_lazy_storage f_value init_value ctxt ty_value v_value
has_lazy_storage_value
| Fold_lazy_storage.Error ⇒ return? (init_value, ctxt)
end) m_value (return? ((Fold_lazy_storage.Ok init_value), ctxt))
| _ ⇒ unreachable_gadt_branch
end.
Definition collect_lazy_storage {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty) (x_value : A)
: M? (Alpha_context.Lazy_storage.IdSet.t × Alpha_context.context) :=
let has_lazy_storage_value := has_lazy_storage_value ty_value in
let f_value {B : Set}
(kind_value : Alpha_context.Lazy_storage.Kind.t) (id : B)
(acc_value : Fold_lazy_storage.result Alpha_context.Lazy_storage.IdSet.t)
: Fold_lazy_storage.result Alpha_context.Lazy_storage.IdSet.t :=
let acc_value :=
match acc_value with
| Fold_lazy_storage.Ok acc_value ⇒ acc_value
| _ ⇒ unreachable_gadt_branch
end in
Fold_lazy_storage.Ok
(Alpha_context.Lazy_storage.IdSet.add kind_value id acc_value) in
let? '(ids, ctxt) :=
fold_lazy_storage
{| Alpha_context.Lazy_storage.IdSet.fold_f.f _ := f_value; |}
no_lazy_storage_id ctxt ty_value x_value has_lazy_storage_value in
match ids with
| Fold_lazy_storage.Ok ids ⇒ return? (ids, ctxt)
| _ ⇒ unreachable_gadt_branch
end.
Definition extract_lazy_storage_diff {A : Set}
(ctxt : Alpha_context.context) (mode : Script_ir_unparser.unparsing_mode)
(temporary : bool) (to_duplicate : Alpha_context.Lazy_storage.IdSet.t)
(to_update : Alpha_context.Lazy_storage.IdSet.t)
(ty_value : Script_typed_ir.ty) (v_value : A)
: M? (A × option Alpha_context.Lazy_storage.diffs × Alpha_context.context) :=
let to_duplicate :=
Alpha_context.Lazy_storage.IdSet.diff_value to_duplicate to_update in
let? '(ctxt, v_value, alive, diffs) :=
extract_lazy_storage_updates ctxt mode temporary to_duplicate nil ty_value
v_value in
let diffs :=
if temporary then
diffs
else
let dead := Alpha_context.Lazy_storage.IdSet.diff_value to_update alive in
let f_value {B : Set}
(kind_value : Alpha_context.Lazy_storage.Kind.t) (id : B)
(acc_value : list Alpha_context.Lazy_storage.diffs_item)
: list Alpha_context.Lazy_storage.diffs_item :=
cons
((Alpha_context.Lazy_storage.make (a := unit) (u := unit)) kind_value
id Alpha_context.Lazy_storage.Remove) acc_value in
Alpha_context.Lazy_storage.IdSet.fold_all
{| Alpha_context.Lazy_storage.IdSet.fold_f.f _ := f_value; |} dead diffs
in
match diffs with
| [] ⇒ return? (v_value, None, ctxt)
| diffs ⇒ return? (v_value, (Some diffs), ctxt)
end.
Definition list_of_big_map_ids (ids : Alpha_context.Lazy_storage.IdSet.t)
: list Alpha_context.Big_map.Id.t :=
Alpha_context.Lazy_storage.IdSet.fold Alpha_context.Lazy_storage.Kind.Big_map
(fun (id : Alpha_context.Big_map.Id.t) ⇒
fun (acc_value : list Alpha_context.Big_map.Id.t) ⇒ cons id acc_value)
ids nil.
Definition parse_data {A : Set}
: elab_conf → Alpha_context.context → bool → Script_typed_ir.ty →
Alpha_context.Script.node → M? (A × Alpha_context.context) :=
fun x_1 ⇒ parse_data_aux x_1 0.
Definition parse_comparable_data {A : Set}
(type_logger_value : option Script_ir_translator_config.type_logger)
: Alpha_context.context → Script_typed_ir.ty → Alpha_context.Script.node →
M? (A × Alpha_context.context) :=
fun x_1 ⇒
parse_data
(Script_ir_translator_config.make type_logger_value None false tt) x_1
false.
Definition parse_instr
(elab_conf : elab_conf) (tc_context_value : tc_context)
(ctxt : Alpha_context.context) (script_instr : Alpha_context.Script.node)
(stack_ty : Script_typed_ir.stack_ty)
: M? (judgement × Alpha_context.context) :=
parse_instr_aux elab_conf 0 tc_context_value ctxt script_instr stack_ty.
Definition unparse_data {A : Set}
: Alpha_context.context → Script_ir_unparser.unparsing_mode →
Script_typed_ir.ty → A →
M? (Alpha_context.Script.expr × Alpha_context.context) :=
fun x_1 ⇒
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_data_aux)
x_1 0.
Definition unparse_code {A : Set}
(ctxt : Alpha_context.t) (mode : Script_ir_unparser.unparsing_mode)
(code : Micheline.node A Alpha_context.Script.prim)
: M? (Alpha_context.Script.expr × Alpha_context.context) :=
let? '(ctxt, code) :=
Alpha_context.Global_constants_storage.expand ctxt
(Micheline.strip_locations code) in
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_code_aux)
ctxt 0 mode (Micheline.root_value code).
Definition parse_contract_data
(context_value : Alpha_context.context)
(loc_value : Alpha_context.Script.location) (arg_ty : Script_typed_ir.ty)
(contract : Alpha_context.Destination.t)
(entrypoint : Alpha_context.Entrypoint.t)
: M? (Alpha_context.context × Script_typed_ir.typed_contract) :=
parse_contract_data_aux 0 context_value loc_value arg_ty contract entrypoint.
Definition parse_toplevel
(ctxt : Alpha_context.t) (legacy : bool)
(toplevel_value : Alpha_context.Script.expr)
: M? (toplevel × Alpha_context.context) :=
let? '(ctxt, toplevel_value) :=
Alpha_context.Global_constants_storage.expand ctxt toplevel_value in
parse_toplevel_aux ctxt legacy toplevel_value.
Definition parse_comparable_ty
: Alpha_context.context → Alpha_context.Script.node →
M? (ex_comparable_ty × Alpha_context.context) :=
fun x_1 ⇒ parse_comparable_ty_aux x_1 0.
Definition parse_big_map_value_ty
: Alpha_context.context → bool →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
fun x_1 ⇒ parse_big_map_value_ty_aux x_1 0.
Definition parse_packable_ty
: Alpha_context.context → bool → Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
fun x_1 ⇒ parse_packable_ty_aux x_1 0.
Definition parse_passable_ty
: Alpha_context.context → bool → Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
fun x_1 ⇒ parse_passable_ty_aux x_1 0.
Definition parse_any_ty
: Alpha_context.context → bool → Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
fun x_1 ⇒ parse_any_ty_aux x_1 0.
Definition parse_ty
: Alpha_context.context → bool → bool → bool → bool → bool →
Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
fun x_1 x_2 x_3 x_4 x_5 x_6 ⇒
parse_ty_aux x_1 0 x_2 x_3 x_4 x_5 x_6 Don't_parse_entrypoints.
Definition parse_parameter_ty_and_entrypoints
: Alpha_context.context → bool → Alpha_context.Script.node →
M? (ex_parameter_ty_and_entrypoints × Alpha_context.context) :=
fun x_1 ⇒ parse_parameter_ty_and_entrypoints_aux x_1 0.
Definition get_single_sapling_state {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty) (x_value : A)
: M? (option Alpha_context.Sapling.Id.t × Alpha_context.context) :=
let has_lazy_storage_value := has_lazy_storage_value ty_value in
let f_value {i : Set}
(kind_value : Alpha_context.Lazy_storage.Kind.t) (id : i)
(single_id_opt :
Fold_lazy_storage.result (option Alpha_context.Sapling.Id.t))
: Fold_lazy_storage.result (option Alpha_context.Sapling.Id.t) :=
match (kind_value, id) with
| (Alpha_context.Lazy_storage.Kind.Sapling_state, id) ⇒
let id := cast Alpha_context.Sapling.Id.t id in
match single_id_opt with
| Fold_lazy_storage.Ok None ⇒ Fold_lazy_storage.Ok (Some id)
| Fold_lazy_storage.Ok (Some _) ⇒ Fold_lazy_storage.Error
| Fold_lazy_storage.Error ⇒ single_id_opt
end
| _ ⇒ single_id_opt
end in
let? '(id, ctxt) :=
fold_lazy_storage
{| Alpha_context.Lazy_storage.IdSet.fold_f.f _ := f_value; |} None ctxt
ty_value x_value has_lazy_storage_value in
match id with
| Fold_lazy_storage.Ok (Some id) ⇒ return? ((Some id), ctxt)
| (Fold_lazy_storage.Ok None | Fold_lazy_storage.Error) ⇒
return? (None, ctxt)
end.
Definition script_size (function_parameter : ex_script)
: int × Gas_limit_repr.cost :=
let
'Ex_script
(Script_typed_ir.Script {|
Script_typed_ir.script.Script.code := _;
Script_typed_ir.script.Script.arg_type := _;
Script_typed_ir.script.Script.storage := storage_value;
Script_typed_ir.script.Script.storage_type := storage_type;
Script_typed_ir.script.Script.views := _;
Script_typed_ir.script.Script.entrypoints := _;
Script_typed_ir.script.Script.code_size := code_size
|}) := function_parameter in
let '(nodes, storage_size) :=
Script_typed_ir_size.value_size storage_type storage_value in
let cost := Script_typed_ir_size_costs.nodes_cost nodes in
((Saturation_repr.to_int (Saturation_repr.add code_size storage_size)), cost).
Definition typecheck_code
(legacy : bool) (show_types : bool) (ctxt : Alpha_context.context)
(code : Alpha_context.Script.expr)
: M? (Script_tc_errors.type_map × Alpha_context.context) :=
let?
'(Typechecked_code_internal {|
typechecked_code_internal.Typechecked_code_internal.type_map := type_map
|}, ctxt) := typecheck_code_aux legacy show_types ctxt code in
return? (type_map, ctxt).
Fixpoint fold_lazy_storage {acc a : Set}
(f_value :
Alpha_context.Lazy_storage.IdSet.fold_f (Fold_lazy_storage.result acc))
(init_value : acc) (ctxt : Alpha_context.context)
(ty_value : Script_typed_ir.ty) (x_value : a)
(has_lazy_storage_value : has_lazy_storage) {struct has_lazy_storage_value}
: M? (Fold_lazy_storage.result acc × Alpha_context.context) :=
let? ctxt := Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle
in
match (has_lazy_storage_value, ty_value, x_value) with
| (Big_map_f, Script_typed_ir.Big_map_t _ _ _, x_value) ⇒
let x_value := cast Script_typed_ir.big_map x_value in
match x_value with
|
Script_typed_ir.Big_map {|
Script_typed_ir.big_map.Big_map.id := Some id |} ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle in
return?
((f_value.(Alpha_context.Lazy_storage.IdSet.fold_f.f)
Alpha_context.Lazy_storage.Kind.Big_map id
(Fold_lazy_storage.Ok init_value)), ctxt)
| Script_typed_ir.Big_map {| Script_typed_ir.big_map.Big_map.id := None |}
⇒ return? ((Fold_lazy_storage.Ok init_value), ctxt)
end
| (Sapling_state_f, Script_typed_ir.Sapling_state_t _, x_value) ⇒
let x_value := cast Alpha_context.Sapling.state x_value in
match x_value with
| {| Alpha_context.Sapling.state.id := Some id |} ⇒
let? ctxt :=
Alpha_context.Gas.consume ctxt Typecheck_costs.parse_instr_cycle in
return?
((f_value.(Alpha_context.Lazy_storage.IdSet.fold_f.f)
Alpha_context.Lazy_storage.Kind.Sapling_state id
(Fold_lazy_storage.Ok init_value)), ctxt)
| {| Alpha_context.Sapling.state.id := None |} ⇒
return? ((Fold_lazy_storage.Ok init_value), ctxt)
end
| (False_f, _, _) ⇒ return? ((Fold_lazy_storage.Ok init_value), ctxt)
| (Pair_f hl hr, Script_typed_ir.Pair_t tyl tyr _ _, x_value) ⇒
let 'existT _ [__2, __3] [x_value, tyr, tyl, hr, hl] :=
cast_exists (Es := [Set ** Set])
(fun '[__2, __3] ⇒
[Script_typed_ir.pair __2 __3 ** Script_typed_ir.ty **
Script_typed_ir.ty ** has_lazy_storage ** has_lazy_storage])
[x_value, tyr, tyl, hr, hl] in
let '(xl, xr) := x_value in
let? '(init_value, ctxt) :=
fold_lazy_storage f_value init_value ctxt tyl xl hl in
match init_value with
| Fold_lazy_storage.Ok init_value ⇒
fold_lazy_storage f_value init_value ctxt tyr xr hr
| Fold_lazy_storage.Error ⇒ return? (init_value, ctxt)
end
|
(Union_f has_lazy_storage_l has_lazy_storage_r,
Script_typed_ir.Union_t tyl tyr _ _, x_value) ⇒
let 'existT _ [__4, __5]
[x_value, tyr, tyl, has_lazy_storage_r, has_lazy_storage_l] :=
cast_exists (Es := [Set ** Set])
(fun '[__4, __5] ⇒
[Script_typed_ir.union __4 __5 ** Script_typed_ir.ty **
Script_typed_ir.ty ** has_lazy_storage ** has_lazy_storage])
[x_value, tyr, tyl, has_lazy_storage_r, has_lazy_storage_l] in
match x_value with
| Script_typed_ir.L x_value ⇒
fold_lazy_storage f_value init_value ctxt tyl x_value has_lazy_storage_l
| Script_typed_ir.R x_value ⇒
fold_lazy_storage f_value init_value ctxt tyr x_value has_lazy_storage_r
end
|
(Option_f has_lazy_storage_value, Script_typed_ir.Option_t ty_value _ _,
x_value) ⇒
let 'existT _ __6 [x_value, ty_value, has_lazy_storage_value] :=
cast_exists (Es := Set)
(fun __6 ⇒ [option __6 ** Script_typed_ir.ty ** has_lazy_storage])
[x_value, ty_value, has_lazy_storage_value] in
match x_value with
| Some x_value ⇒
fold_lazy_storage f_value init_value ctxt ty_value x_value
has_lazy_storage_value
| None ⇒ return? ((Fold_lazy_storage.Ok init_value), ctxt)
end
| (List_f has_lazy_storage_value, Script_typed_ir.List_t ty_value _, l_value)
⇒
let 'existT _ __7 [l_value, ty_value, has_lazy_storage_value] :=
cast_exists (Es := Set)
(fun __7 ⇒
[Script_list.t __7 ** Script_typed_ir.ty ** has_lazy_storage])
[l_value, ty_value, has_lazy_storage_value] in
List.fold_left_e
(fun (function_parameter :
Fold_lazy_storage.result acc × Alpha_context.context) ⇒
let '(init_value, ctxt) := function_parameter in
fun (x_value : __7) ⇒
match init_value with
| Fold_lazy_storage.Ok init_value ⇒
fold_lazy_storage f_value init_value ctxt ty_value x_value
has_lazy_storage_value
| Fold_lazy_storage.Error ⇒ return? (init_value, ctxt)
end) ((Fold_lazy_storage.Ok init_value), ctxt)
l_value.(Script_list.t.elements)
| (Map_f has_lazy_storage_value, Script_typed_ir.Map_t _ ty_value _, m_value)
⇒
let 'existT _ [__8, __9] [m_value, ty_value, has_lazy_storage_value] :=
cast_exists (Es := [Set ** Set])
(fun '[__8, __9] ⇒
[Script_typed_ir.map __8 __9 ** Script_typed_ir.ty **
has_lazy_storage]) [m_value, ty_value, has_lazy_storage_value] in
Script_map.fold
(fun (function_parameter : __8) ⇒
let '_ := function_parameter in
fun (v_value : __9) ⇒
fun (acc_value :
M? (Fold_lazy_storage.result acc × Alpha_context.context)) ⇒
let? '(init_value, ctxt) := acc_value in
match init_value with
| Fold_lazy_storage.Ok init_value ⇒
fold_lazy_storage f_value init_value ctxt ty_value v_value
has_lazy_storage_value
| Fold_lazy_storage.Error ⇒ return? (init_value, ctxt)
end) m_value (return? ((Fold_lazy_storage.Ok init_value), ctxt))
| _ ⇒ unreachable_gadt_branch
end.
Definition collect_lazy_storage {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty) (x_value : A)
: M? (Alpha_context.Lazy_storage.IdSet.t × Alpha_context.context) :=
let has_lazy_storage_value := has_lazy_storage_value ty_value in
let f_value {B : Set}
(kind_value : Alpha_context.Lazy_storage.Kind.t) (id : B)
(acc_value : Fold_lazy_storage.result Alpha_context.Lazy_storage.IdSet.t)
: Fold_lazy_storage.result Alpha_context.Lazy_storage.IdSet.t :=
let acc_value :=
match acc_value with
| Fold_lazy_storage.Ok acc_value ⇒ acc_value
| _ ⇒ unreachable_gadt_branch
end in
Fold_lazy_storage.Ok
(Alpha_context.Lazy_storage.IdSet.add kind_value id acc_value) in
let? '(ids, ctxt) :=
fold_lazy_storage
{| Alpha_context.Lazy_storage.IdSet.fold_f.f _ := f_value; |}
no_lazy_storage_id ctxt ty_value x_value has_lazy_storage_value in
match ids with
| Fold_lazy_storage.Ok ids ⇒ return? (ids, ctxt)
| _ ⇒ unreachable_gadt_branch
end.
Definition extract_lazy_storage_diff {A : Set}
(ctxt : Alpha_context.context) (mode : Script_ir_unparser.unparsing_mode)
(temporary : bool) (to_duplicate : Alpha_context.Lazy_storage.IdSet.t)
(to_update : Alpha_context.Lazy_storage.IdSet.t)
(ty_value : Script_typed_ir.ty) (v_value : A)
: M? (A × option Alpha_context.Lazy_storage.diffs × Alpha_context.context) :=
let to_duplicate :=
Alpha_context.Lazy_storage.IdSet.diff_value to_duplicate to_update in
let? '(ctxt, v_value, alive, diffs) :=
extract_lazy_storage_updates ctxt mode temporary to_duplicate nil ty_value
v_value in
let diffs :=
if temporary then
diffs
else
let dead := Alpha_context.Lazy_storage.IdSet.diff_value to_update alive in
let f_value {B : Set}
(kind_value : Alpha_context.Lazy_storage.Kind.t) (id : B)
(acc_value : list Alpha_context.Lazy_storage.diffs_item)
: list Alpha_context.Lazy_storage.diffs_item :=
cons
((Alpha_context.Lazy_storage.make (a := unit) (u := unit)) kind_value
id Alpha_context.Lazy_storage.Remove) acc_value in
Alpha_context.Lazy_storage.IdSet.fold_all
{| Alpha_context.Lazy_storage.IdSet.fold_f.f _ := f_value; |} dead diffs
in
match diffs with
| [] ⇒ return? (v_value, None, ctxt)
| diffs ⇒ return? (v_value, (Some diffs), ctxt)
end.
Definition list_of_big_map_ids (ids : Alpha_context.Lazy_storage.IdSet.t)
: list Alpha_context.Big_map.Id.t :=
Alpha_context.Lazy_storage.IdSet.fold Alpha_context.Lazy_storage.Kind.Big_map
(fun (id : Alpha_context.Big_map.Id.t) ⇒
fun (acc_value : list Alpha_context.Big_map.Id.t) ⇒ cons id acc_value)
ids nil.
Definition parse_data {A : Set}
: elab_conf → Alpha_context.context → bool → Script_typed_ir.ty →
Alpha_context.Script.node → M? (A × Alpha_context.context) :=
fun x_1 ⇒ parse_data_aux x_1 0.
Definition parse_comparable_data {A : Set}
(type_logger_value : option Script_ir_translator_config.type_logger)
: Alpha_context.context → Script_typed_ir.ty → Alpha_context.Script.node →
M? (A × Alpha_context.context) :=
fun x_1 ⇒
parse_data
(Script_ir_translator_config.make type_logger_value None false tt) x_1
false.
Definition parse_instr
(elab_conf : elab_conf) (tc_context_value : tc_context)
(ctxt : Alpha_context.context) (script_instr : Alpha_context.Script.node)
(stack_ty : Script_typed_ir.stack_ty)
: M? (judgement × Alpha_context.context) :=
parse_instr_aux elab_conf 0 tc_context_value ctxt script_instr stack_ty.
Definition unparse_data {A : Set}
: Alpha_context.context → Script_ir_unparser.unparsing_mode →
Script_typed_ir.ty → A →
M? (Alpha_context.Script.expr × Alpha_context.context) :=
fun x_1 ⇒
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_data_aux)
x_1 0.
Definition unparse_code {A : Set}
(ctxt : Alpha_context.t) (mode : Script_ir_unparser.unparsing_mode)
(code : Micheline.node A Alpha_context.Script.prim)
: M? (Alpha_context.Script.expr × Alpha_context.context) :=
let? '(ctxt, code) :=
Alpha_context.Global_constants_storage.expand ctxt
(Micheline.strip_locations code) in
Data_unparser_Michelson.(Script_ir_unparser.DATA_UNPARSER.unparse_code_aux)
ctxt 0 mode (Micheline.root_value code).
Definition parse_contract_data
(context_value : Alpha_context.context)
(loc_value : Alpha_context.Script.location) (arg_ty : Script_typed_ir.ty)
(contract : Alpha_context.Destination.t)
(entrypoint : Alpha_context.Entrypoint.t)
: M? (Alpha_context.context × Script_typed_ir.typed_contract) :=
parse_contract_data_aux 0 context_value loc_value arg_ty contract entrypoint.
Definition parse_toplevel
(ctxt : Alpha_context.t) (legacy : bool)
(toplevel_value : Alpha_context.Script.expr)
: M? (toplevel × Alpha_context.context) :=
let? '(ctxt, toplevel_value) :=
Alpha_context.Global_constants_storage.expand ctxt toplevel_value in
parse_toplevel_aux ctxt legacy toplevel_value.
Definition parse_comparable_ty
: Alpha_context.context → Alpha_context.Script.node →
M? (ex_comparable_ty × Alpha_context.context) :=
fun x_1 ⇒ parse_comparable_ty_aux x_1 0.
Definition parse_big_map_value_ty
: Alpha_context.context → bool →
Micheline.node Alpha_context.Script.location Alpha_context.Script.prim →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
fun x_1 ⇒ parse_big_map_value_ty_aux x_1 0.
Definition parse_packable_ty
: Alpha_context.context → bool → Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
fun x_1 ⇒ parse_packable_ty_aux x_1 0.
Definition parse_passable_ty
: Alpha_context.context → bool → Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
fun x_1 ⇒ parse_passable_ty_aux x_1 0.
Definition parse_any_ty
: Alpha_context.context → bool → Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
fun x_1 ⇒ parse_any_ty_aux x_1 0.
Definition parse_ty
: Alpha_context.context → bool → bool → bool → bool → bool →
Alpha_context.Script.node →
M? (Script_typed_ir.ex_ty × Alpha_context.context) :=
fun x_1 x_2 x_3 x_4 x_5 x_6 ⇒
parse_ty_aux x_1 0 x_2 x_3 x_4 x_5 x_6 Don't_parse_entrypoints.
Definition parse_parameter_ty_and_entrypoints
: Alpha_context.context → bool → Alpha_context.Script.node →
M? (ex_parameter_ty_and_entrypoints × Alpha_context.context) :=
fun x_1 ⇒ parse_parameter_ty_and_entrypoints_aux x_1 0.
Definition get_single_sapling_state {A : Set}
(ctxt : Alpha_context.context) (ty_value : Script_typed_ir.ty) (x_value : A)
: M? (option Alpha_context.Sapling.Id.t × Alpha_context.context) :=
let has_lazy_storage_value := has_lazy_storage_value ty_value in
let f_value {i : Set}
(kind_value : Alpha_context.Lazy_storage.Kind.t) (id : i)
(single_id_opt :
Fold_lazy_storage.result (option Alpha_context.Sapling.Id.t))
: Fold_lazy_storage.result (option Alpha_context.Sapling.Id.t) :=
match (kind_value, id) with
| (Alpha_context.Lazy_storage.Kind.Sapling_state, id) ⇒
let id := cast Alpha_context.Sapling.Id.t id in
match single_id_opt with
| Fold_lazy_storage.Ok None ⇒ Fold_lazy_storage.Ok (Some id)
| Fold_lazy_storage.Ok (Some _) ⇒ Fold_lazy_storage.Error
| Fold_lazy_storage.Error ⇒ single_id_opt
end
| _ ⇒ single_id_opt
end in
let? '(id, ctxt) :=
fold_lazy_storage
{| Alpha_context.Lazy_storage.IdSet.fold_f.f _ := f_value; |} None ctxt
ty_value x_value has_lazy_storage_value in
match id with
| Fold_lazy_storage.Ok (Some id) ⇒ return? ((Some id), ctxt)
| (Fold_lazy_storage.Ok None | Fold_lazy_storage.Error) ⇒
return? (None, ctxt)
end.
Definition script_size (function_parameter : ex_script)
: int × Gas_limit_repr.cost :=
let
'Ex_script
(Script_typed_ir.Script {|
Script_typed_ir.script.Script.code := _;
Script_typed_ir.script.Script.arg_type := _;
Script_typed_ir.script.Script.storage := storage_value;
Script_typed_ir.script.Script.storage_type := storage_type;
Script_typed_ir.script.Script.views := _;
Script_typed_ir.script.Script.entrypoints := _;
Script_typed_ir.script.Script.code_size := code_size
|}) := function_parameter in
let '(nodes, storage_size) :=
Script_typed_ir_size.value_size storage_type storage_value in
let cost := Script_typed_ir_size_costs.nodes_cost nodes in
((Saturation_repr.to_int (Saturation_repr.add code_size storage_size)), cost).
Definition typecheck_code
(legacy : bool) (show_types : bool) (ctxt : Alpha_context.context)
(code : Alpha_context.Script.expr)
: M? (Script_tc_errors.type_map × Alpha_context.context) :=
let?
'(Typechecked_code_internal {|
typechecked_code_internal.Typechecked_code_internal.type_map := type_map
|}, ctxt) := typecheck_code_aux legacy show_types ctxt code in
return? (type_map, ctxt).