diff --git a/src/client/embedded/bootstrap/client_proto_programs.ml b/src/client/embedded/bootstrap/client_proto_programs.ml index 3baf1bea8..3b983ece4 100644 --- a/src/client/embedded/bootstrap/client_proto_programs.ml +++ b/src/client/embedded/bootstrap/client_proto_programs.ml @@ -56,48 +56,47 @@ let parse_program s = with | exn -> report_parse_error "program: " exn lexbuf -let rec print_ir ppf node = +let rec print_ir locations ppf node = let open Script in let rec do_seq = function | [] -> assert false - | [ last ] -> Format.fprintf ppf "%a }@]" print_ir last - | fst :: rest -> Format.fprintf ppf "%a ;@ " print_ir fst ; do_seq rest in + | [ last ] -> Format.fprintf ppf "%a }@]" (print_ir locations) last + | fst :: rest -> Format.fprintf ppf "%a ;@ " (print_ir locations) fst ; do_seq rest in let rec do_args = function | [] -> assert false - | [ last ] -> Format.fprintf ppf "%a@]" print_ir last - | fst :: rest -> Format.fprintf ppf "%a@," print_ir fst ; do_args rest in + | [ last ] -> Format.fprintf ppf "%a@]" (print_ir locations) last + | fst :: rest -> Format.fprintf ppf "%a@," (print_ir locations) fst ; do_args rest in + let print_location ppf loc = + if locations loc then begin + Format.fprintf ppf " /* %d */" loc + end in match node with | String (_, s) -> Format.fprintf ppf "%S" s | Int (_, s) -> Format.fprintf ppf "%s" s - | Seq (_, [ one ]) -> print_ir ppf one + | Seq (_, [ one ]) -> print_ir locations ppf one | Seq (_, []) -> Format.fprintf ppf "{}" ; | Seq (_, seq) -> Format.fprintf ppf "{ @[" ; do_seq seq - | Prim (_, "push", [ Prim (_, name, []) ]) -> - Format.fprintf ppf "push %s" name - | Prim (_, name, []) -> - Format.fprintf ppf "%s" name - | Prim (_, "push", [ Prim (_, name, seq) ]) -> - Format.fprintf ppf "push @[%s@," name ; - do_args seq - | Prim (_, name, seq) -> - Format.fprintf ppf "@[%s@," name ; + | Prim (loc, name, []) -> + Format.fprintf ppf "%s%a" name print_location loc + | Prim (loc, name, seq) -> + Format.fprintf ppf "@[%s%a@," name print_location loc; do_args seq -let print_program ppf c = +let print_program locations ppf c = Format.fprintf ppf "@[storage@,%a@]@." - print_ir (c : Script.code).Script.storage_type ; + (print_ir (fun _ -> false)) (c : Script.code).Script.storage_type ; Format.fprintf ppf "@[parameter@,%a@]@." - print_ir (c : Script.code).Script.arg_type ; + (print_ir (fun _ -> false)) (c : Script.code).Script.arg_type ; Format.fprintf ppf "@[return@,%a@]@." - print_ir (c : Script.code).Script.ret_type ; + (print_ir (fun _ -> false)) (c : Script.code).Script.ret_type ; Format.fprintf ppf "@[code@,%a@]" - print_ir (c : Script.code).Script.code + (print_ir locations) (c : Script.code).Script.code let parse_data s = let lexbuf = Lexing.from_string s in @@ -121,7 +120,7 @@ module Program = Client_aliases.Alias (struct type t = Script.code let encoding = Script.code_encoding let of_source s = parse_program s - let to_source p = Lwt.return (Format.asprintf "%a" print_program p) + let to_source p = Lwt.return (Format.asprintf "%a" (print_program (fun _ -> false)) p) let name = "program" end) @@ -169,8 +168,22 @@ let commands () = (fun program () -> let open Data_encoding in Client_proto_rpcs.Helpers.typecheck_code (block ()) program >>= function - | Ok () -> + | Ok type_map -> message "Well typed" ; + print_program + (fun l -> List.mem_assoc l type_map) + Format.std_formatter program ; + Format.printf "@." ; + List.iter + (fun (loc, (before, after)) -> + Format.printf + "%3d@[ : [ @[%a ]@]@,-> [ @[%a ]@]@]@." + loc + (Format.pp_print_list (print_ir (fun _ -> false))) + before + (Format.pp_print_list (print_ir (fun _ -> false))) + after) + type_map ; Lwt.return () | Error errs -> pp_print_error Format.err_formatter errs ; diff --git a/src/client/embedded/bootstrap/client_proto_programs.mli b/src/client/embedded/bootstrap/client_proto_programs.mli index dbec38b52..23e4b8664 100644 --- a/src/client/embedded/bootstrap/client_proto_programs.mli +++ b/src/client/embedded/bootstrap/client_proto_programs.mli @@ -11,8 +11,6 @@ val parse_program: string -> Script.code Lwt.t val parse_data: string -> Script.expr Lwt.t val parse_data_type: string -> Script.expr Lwt.t -val print_program: Format.formatter -> Script.code -> unit - module Program : Client_aliases.Alias with type t = Script.code val commands: unit -> Cli_entries.command list diff --git a/src/client/embedded/bootstrap/client_proto_rpcs.mli b/src/client/embedded/bootstrap/client_proto_rpcs.mli index 0cbff7de6..5e72f93d2 100644 --- a/src/client/embedded/bootstrap/client_proto_rpcs.mli +++ b/src/client/embedded/bootstrap/client_proto_rpcs.mli @@ -92,7 +92,7 @@ end module Helpers : sig val minimal_time: block -> ?prio:int -> unit -> Time.t tzresult Lwt.t - val typecheck_code: block -> Script.code -> unit tzresult Lwt.t + val typecheck_code: block -> Script.code -> Script_ir_translator.type_map tzresult Lwt.t val typecheck_tagged_data: block -> Script.expr -> unit tzresult Lwt.t val typecheck_untagged_data: block -> Script.expr * Script.expr -> unit tzresult Lwt.t val hash_data: block -> Script.expr -> string tzresult Lwt.t diff --git a/src/proto/bootstrap/script_ir_translator.ml b/src/proto/bootstrap/script_ir_translator.ml index 389c143a0..0e76501b4 100644 --- a/src/proto/bootstrap/script_ir_translator.ml +++ b/src/proto/bootstrap/script_ir_translator.ml @@ -684,11 +684,12 @@ and parse_untagged_comparable_data and parse_lambda : type arg ret storage. context -> + ?log: (int -> (stack_ty_val * stack_ty_val) -> unit) -> ?storage_type: storage ty -> arg ty -> ret ty -> Script.expr -> (arg, ret) lambda tzresult Lwt.t = - fun ctxt ?storage_type arg ret script_instr -> + fun ctxt ?log ?storage_type arg ret script_instr -> let loc = location script_instr in - parse_instr ctxt ?storage_type script_instr (Item_t (arg, Empty_t)) >>=? function + parse_instr ctxt ?log ?storage_type script_instr (Item_t (arg, Empty_t)) >>=? function | Typed (instr, (Item_t (ty, Empty_t) as stack_ty)) -> trace (Bad_return (loc, Stack_ty stack_ty, Ty ret)) @@ -701,578 +702,639 @@ and parse_lambda and parse_instr : type bef storage. context -> + ?log: (int -> (stack_ty_val * stack_ty_val) -> unit) -> ?storage_type: storage ty -> Script.expr -> bef stack_ty -> bef judgement tzresult Lwt.t = - fun ctxt ?storage_type script_instr stack_ty -> + fun ctxt ?log ?storage_type script_instr stack_ty -> let return : bef judgement -> bef judgement tzresult Lwt.t = return in let check_item_ty got exp pos n = ty_eq got exp |> record_trace (Bad_stack_item (pos, n)) |> Lwt.return in - match script_instr, stack_ty with - (* stack ops *) - | Prim (_, "drop", []), - Item_t (_, rest) -> - return (Typed (Drop, rest)) - | Prim (_, "dup", []), - Item_t (v, rest) -> - return (Typed (Dup, Item_t (v, Item_t (v, rest)))) - | Prim (_, "swap", []), - Item_t (v, Item_t (w, rest)) -> - return (Typed (Swap, Item_t (w, Item_t (v, rest)))) - | Prim (_, "push", [ td ]), - stack -> - parse_tagged_data ctxt td >>=? fun (Ex (t, v)) -> - return (Typed (Const v, Item_t (t, stack))) - (* options *) - | Prim (_, "some", []), - Item_t (t, rest) -> - return (Typed (Cons_some, Item_t (Option_t t, rest))) - | Prim (_, "none", [ t ]), - stack -> - parse_ty t >>=? fun (Ex t) -> - return (Typed (Cons_none t, Item_t (Option_t t, stack))) - | Prim (loc, "if_none", [ bt ; bf ]), - Item_t (Option_t t, rest) -> - expect_sequence_parameter loc Instr "if_none" 0 bt >>=? fun () -> - expect_sequence_parameter loc Instr "if_none" 1 bf >>=? fun () -> - parse_instr ?storage_type ctxt bt rest >>=? fun btr -> - parse_instr ?storage_type ctxt bf (Item_t (t, rest)) >>=? fun bfr -> - let branch ibt ibf = If_none (ibt, ibf) in - merge_branches loc btr bfr { branch } - (* pairs *) - | Prim (_, "pair", []), - Item_t (a, Item_t (b, rest)) -> - return (Typed (Cons_pair, Item_t (Pair_t(a, b), rest))) - | Prim (_, "car", []), - Item_t (Pair_t (a, _), rest) -> - return (Typed (Car, Item_t (a, rest))) - | Prim (_, "cdr", []), - Item_t (Pair_t (_, b), rest) -> - return (Typed (Cdr, Item_t (b, rest))) - (* unions *) - | Prim (_, "left", [ tr ]), - Item_t (tl, rest) -> - parse_ty tr >>=? fun (Ex tr) -> - return (Typed (Left, Item_t (Union_t (tl, tr), rest))) - | Prim (_, "right", [ tl ]), - Item_t (tr, rest) -> - parse_ty tl >>=? fun (Ex tl) -> - return (Typed (Right, Item_t (Union_t (tl, tr), rest))) - | Prim (loc, "if_left", [ bt ; bf ]), - Item_t (Union_t (tl, tr), rest) -> - expect_sequence_parameter loc Instr "if_left" 0 bt >>=? fun () -> - expect_sequence_parameter loc Instr "if_left" 1 bf >>=? fun () -> - parse_instr ?storage_type ctxt bt (Item_t (tl, rest)) >>=? fun btr -> - parse_instr ?storage_type ctxt bf (Item_t (tr, rest)) >>=? fun bfr -> - let branch ibt ibf = If_left (ibt, ibf) in - merge_branches loc btr bfr { branch } - (* lists *) - | Prim (_, "nil", [ t ]), - stack -> - parse_ty t >>=? fun (Ex t) -> - return (Typed (Nil, Item_t (List_t t, stack))) - | Prim (loc, "cons", []), - Item_t (tv, Item_t (List_t t, rest)) -> - trace - (Bad_stack_item (loc, 2)) - (Lwt.return (ty_eq t tv)) >>=? fun (Eq _) -> - return (Typed (Cons_list, Item_t (List_t t, rest))) - | Prim (loc, "if_cons", [ bt ; bf ]), - Item_t (List_t t, rest) -> - expect_sequence_parameter loc Instr "if_cons" 0 bt >>=? fun () -> - expect_sequence_parameter loc Instr "if_cons" 1 bf >>=? fun () -> - parse_instr ?storage_type ctxt bt (Item_t (t, Item_t (List_t t, rest))) >>=? fun btr -> - parse_instr ?storage_type ctxt bf rest >>=? fun bfr -> - let branch ibt ibf = If_cons (ibt, ibf) in - merge_branches loc btr bfr { branch } - | Prim (loc, "iter", []), - Item_t (Lambda_t (param, Void_t), Item_t (List_t elt, rest)) -> - check_item_ty elt param loc 2 >>=? fun (Eq _) -> - return (Typed (List_iter, rest)) - | Prim (loc, "map", []), - Item_t (Lambda_t (param, ret), Item_t (List_t elt, rest)) -> - check_item_ty elt param loc 2 >>=? fun (Eq _) -> - return (Typed (List_map, Item_t (List_t ret, rest))) - | Prim (loc, "reduce", []), - Item_t (Lambda_t (Pair_t (pelt, pr), r), - Item_t (List_t elt, Item_t (init, rest))) -> - check_item_ty r pr loc 1 >>=? fun (Eq _) -> - check_item_ty elt pelt loc 2 >>=? fun (Eq _) -> - check_item_ty init r loc 3 >>=? fun (Eq _) -> - return (Typed (List_reduce, Item_t (r, rest))) - (* sets *) - | Prim (_, "empty_set", [ t ]), - rest -> - parse_comparable_ty t >>=? fun (Ex t) -> - return (Typed (Empty_set t, Item_t (Set_t t, rest))) - | Prim (loc, "iter", []), - Item_t (Lambda_t (param, Void_t), Item_t (Set_t elt, rest)) -> - let elt = ty_of_comparable_ty elt in - check_item_ty elt param loc 2 >>=? fun (Eq _) -> - return (Typed (Set_iter, rest)) - | Prim (loc, "map", []), - Item_t (Lambda_t (param, ret), Item_t (Set_t elt, rest)) -> - let elt = ty_of_comparable_ty elt in - trace (Bad_stack_item (loc, 1)) (Lwt.return (comparable_ty_of_ty ret)) >>=? fun ret -> - check_item_ty elt param loc 2 >>=? fun (Eq _) -> - return (Typed (Set_map ret, Item_t (Set_t ret, rest))) - | Prim (loc, "reduce", []), - Item_t (Lambda_t (Pair_t (pelt, pr), r), - Item_t (Set_t elt, Item_t (init, rest))) -> - let elt = ty_of_comparable_ty elt in - check_item_ty r pr loc 1 >>=? fun (Eq _) -> - check_item_ty elt pelt loc 2 >>=? fun (Eq _) -> - check_item_ty init r loc 3 >>=? fun (Eq _) -> - return (Typed (Set_reduce, Item_t (r, rest))) - | Prim (loc, "mem", []), - Item_t (v, Item_t (Set_t elt, rest)) -> - let elt = ty_of_comparable_ty elt in - check_item_ty elt v loc 2 >>=? fun (Eq _) -> - return (Typed (Set_mem, Item_t (Bool_t, rest))) - | Prim (loc, "update", []), - Item_t (v, Item_t (Bool_t, Item_t (Set_t elt, rest))) -> - let elt = ty_of_comparable_ty elt in - check_item_ty elt v loc 3 >>=? fun (Eq _) -> - return (Typed (Set_update, rest)) - (* maps *) - | Prim (_, "empty_map", [ tk ; tv ]), - stack -> - parse_comparable_ty tk >>=? fun (Ex tk) -> - parse_ty tv >>=? fun (Ex tv) -> - return (Typed (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack))) - | Prim (loc, "iter", []), - Item_t (Lambda_t (Pair_t (pk, pv), Void_t), Item_t (Map_t (k, v), rest)) -> - let k = ty_of_comparable_ty k in - check_item_ty pk k loc 2 >>=? fun (Eq _) -> - check_item_ty pv v loc 2 >>=? fun (Eq _) -> - return (Typed (Map_iter, rest)) - | Prim (loc, "map", []), - Item_t (Lambda_t (Pair_t (pk, pv), ret), Item_t (Map_t (ck, v), rest)) -> - let k = ty_of_comparable_ty ck in - check_item_ty pk k loc 2 >>=? fun (Eq _) -> - check_item_ty pv v loc 2 >>=? fun (Eq _) -> - return (Typed (Map_map, Item_t (Map_t (ck, ret), rest))) - | Prim (loc, "reduce", []), - Item_t (Lambda_t (Pair_t (Pair_t (pk, pv), pr), r), - Item_t (Map_t (ck, v), Item_t (init, rest))) -> - let k = ty_of_comparable_ty ck in - check_item_ty pk k loc 2 >>=? fun (Eq _) -> - check_item_ty pv v loc 2 >>=? fun (Eq _) -> - check_item_ty r pr loc 1 >>=? fun (Eq _) -> - check_item_ty init r loc 3 >>=? fun (Eq _) -> - return (Typed (Map_reduce, Item_t (r, rest))) - | Prim (loc, "mem", []), - Item_t (vk, Item_t (Map_t (ck, _), rest)) -> - let k = ty_of_comparable_ty ck in - check_item_ty vk k loc 1 >>=? fun (Eq _) -> - return (Typed (Map_mem, Item_t (Bool_t, rest))) - | Prim (loc, "get", []), - Item_t (vk, Item_t (Map_t (ck, elt), rest)) -> - let k = ty_of_comparable_ty ck in - check_item_ty vk k loc 1 >>=? fun (Eq _) -> - return (Typed (Map_get, Item_t (Option_t elt, rest))) - | Prim (loc, "update", []), - Item_t (vk, Item_t (Option_t vv, Item_t (Map_t (ck, v), rest))) -> - let k = ty_of_comparable_ty ck in - check_item_ty vk k loc 1 >>=? fun (Eq _) -> - check_item_ty vv v loc 2 >>=? fun (Eq _) -> - return (Typed (Map_update, rest)) - (* reference cells *) - | Prim (_, "ref", []), - Item_t (t, rest) -> - return (Typed (Ref, Item_t (Ref_t t, rest))) - | Prim (_, "deref", []), - Item_t (Ref_t t, rest) -> - return (Typed (Deref, Item_t (t, rest))) - | Prim (loc, "set", []), - Item_t (Ref_t t, Item_t (tv, rest)) -> - check_item_ty tv t loc 2 >>=? fun (Eq _) -> - return (Typed (Set, rest)) - (* control *) - | Seq (_, []), - stack -> - return (Typed (Nop, stack)) - | Seq (_, [ single ]), - stack -> - parse_instr ?storage_type ctxt single stack - | Seq (loc, hd :: tl), - stack -> - parse_instr ?storage_type ctxt hd stack >>=? begin function - | Failed _ -> - fail (Fail_not_in_tail_position loc) - | Typed (ihd, trans) -> - parse_instr ?storage_type ctxt (Seq (loc, tl)) trans >>=? function - | Failed { instr } -> - let instr ret = Seq (ihd, instr ret) in - return (Failed { instr }) - | Typed (itl, aft) -> - return (Typed (Seq (ihd, itl), aft)) - end - | Prim (loc, "if", [ bt ; bf ]), - Item_t (Bool_t, rest) -> - expect_sequence_parameter loc Instr "if" 0 bt >>=? fun () -> - expect_sequence_parameter loc Instr "if" 1 bf >>=? fun () -> - parse_instr ?storage_type ctxt bt rest >>=? fun btr -> - parse_instr ?storage_type ctxt bf rest >>=? fun bfr -> - let branch ibt ibf = If (ibt, ibf) in - merge_branches loc btr bfr { branch } - | Prim (loc, "loop", [ body ]), - (Item_t (Bool_t, rest) as stack) -> - expect_sequence_parameter loc Instr "loop" 0 body >>=? fun () -> - parse_instr ?storage_type ctxt body rest >>=? begin function - | Typed (ibody, aftbody) -> - trace - (Unmatched_branches (loc, Stack_ty aftbody, Stack_ty stack)) - (Lwt.return (stack_ty_eq 0 aftbody stack)) >>=? fun (Eq _) -> - return (Typed (Loop ibody, rest)) - | Failed { instr } -> - let ibody = instr (Item_t (Bool_t, rest)) in - return (Typed (Loop ibody, rest)) - end - | Prim (loc, "lambda", [ arg ; ret ; code ]), - stack -> - parse_ty arg >>=? fun (Ex arg) -> - parse_ty ret >>=? fun (Ex ret) -> - expect_sequence_parameter loc Instr "lambda" 2 code >>=? fun () -> - parse_lambda ctxt arg ret code >>=? fun lambda -> - return (Typed (Lambda lambda, Item_t (Lambda_t (arg, ret), stack))) - | Prim (loc, "exec", []), - Item_t (arg, Item_t (Lambda_t (param, ret), rest)) -> - check_item_ty arg param loc 1 >>=? fun (Eq _) -> - return (Typed (Exec, Item_t (ret, rest))) - | Prim (loc, "dip", [ code ]), - Item_t (v, rest) -> - expect_sequence_parameter loc Instr "dip" 0 code >>=? fun () -> - parse_instr ctxt code rest >>=? begin function - | Typed (instr, aft_rest) -> - return (Typed (Dip instr, Item_t (v, aft_rest))) - | Failed _ -> - fail (Fail_not_in_tail_position loc) - end - | Prim (loc, "fail", []), - _ -> - let instr _ = Fail loc in - return (Failed { instr }) - | Prim (_, "nop", []), - stack -> - return (Typed (Nop, stack)) - (* timestamp operations *) - | Prim (loc, "add", []), - Item_t (Timestamp_t, Item_t (Int_t kind, rest)) -> - trace (Bad_stack_item (loc, 2)) (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> - return (Typed (Add_timestamp_to_seconds (kind, loc), Item_t (Timestamp_t, rest))) - | Prim (loc, "add", []), - Item_t (Int_t kind, Item_t (Timestamp_t, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> - return (Typed (Add_seconds_to_timestamp (kind, loc), Item_t (Timestamp_t, rest))) - (* string operations *) - | Prim (_, "concat", []), - Item_t (String_t, Item_t (String_t, rest)) -> - return (Typed (Concat, Item_t (String_t, rest))) - (* currency operations *) - | Prim (_, "add", []), - Item_t (Tez_t, Item_t (Tez_t, rest)) -> - return (Typed (Add_tez, Item_t (Tez_t, rest))) - | Prim (_, "sub", []), - Item_t (Tez_t, Item_t (Tez_t, rest)) -> - return (Typed (Sub_tez, Item_t (Tez_t, rest))) - | Prim (loc, "mul", []), - Item_t (Tez_t, Item_t (Int_t kind, rest)) -> - trace (Bad_stack_item (loc, 2)) (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> - return (Typed (Mul_tez kind, Item_t (Tez_t, rest))) - | Prim (loc, "mul", []), - Item_t (Int_t kind, Item_t (Tez_t, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> - return (Typed (Mul_tez' kind, Item_t (Tez_t, rest))) - (* boolean operations *) - | Prim (_, "or", []), - Item_t (Bool_t, Item_t (Bool_t, rest)) -> - return (Typed (Or, Item_t (Bool_t, rest))) - | Prim (_, "and", []), - Item_t (Bool_t, Item_t (Bool_t, rest)) -> - return (Typed (And, Item_t (Bool_t, rest))) - | Prim (_, "xor", []), - Item_t (Bool_t, Item_t (Bool_t, rest)) -> - return (Typed (Xor, Item_t (Bool_t, rest))) - | Prim (_, "not", []), - Item_t (Bool_t, rest) -> - return (Typed (Not, Item_t (Bool_t, rest))) - (* integer operations *) - | Prim (loc, "checked_abs", []), - Item_t (Int_t k, rest) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Checked_abs_int (k, loc), Item_t (Int_t k, rest))) - | Prim (loc, "checked_neg", []), - Item_t (Int_t k, rest) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Checked_neg_int (k, loc), Item_t (Int_t k, rest))) - | Prim (loc, "checked_add", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Checked_add_int (kl, loc), Item_t (Int_t kl, rest))) - | Prim (loc, "checked_sub", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Checked_sub_int (kl, loc), Item_t (Int_t kl, rest))) - | Prim (loc, "checked_mul", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Checked_mul_int (kl, loc), Item_t (Int_t kl, rest))) - | Prim (loc, "abs", []), - Item_t (Int_t k, rest) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Abs_int k, Item_t (Int_t k, rest))) - | Prim (loc, "neg", []), - Item_t (Int_t k, rest) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Neg_int k, Item_t (Int_t k, rest))) - | Prim (loc, "add", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Add_int kl, Item_t (Int_t kl, rest))) - | Prim (loc, "sub", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Sub_int kl, Item_t (Int_t kl, rest))) - | Prim (loc, "mul", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Mul_int kl, Item_t (Int_t kl, rest))) - | Prim (loc, "div", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Div_int (kl, loc), Item_t (Int_t kl, rest))) - | Prim (loc, "mod", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Mod_int (kl, loc), Item_t (Int_t kl, rest))) - | Prim (loc, "lsl", []), - Item_t (Int_t k, Item_t (Int_t Uint8, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Lsl_int k, Item_t (Int_t k, rest))) - | Prim (loc, "lsr", []), - Item_t (Int_t k, Item_t (Int_t Uint8, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Lsr_int k, Item_t (Int_t k, rest))) - | Prim (loc, "or", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> - trace (Bad_stack_item (loc, 2)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Or_int kl, Item_t (Int_t kl, rest))) - | Prim (loc, "and", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> - trace (Bad_stack_item (loc, 2)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (And_int kl, Item_t (Int_t kl, rest))) - | Prim (loc, "xor", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> - trace (Bad_stack_item (loc, 2)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Xor_int kl, Item_t (Int_t kl, rest))) - | Prim (loc, "not", []), - Item_t (Int_t k, rest) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Not_int k, Item_t (Int_t k, rest))) - (* comparison *) - | Prim (loc, "compare", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace (Bad_stack_item (loc, 1)) (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Compare (Int_key kl), Item_t (Int_t Int64, rest))) - | Prim (_, "compare", []), - Item_t (Bool_t, Item_t (Bool_t, rest)) -> - return (Typed (Compare Bool_key, Item_t (Int_t Int64, rest))) - | Prim (_, "compare", []), - Item_t (String_t, Item_t (String_t, rest)) -> - return (Typed (Compare String_key, Item_t (Int_t Int64, rest))) - | Prim (_, "compare", []), - Item_t (Tez_t, Item_t (Tez_t, rest)) -> - return (Typed (Compare Tez_key, Item_t (Int_t Int64, rest))) - | Prim (_, "compare", []), - Item_t (Key_t, Item_t (Key_t, rest)) -> - return (Typed (Compare Key_key, Item_t (Int_t Int64, rest))) - | Prim (_, "compare", []), - Item_t (Timestamp_t, Item_t (Timestamp_t, rest)) -> - return (Typed (Compare Timestamp_key, Item_t (Int_t Int64, rest))) - (* comparators *) - | Prim (_, "eq", []), - Item_t (Int_t Int64, rest) -> - return (Typed (Eq, Item_t (Bool_t, rest))) - | Prim (_, "neq", []), - Item_t (Int_t Int64, rest) -> - return (Typed (Neq, Item_t (Bool_t, rest))) - | Prim (_, "lt", []), - Item_t (Int_t Int64, rest) -> - return (Typed (Lt, Item_t (Bool_t, rest))) - | Prim (_, "gt", []), - Item_t (Int_t Int64, rest) -> - return (Typed (Gt, Item_t (Bool_t, rest))) - | Prim (_, "le", []), - Item_t (Int_t Int64, rest) -> - return (Typed (Le, Item_t (Bool_t, rest))) - | Prim (_, "ge", []), - Item_t (Int_t Int64, rest) -> - return (Typed (Ge, Item_t (Bool_t, rest))) - (* casts *) - | Prim (loc, "checked_cast", [ t ]), - stack -> - parse_ty t >>=? fun (Ex ty) -> begin match ty, stack with - | Int_t kt, - Item_t (Int_t kf, rest) -> - return (Typed (Checked_int_of_int (kf, kt, loc), Item_t (Int_t kt, rest))) - | ty, Item_t (ty', _) -> - fail (Undefined_cast (loc, Ty ty', Ty ty)) - | _, Empty_t -> - fail (Bad_stack (loc, 1, Stack_ty stack)) - end - | Prim (loc, "cast", [ t ]), - stack -> - parse_ty t >>=? fun (Ex ty) -> begin match ty, stack with - | Int_t kt, Item_t (Int_t kf, rest) -> - return (Typed (Int_of_int (kf, kt), Item_t (Int_t kt, rest))) - | ty, Item_t (ty', _) -> - fail (Undefined_cast (loc, Ty ty', Ty ty)) - | _, Empty_t -> - fail (Bad_stack (loc, 1, Stack_ty stack)) - end - (* protocol *) - | Prim (_, "manager", []), - Item_t (Contract_t _, rest) -> - return (Typed (Manager, Item_t (Key_t, rest))) - | Prim (loc, "transfer_tokens", []), - Item_t (p, Item_t - (Tez_t, Item_t - (Contract_t (cp, cr), Item_t - (storage, Empty_t)))) -> - check_item_ty p cp loc 1 >>=? fun (Eq _) -> - begin match storage_type with - | Some storage_type -> - check_item_ty storage storage_type loc 3 >>=? fun (Eq _) -> - return (Typed (Transfer_tokens (storage, loc), Item_t (cr, Item_t (storage, Empty_t)))) - | None -> - fail (Transfer_in_lambda loc) - end - | Prim (_, "create_account", []), - Item_t - (Key_t, Item_t - (Option_t Key_t, Item_t - (Bool_t, Item_t - (Tez_t, rest)))) -> - return (Typed (Create_account, Item_t (Contract_t (Void_t, Void_t), rest))) - | Prim (loc, "create_contract", []), - Item_t - (Key_t, Item_t - (Option_t Key_t, Item_t - (Bool_t, Item_t - (Tez_t, Item_t - (Lambda_t (Pair_t (Pair_t (Tez_t, p), gp), - Pair_t (r, gr)), Item_t - (ginit, rest)))))) -> - check_item_ty gp gr loc 5 >>=? fun (Eq _) -> - check_item_ty ginit gp loc 6 >>=? fun (Eq _) -> - return (Typed (Create_contract (gp, p, r), - Item_t (Contract_t (p, r), rest))) - | Prim (_, "now", []), - stack -> - return (Typed (Now, Item_t (Timestamp_t, stack))) - | Prim (_, "amount", []), - stack -> - return (Typed (Amount, Item_t (Tez_t, stack))) - | Prim (_, "balance", []), - stack -> - return (Typed (Balance, Item_t (Tez_t, stack))) - | Prim (_, "check_signature", []), - Item_t (Key_t, Item_t (Pair_t (Signature_t, String_t), rest)) -> - return (Typed (Check_signature, Item_t (Bool_t, rest))) - | Prim (_, "h", []), - Item_t (t, rest) -> - return (Typed (H t, Item_t (String_t, rest))) - | Prim (_, "steps_to_quota", []), - stack -> - return (Typed (Steps_to_quota, Item_t (Int_t Uint32, stack))) - | Prim (_, "source", [ ta; tb ]), - stack -> - parse_ty ta >>=? fun (Ex ta) -> - parse_ty tb >>=? fun (Ex tb) -> - return (Typed (Source (ta, tb), Item_t (Contract_t (ta, tb), stack))) - (* Primitive parsing errors *) - | Prim (loc, ("drop" | "dup" | "swap" | "some" - | "pair" | "car" | "cdr" | "cons" - | "mem" | "update" | "iter" | "map" | "reduce" - | "get" | "ref" | "deref" - | "set" | "exec" | "fail" | "nop" - | "concat" | "add" | "sub" - | "mul" | "floor" | "ceil" | "inf" - | "nan" | "isnan" | "nanan" - | "div" | "mod" | "or" | "and" | "xor" - | "not" | "checked_abs" | "checked_neg" - | "checked_add" | "checked_sub" | "checked_mul" - | "abs" | "neg" | "lsl" | "lsr" - | "compare" | "eq" | "neq" - | "lt" | "gt" | "le" | "ge" - | "manager" | "transfer_tokens" | "create_account" - | "create_contract" | "now" | "amount" | "balance" - | "check_signature" | "h" | "steps_to_quota" - as name), (_ :: _ as l)), _ -> - fail (Invalid_arity (loc, Instr, name, 0, List.length l)) - | Prim (loc, ( "push" | "none" | "left" | "right" | "nil" - | "empty_set" | "dip" | "checked_cast" | "cast" | "loop" - as name), ([] | _ :: _ :: _ as l)), _ -> - fail (Invalid_arity (loc, Instr, name, 1, List.length l)) - | Prim (loc, ("if_none" | "if_left" | "if_cons" - | "empty_map" | "if" | "source" - as name), ([] | [ _ ] | _ :: _ :: _ :: _ as l)), _ -> - fail (Invalid_arity (loc, Instr, name, 2, List.length l)) - | Prim (loc, "lambda", ([] | [ _ ] | [ _; _ ] | _ :: _ :: _ :: _ :: _ as l)), _ -> - fail (Invalid_arity (loc, Instr, "lambda", 3, List.length l)) - (* Stack errors *) - | Prim (loc, ("add" | "sub" | "mul" | "div" | "mod" - | "and" | "or" | "xor" | "lsl" | "lsr" - | "concat" | "compare" - | "checked_abs" | "checked_neg" - | "checked_add" | "checked_sub" | "checked_mul" as name), []), - Item_t (ta, Item_t (tb, _)) -> - fail (Undefined_binop (loc, name, Ty ta, Ty tb)) - | Prim (loc, ("neg" | "abs" | "not" | "floor" | "ceil" - | "isnan" | "nanan" | "eq" - | "neq" | "lt" | "gt" | "le" | "ge" as name), []), - Item_t (t, _) -> - fail (Undefined_unop (loc, name, Ty t)) - | Prim (loc, ("reduce" | "update"), []), - stack -> - fail (Bad_stack (loc, 3, Stack_ty stack)) - | Prim (loc, "create_contract", []), - stack -> - fail (Bad_stack (loc, 6, Stack_ty stack)) - | Prim (loc, "create_account", []), - stack -> - fail (Bad_stack (loc, 4, Stack_ty stack)) - | Prim (loc, "transfer_tokens", []), - stack -> - fail (Bad_stack (loc, 3, Stack_ty stack)) - | Prim (loc, ("drop" | "dup" | "car" | "cdr" | "some" | "h" | "dip" - | "if_none" | "left" | "right" | "if_left" | "if" - | "loop" | "if_cons" | "ref" | "deref" | "manager" - | "neg" | "abs" | "not" | "floor" | "ceil" | "isnan" | "nanan" - | "eq" | "neq" | "lt" | "gt" | "le" | "ge"), _), - stack -> - fail (Bad_stack (loc, 1, Stack_ty stack)) - | Prim (loc, ("swap" | "pair" | "cons" | "set" | "incr" | "decr" - | "map" | "iter" | "get" | "mem" | "exec" - | "check_signature" | "add" | "sub" | "mul" - | "div" | "mod" | "and" | "or" | "xor" - | "lsl" | "lsr" | "concat" - | "checked_abs" | "checked_neg" | "checked_add" - | "checked_sub" | "checked_mul" | "compare"), _), - stack -> - fail (Bad_stack (loc, 2, Stack_ty stack)) - (* Generic parsing errors *) - | Prim (loc, prim, _), _ -> - fail @@ Invalid_primitive (loc, Instr, prim) - | (Int (loc, _) | String (loc, _)), _ -> - fail @@ Invalid_expression_kind loc + begin match script_instr, stack_ty with + (* stack ops *) + | Prim (_, "drop", []), + Item_t (_, rest) -> + return (Typed (Drop, rest)) + | Prim (_, "dup", []), + Item_t (v, rest) -> + return (Typed (Dup, Item_t (v, Item_t (v, rest)))) + | Prim (_, "swap", []), + Item_t (v, Item_t (w, rest)) -> + return (Typed (Swap, Item_t (w, Item_t (v, rest)))) + | Prim (_, "push", [ td ]), + stack -> + parse_tagged_data ctxt td >>=? fun (Ex (t, v)) -> + return (Typed (Const v, Item_t (t, stack))) + (* options *) + | Prim (_, "some", []), + Item_t (t, rest) -> + return (Typed (Cons_some, Item_t (Option_t t, rest))) + | Prim (_, "none", [ t ]), + stack -> + parse_ty t >>=? fun (Ex t) -> + return (Typed (Cons_none t, Item_t (Option_t t, stack))) + | Prim (loc, "if_none", [ bt ; bf ]), + Item_t (Option_t t, rest) -> + expect_sequence_parameter loc Instr "if_none" 0 bt >>=? fun () -> + expect_sequence_parameter loc Instr "if_none" 1 bf >>=? fun () -> + parse_instr ?log ?storage_type ctxt bt rest >>=? fun btr -> + parse_instr ?log ?storage_type ctxt bf (Item_t (t, rest)) >>=? fun bfr -> + let branch ibt ibf = If_none (ibt, ibf) in + merge_branches loc btr bfr { branch } + (* pairs *) + | Prim (_, "pair", []), + Item_t (a, Item_t (b, rest)) -> + return (Typed (Cons_pair, Item_t (Pair_t(a, b), rest))) + | Prim (_, "car", []), + Item_t (Pair_t (a, _), rest) -> + return (Typed (Car, Item_t (a, rest))) + | Prim (_, "cdr", []), + Item_t (Pair_t (_, b), rest) -> + return (Typed (Cdr, Item_t (b, rest))) + (* unions *) + | Prim (_, "left", [ tr ]), + Item_t (tl, rest) -> + parse_ty tr >>=? fun (Ex tr) -> + return (Typed (Left, Item_t (Union_t (tl, tr), rest))) + | Prim (_, "right", [ tl ]), + Item_t (tr, rest) -> + parse_ty tl >>=? fun (Ex tl) -> + return (Typed (Right, Item_t (Union_t (tl, tr), rest))) + | Prim (loc, "if_left", [ bt ; bf ]), + Item_t (Union_t (tl, tr), rest) -> + expect_sequence_parameter loc Instr "if_left" 0 bt >>=? fun () -> + expect_sequence_parameter loc Instr "if_left" 1 bf >>=? fun () -> + parse_instr ?log ?storage_type ctxt bt (Item_t (tl, rest)) >>=? fun btr -> + parse_instr ?log ?storage_type ctxt bf (Item_t (tr, rest)) >>=? fun bfr -> + let branch ibt ibf = If_left (ibt, ibf) in + merge_branches loc btr bfr { branch } + (* lists *) + | Prim (_, "nil", [ t ]), + stack -> + parse_ty t >>=? fun (Ex t) -> + return (Typed (Nil, Item_t (List_t t, stack))) + | Prim (loc, "cons", []), + Item_t (tv, Item_t (List_t t, rest)) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (ty_eq t tv)) >>=? fun (Eq _) -> + return (Typed (Cons_list, Item_t (List_t t, rest))) + | Prim (loc, "if_cons", [ bt ; bf ]), + Item_t (List_t t, rest) -> + expect_sequence_parameter loc Instr "if_cons" 0 bt >>=? fun () -> + expect_sequence_parameter loc Instr "if_cons" 1 bf >>=? fun () -> + parse_instr ?log ?storage_type ctxt bt (Item_t (t, Item_t (List_t t, rest))) >>=? fun btr -> + parse_instr ?log ?storage_type ctxt bf rest >>=? fun bfr -> + let branch ibt ibf = If_cons (ibt, ibf) in + merge_branches loc btr bfr { branch } + | Prim (loc, "iter", []), + Item_t (Lambda_t (param, Void_t), Item_t (List_t elt, rest)) -> + check_item_ty elt param loc 2 >>=? fun (Eq _) -> + return (Typed (List_iter, rest)) + | Prim (loc, "map", []), + Item_t (Lambda_t (param, ret), Item_t (List_t elt, rest)) -> + check_item_ty elt param loc 2 >>=? fun (Eq _) -> + return (Typed (List_map, Item_t (List_t ret, rest))) + | Prim (loc, "reduce", []), + Item_t (Lambda_t (Pair_t (pelt, pr), r), + Item_t (List_t elt, Item_t (init, rest))) -> + check_item_ty r pr loc 1 >>=? fun (Eq _) -> + check_item_ty elt pelt loc 2 >>=? fun (Eq _) -> + check_item_ty init r loc 3 >>=? fun (Eq _) -> + return (Typed (List_reduce, Item_t (r, rest))) + (* sets *) + | Prim (_, "empty_set", [ t ]), + rest -> + parse_comparable_ty t >>=? fun (Ex t) -> + return (Typed (Empty_set t, Item_t (Set_t t, rest))) + | Prim (loc, "iter", []), + Item_t (Lambda_t (param, Void_t), Item_t (Set_t elt, rest)) -> + let elt = ty_of_comparable_ty elt in + check_item_ty elt param loc 2 >>=? fun (Eq _) -> + return (Typed (Set_iter, rest)) + | Prim (loc, "map", []), + Item_t (Lambda_t (param, ret), Item_t (Set_t elt, rest)) -> + let elt = ty_of_comparable_ty elt in + trace (Bad_stack_item (loc, 1)) (Lwt.return (comparable_ty_of_ty ret)) >>=? fun ret -> + check_item_ty elt param loc 2 >>=? fun (Eq _) -> + return (Typed (Set_map ret, Item_t (Set_t ret, rest))) + | Prim (loc, "reduce", []), + Item_t (Lambda_t (Pair_t (pelt, pr), r), + Item_t (Set_t elt, Item_t (init, rest))) -> + let elt = ty_of_comparable_ty elt in + check_item_ty r pr loc 1 >>=? fun (Eq _) -> + check_item_ty elt pelt loc 2 >>=? fun (Eq _) -> + check_item_ty init r loc 3 >>=? fun (Eq _) -> + return (Typed (Set_reduce, Item_t (r, rest))) + | Prim (loc, "mem", []), + Item_t (v, Item_t (Set_t elt, rest)) -> + let elt = ty_of_comparable_ty elt in + check_item_ty elt v loc 2 >>=? fun (Eq _) -> + return (Typed (Set_mem, Item_t (Bool_t, rest))) + | Prim (loc, "update", []), + Item_t (v, Item_t (Bool_t, Item_t (Set_t elt, rest))) -> + let elt = ty_of_comparable_ty elt in + check_item_ty elt v loc 3 >>=? fun (Eq _) -> + return (Typed (Set_update, rest)) + (* maps *) + | Prim (_, "empty_map", [ tk ; tv ]), + stack -> + parse_comparable_ty tk >>=? fun (Ex tk) -> + parse_ty tv >>=? fun (Ex tv) -> + return (Typed (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack))) + | Prim (loc, "iter", []), + Item_t (Lambda_t (Pair_t (pk, pv), Void_t), Item_t (Map_t (k, v), rest)) -> + let k = ty_of_comparable_ty k in + check_item_ty pk k loc 2 >>=? fun (Eq _) -> + check_item_ty pv v loc 2 >>=? fun (Eq _) -> + return (Typed (Map_iter, rest)) + | Prim (loc, "map", []), + Item_t (Lambda_t (Pair_t (pk, pv), ret), Item_t (Map_t (ck, v), rest)) -> + let k = ty_of_comparable_ty ck in + check_item_ty pk k loc 2 >>=? fun (Eq _) -> + check_item_ty pv v loc 2 >>=? fun (Eq _) -> + return (Typed (Map_map, Item_t (Map_t (ck, ret), rest))) + | Prim (loc, "reduce", []), + Item_t (Lambda_t (Pair_t (Pair_t (pk, pv), pr), r), + Item_t (Map_t (ck, v), Item_t (init, rest))) -> + let k = ty_of_comparable_ty ck in + check_item_ty pk k loc 2 >>=? fun (Eq _) -> + check_item_ty pv v loc 2 >>=? fun (Eq _) -> + check_item_ty r pr loc 1 >>=? fun (Eq _) -> + check_item_ty init r loc 3 >>=? fun (Eq _) -> + return (Typed (Map_reduce, Item_t (r, rest))) + | Prim (loc, "mem", []), + Item_t (vk, Item_t (Map_t (ck, _), rest)) -> + let k = ty_of_comparable_ty ck in + check_item_ty vk k loc 1 >>=? fun (Eq _) -> + return (Typed (Map_mem, Item_t (Bool_t, rest))) + | Prim (loc, "get", []), + Item_t (vk, Item_t (Map_t (ck, elt), rest)) -> + let k = ty_of_comparable_ty ck in + check_item_ty vk k loc 1 >>=? fun (Eq _) -> + return (Typed (Map_get, Item_t (Option_t elt, rest))) + | Prim (loc, "update", []), + Item_t (vk, Item_t (Option_t vv, Item_t (Map_t (ck, v), rest))) -> + let k = ty_of_comparable_ty ck in + check_item_ty vk k loc 1 >>=? fun (Eq _) -> + check_item_ty vv v loc 2 >>=? fun (Eq _) -> + return (Typed (Map_update, rest)) + (* reference cells *) + | Prim (_, "ref", []), + Item_t (t, rest) -> + return (Typed (Ref, Item_t (Ref_t t, rest))) + | Prim (_, "deref", []), + Item_t (Ref_t t, rest) -> + return (Typed (Deref, Item_t (t, rest))) + | Prim (loc, "set", []), + Item_t (Ref_t t, Item_t (tv, rest)) -> + check_item_ty tv t loc 2 >>=? fun (Eq _) -> + return (Typed (Set, rest)) + (* control *) + | Seq (_, []), + stack -> + return (Typed (Nop, stack)) + | Seq (_, [ single ]), + stack -> + parse_instr ?log ?storage_type ctxt single stack + | Seq (loc, hd :: tl), + stack -> + parse_instr ?log ?storage_type ctxt hd stack >>=? begin function + | Failed _ -> + fail (Fail_not_in_tail_position loc) + | Typed (ihd, trans) -> + parse_instr ?log ?storage_type ctxt (Seq (loc, tl)) trans >>=? function + | Failed { instr } -> + let instr ret = Seq (ihd, instr ret) in + return (Failed { instr }) + | Typed (itl, aft) -> + return (Typed (Seq (ihd, itl), aft)) + end + | Prim (loc, "if", [ bt ; bf ]), + Item_t (Bool_t, rest) -> + expect_sequence_parameter loc Instr "if" 0 bt >>=? fun () -> + expect_sequence_parameter loc Instr "if" 1 bf >>=? fun () -> + parse_instr ?log ?storage_type ctxt bt rest >>=? fun btr -> + parse_instr ?log ?storage_type ctxt bf rest >>=? fun bfr -> + let branch ibt ibf = If (ibt, ibf) in + merge_branches loc btr bfr { branch } + | Prim (loc, "loop", [ body ]), + (Item_t (Bool_t, rest) as stack) -> + expect_sequence_parameter loc Instr "loop" 0 body >>=? fun () -> + parse_instr ?log ?storage_type ctxt body rest >>=? begin function + | Typed (ibody, aftbody) -> + trace + (Unmatched_branches (loc, Stack_ty aftbody, Stack_ty stack)) + (Lwt.return (stack_ty_eq 0 aftbody stack)) >>=? fun (Eq _) -> + return (Typed (Loop ibody, rest)) + | Failed { instr } -> + let ibody = instr (Item_t (Bool_t, rest)) in + return (Typed (Loop ibody, rest)) + end + | Prim (loc, "lambda", [ arg ; ret ; code ]), + stack -> + parse_ty arg >>=? fun (Ex arg) -> + parse_ty ret >>=? fun (Ex ret) -> + expect_sequence_parameter loc Instr "lambda" 2 code >>=? fun () -> + parse_lambda ctxt ?log arg ret code >>=? fun lambda -> + return (Typed (Lambda lambda, Item_t (Lambda_t (arg, ret), stack))) + | Prim (loc, "exec", []), + Item_t (arg, Item_t (Lambda_t (param, ret), rest)) -> + check_item_ty arg param loc 1 >>=? fun (Eq _) -> + return (Typed (Exec, Item_t (ret, rest))) + | Prim (loc, "dip", [ code ]), + Item_t (v, rest) -> + expect_sequence_parameter loc Instr "dip" 0 code >>=? fun () -> + parse_instr ?log ctxt code rest >>=? begin function + | Typed (instr, aft_rest) -> + return (Typed (Dip instr, Item_t (v, aft_rest))) + | Failed _ -> + fail (Fail_not_in_tail_position loc) + end + | Prim (loc, "fail", []), + _ -> + let instr _ = Fail loc in + return (Failed { instr }) + | Prim (_, "nop", []), + stack -> + return (Typed (Nop, stack)) + (* timestamp operations *) + | Prim (loc, "add", []), + Item_t (Timestamp_t, Item_t (Int_t kind, rest)) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> + return (Typed (Add_timestamp_to_seconds (kind, loc), Item_t (Timestamp_t, rest))) + | Prim (loc, "add", []), + Item_t (Int_t kind, Item_t (Timestamp_t, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> + return (Typed (Add_seconds_to_timestamp (kind, loc), Item_t (Timestamp_t, rest))) + (* string operations *) + | Prim (_, "concat", []), + Item_t (String_t, Item_t (String_t, rest)) -> + return (Typed (Concat, Item_t (String_t, rest))) + (* currency operations *) + | Prim (_, "add", []), + Item_t (Tez_t, Item_t (Tez_t, rest)) -> + return (Typed (Add_tez, Item_t (Tez_t, rest))) + | Prim (_, "sub", []), + Item_t (Tez_t, Item_t (Tez_t, rest)) -> + return (Typed (Sub_tez, Item_t (Tez_t, rest))) + | Prim (loc, "mul", []), + Item_t (Tez_t, Item_t (Int_t kind, rest)) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> + return (Typed (Mul_tez kind, Item_t (Tez_t, rest))) + | Prim (loc, "mul", []), + Item_t (Int_t kind, Item_t (Tez_t, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> + return (Typed (Mul_tez' kind, Item_t (Tez_t, rest))) + (* boolean operations *) + | Prim (_, "or", []), + Item_t (Bool_t, Item_t (Bool_t, rest)) -> + return (Typed (Or, Item_t (Bool_t, rest))) + | Prim (_, "and", []), + Item_t (Bool_t, Item_t (Bool_t, rest)) -> + return (Typed (And, Item_t (Bool_t, rest))) + | Prim (_, "xor", []), + Item_t (Bool_t, Item_t (Bool_t, rest)) -> + return (Typed (Xor, Item_t (Bool_t, rest))) + | Prim (_, "not", []), + Item_t (Bool_t, rest) -> + return (Typed (Not, Item_t (Bool_t, rest))) + (* integer operations *) + | Prim (loc, "checked_abs", []), + Item_t (Int_t k, rest) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Checked_abs_int (k, loc), Item_t (Int_t k, rest))) + | Prim (loc, "checked_neg", []), + Item_t (Int_t k, rest) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Checked_neg_int (k, loc), Item_t (Int_t k, rest))) + | Prim (loc, "checked_add", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Checked_add_int (kl, loc), Item_t (Int_t kl, rest))) + | Prim (loc, "checked_sub", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Checked_sub_int (kl, loc), Item_t (Int_t kl, rest))) + | Prim (loc, "checked_mul", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Checked_mul_int (kl, loc), Item_t (Int_t kl, rest))) + | Prim (loc, "abs", []), + Item_t (Int_t k, rest) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Abs_int k, Item_t (Int_t k, rest))) + | Prim (loc, "neg", []), + Item_t (Int_t k, rest) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Neg_int k, Item_t (Int_t k, rest))) + | Prim (loc, "add", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Add_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "sub", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Sub_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "mul", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Mul_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "div", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Div_int (kl, loc), Item_t (Int_t kl, rest))) + | Prim (loc, "mod", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Mod_int (kl, loc), Item_t (Int_t kl, rest))) + | Prim (loc, "lsl", []), + Item_t (Int_t k, Item_t (Int_t Uint8, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Lsl_int k, Item_t (Int_t k, rest))) + | Prim (loc, "lsr", []), + Item_t (Int_t k, Item_t (Int_t Uint8, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Lsr_int k, Item_t (Int_t k, rest))) + | Prim (loc, "or", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Or_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "and", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (And_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "xor", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Xor_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "not", []), + Item_t (Int_t k, rest) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> + return (Typed (Not_int k, Item_t (Int_t k, rest))) + (* comparison *) + | Prim (loc, "compare", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (Typed (Compare (Int_key kl), Item_t (Int_t Int64, rest))) + | Prim (_, "compare", []), + Item_t (Bool_t, Item_t (Bool_t, rest)) -> + return (Typed (Compare Bool_key, Item_t (Int_t Int64, rest))) + | Prim (_, "compare", []), + Item_t (String_t, Item_t (String_t, rest)) -> + return (Typed (Compare String_key, Item_t (Int_t Int64, rest))) + | Prim (_, "compare", []), + Item_t (Tez_t, Item_t (Tez_t, rest)) -> + return (Typed (Compare Tez_key, Item_t (Int_t Int64, rest))) + | Prim (_, "compare", []), + Item_t (Key_t, Item_t (Key_t, rest)) -> + return (Typed (Compare Key_key, Item_t (Int_t Int64, rest))) + | Prim (_, "compare", []), + Item_t (Timestamp_t, Item_t (Timestamp_t, rest)) -> + return (Typed (Compare Timestamp_key, Item_t (Int_t Int64, rest))) + (* comparators *) + | Prim (_, "eq", []), + Item_t (Int_t Int64, rest) -> + return (Typed (Eq, Item_t (Bool_t, rest))) + | Prim (_, "neq", []), + Item_t (Int_t Int64, rest) -> + return (Typed (Neq, Item_t (Bool_t, rest))) + | Prim (_, "lt", []), + Item_t (Int_t Int64, rest) -> + return (Typed (Lt, Item_t (Bool_t, rest))) + | Prim (_, "gt", []), + Item_t (Int_t Int64, rest) -> + return (Typed (Gt, Item_t (Bool_t, rest))) + | Prim (_, "le", []), + Item_t (Int_t Int64, rest) -> + return (Typed (Le, Item_t (Bool_t, rest))) + | Prim (_, "ge", []), + Item_t (Int_t Int64, rest) -> + return (Typed (Ge, Item_t (Bool_t, rest))) + (* casts *) + | Prim (loc, "checked_cast", [ t ]), + stack -> + parse_ty t >>=? fun (Ex ty) -> begin match ty, stack with + | Int_t kt, + Item_t (Int_t kf, rest) -> + return (Typed (Checked_int_of_int (kf, kt, loc), + Item_t (Int_t kt, rest))) + | ty, Item_t (ty', _) -> + fail (Undefined_cast (loc, Ty ty', Ty ty)) + | _, Empty_t -> + fail (Bad_stack (loc, 1, Stack_ty stack)) + end + | Prim (loc, "cast", [ t ]), + stack -> + parse_ty t >>=? fun (Ex ty) -> begin match ty, stack with + | Int_t kt, Item_t (Int_t kf, rest) -> + return (Typed (Int_of_int (kf, kt), + Item_t (Int_t kt, rest))) + | ty, Item_t (ty', _) -> + fail (Undefined_cast (loc, Ty ty', Ty ty)) + | _, Empty_t -> + fail (Bad_stack (loc, 1, Stack_ty stack)) + end + (* protocol *) + | Prim (_, "manager", []), + Item_t (Contract_t _, rest) -> + return (Typed (Manager, Item_t (Key_t, rest))) + | Prim (loc, "transfer_tokens", []), + Item_t (p, Item_t + (Tez_t, Item_t + (Contract_t (cp, cr), Item_t + (storage, Empty_t)))) -> + check_item_ty p cp loc 1 >>=? fun (Eq _) -> + begin match storage_type with + | Some storage_type -> + check_item_ty storage storage_type loc 3 >>=? fun (Eq _) -> + return (Typed (Transfer_tokens (storage, loc), + Item_t (cr, Item_t (storage, Empty_t)))) + | None -> + fail (Transfer_in_lambda loc) + end + | Prim (_, "create_account", []), + Item_t + (Key_t, Item_t + (Option_t Key_t, Item_t + (Bool_t, Item_t + (Tez_t, rest)))) -> + return (Typed (Create_account, + Item_t (Contract_t (Void_t, Void_t), rest))) + | Prim (loc, "create_contract", []), + Item_t + (Key_t, Item_t + (Option_t Key_t, Item_t + (Bool_t, Item_t + (Tez_t, Item_t + (Lambda_t (Pair_t (Pair_t (Tez_t, p), gp), + Pair_t (r, gr)), Item_t + (ginit, rest)))))) -> + check_item_ty gp gr loc 5 >>=? fun (Eq _) -> + check_item_ty ginit gp loc 6 >>=? fun (Eq _) -> + return (Typed (Create_contract (gp, p, r), + Item_t (Contract_t (p, r), rest))) + | Prim (_, "now", []), + stack -> + return (Typed (Now, Item_t (Timestamp_t, stack))) + | Prim (_, "amount", []), + stack -> + return (Typed (Amount, Item_t (Tez_t, stack))) + | Prim (_, "balance", []), + stack -> + return (Typed (Balance, Item_t (Tez_t, stack))) + | Prim (_, "check_signature", []), + Item_t (Key_t, Item_t (Pair_t (Signature_t, String_t), rest)) -> + return (Typed (Check_signature, Item_t (Bool_t, rest))) + | Prim (_, "h", []), + Item_t (t, rest) -> + return (Typed (H t, Item_t (String_t, rest))) + | Prim (_, "steps_to_quota", []), + stack -> + return (Typed (Steps_to_quota, Item_t (Int_t Uint32, stack))) + | Prim (_, "source", [ ta; tb ]), + stack -> + parse_ty ta >>=? fun (Ex ta) -> + parse_ty tb >>=? fun (Ex tb) -> + return (Typed (Source (ta, tb), Item_t (Contract_t (ta, tb), stack))) + (* Primitive parsing errors *) + | Prim (loc, ("drop" | "dup" | "swap" | "some" + | "pair" | "car" | "cdr" | "cons" + | "mem" | "update" | "iter" | "map" | "reduce" + | "get" | "ref" | "deref" + | "set" | "exec" | "fail" | "nop" + | "concat" | "add" | "sub" + | "mul" | "floor" | "ceil" | "inf" + | "nan" | "isnan" | "nanan" + | "div" | "mod" | "or" | "and" | "xor" + | "not" | "checked_abs" | "checked_neg" + | "checked_add" | "checked_sub" | "checked_mul" + | "abs" | "neg" | "lsl" | "lsr" + | "compare" | "eq" | "neq" + | "lt" | "gt" | "le" | "ge" + | "manager" | "transfer_tokens" | "create_account" + | "create_contract" | "now" | "amount" | "balance" + | "check_signature" | "h" | "steps_to_quota" + as name), (_ :: _ as l)), _ -> + fail (Invalid_arity (loc, Instr, name, 0, List.length l)) + | Prim (loc, ( "push" | "none" | "left" | "right" | "nil" + | "empty_set" | "dip" | "checked_cast" | "cast" | "loop" + as name), ([] | _ :: _ :: _ as l)), _ -> + fail (Invalid_arity (loc, Instr, name, 1, List.length l)) + | Prim (loc, ("if_none" | "if_left" | "if_cons" + | "empty_map" | "if" | "source" + as name), ([] | [ _ ] | _ :: _ :: _ :: _ as l)), _ -> + fail (Invalid_arity (loc, Instr, name, 2, List.length l)) + | Prim (loc, "lambda", ([] | [ _ ] | [ _; _ ] + | _ :: _ :: _ :: _ :: _ as l)), _ -> + fail (Invalid_arity (loc, Instr, "lambda", 3, List.length l)) + (* Stack errors *) + | Prim (loc, ("add" | "sub" | "mul" | "div" | "mod" + | "and" | "or" | "xor" | "lsl" | "lsr" + | "concat" | "compare" + | "checked_abs" | "checked_neg" + | "checked_add" | "checked_sub" | "checked_mul" as name), []), + Item_t (ta, Item_t (tb, _)) -> + fail (Undefined_binop (loc, name, Ty ta, Ty tb)) + | Prim (loc, ("neg" | "abs" | "not" | "floor" | "ceil" + | "isnan" | "nanan" | "eq" + | "neq" | "lt" | "gt" | "le" | "ge" as name), []), + Item_t (t, _) -> + fail (Undefined_unop (loc, name, Ty t)) + | Prim (loc, ("reduce" | "update"), []), + stack -> + fail (Bad_stack (loc, 3, Stack_ty stack)) + | Prim (loc, "create_contract", []), + stack -> + fail (Bad_stack (loc, 6, Stack_ty stack)) + | Prim (loc, "create_account", []), + stack -> + fail (Bad_stack (loc, 4, Stack_ty stack)) + | Prim (loc, "transfer_tokens", []), + stack -> + fail (Bad_stack (loc, 3, Stack_ty stack)) + | Prim (loc, ("drop" | "dup" | "car" | "cdr" | "some" | "h" | "dip" + | "if_none" | "left" | "right" | "if_left" | "if" + | "loop" | "if_cons" | "ref" | "deref" | "manager" + | "neg" | "abs" | "not" | "floor" | "ceil" | "isnan" | "nanan" + | "eq" | "neq" | "lt" | "gt" | "le" | "ge"), _), + stack -> + fail (Bad_stack (loc, 1, Stack_ty stack)) + | Prim (loc, ("swap" | "pair" | "cons" | "set" | "incr" | "decr" + | "map" | "iter" | "get" | "mem" | "exec" + | "check_signature" | "add" | "sub" | "mul" + | "div" | "mod" | "and" | "or" | "xor" + | "lsl" | "lsr" | "concat" + | "checked_abs" | "checked_neg" | "checked_add" + | "checked_sub" | "checked_mul" | "compare"), _), + stack -> + fail (Bad_stack (loc, 2, Stack_ty stack)) + (* Generic parsing errors *) + | Prim (loc, prim, _), _ -> + fail @@ Invalid_primitive (loc, Instr, prim) + | (Int (loc, _) | String (loc, _)), _ -> + fail @@ Invalid_expression_kind loc + end >>=? fun judgement -> + begin match judgement, script_instr, log with + | Typed (_, after_ty), Prim (loc, _, _), Some log -> + log loc (Stack_ty stack_ty, Stack_ty after_ty) + | _ -> () + end ; + return judgement and parse_contract : type arg ret. context -> arg ty -> ret ty -> Script.location -> Contract.t -> @@ -1522,16 +1584,36 @@ let parse_script parse_lambda ctxt ~storage_type arg_type_full ret_type_full code >>=? fun code -> return (Ex { code; arg_type; ret_type; storage; storage_type }) +type type_map = + (int * (Script.expr list * Script.expr list)) list + +let type_map_enc = + let open Data_encoding in + list + (tup2 + int31 + (tup2 + (list Script.expr_encoding) + (list Script.expr_encoding))) + let typecheck_code - : context -> Script.code -> unit tzresult Lwt.t + : context -> Script.code -> type_map tzresult Lwt.t = fun ctxt { code; arg_type; ret_type; storage_type } -> parse_ty arg_type >>=? fun (Ex arg_type) -> parse_ty ret_type >>=? fun (Ex ret_type) -> parse_ty storage_type >>=? fun (Ex storage_type) -> let arg_type_full = Pair_t (Pair_t (Tez_t, arg_type), storage_type) in let ret_type_full = Pair_t (ret_type, storage_type) in - parse_lambda ctxt ~storage_type arg_type_full ret_type_full code >>=? fun _ -> - return () + let result = ref [] in + let log loc (Stack_ty before, Stack_ty after) = + let rec unparse_stack + : type a. a stack_ty -> Script.expr list + = function + | Empty_t -> [] + | Item_t (ty, rest) -> unparse_ty ty :: unparse_stack rest in + result := (loc, (unparse_stack before, unparse_stack after)) :: !result in + parse_lambda ctxt ~log ~storage_type arg_type_full ret_type_full code >>=? fun _ -> + return !result let typecheck_tagged_data : context -> Script.expr -> unit tzresult Lwt.t diff --git a/src/proto/bootstrap/script_repr.ml b/src/proto/bootstrap/script_repr.ml index 2480e695f..a77cf9e04 100644 --- a/src/proto/bootstrap/script_repr.ml +++ b/src/proto/bootstrap/script_repr.ml @@ -92,7 +92,7 @@ let update_locations ir = (narg :: nargs, ni)) ([], succ i) args in (Seq (i, List.rev nargs), ni) in - fst (update_locations 0 ir) + fst (update_locations 1 ir) let expr_encoding = Data_encoding.conv diff --git a/src/proto/bootstrap/services.ml b/src/proto/bootstrap/services.ml index 721d099c9..987610ed9 100644 --- a/src/proto/bootstrap/services.ml +++ b/src/proto/bootstrap/services.ml @@ -331,7 +331,7 @@ module Helpers = struct RPC.service ~description: "Typecheck a piece of code in the current context" ~input: Script.code_encoding - ~output: (wrap_tzerror empty) + ~output: (wrap_tzerror Script_ir_translator.type_map_enc) RPC.Path.(custom_root / "helpers" / "typecheck_code") let typecheck_tagged_data custom_root =