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

Michelson: Switch parser/printer/representation to Micheline

Browse Source
This commit is contained in:
Benjamin Canou 2017-11-02 18:57:17 +01:00
parent e18802b32e
commit b22f02868f
36 changed files with 2426 additions and 2237 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/client/embedded/alpha/client_proto_context.ml
View File

@ -46,8 +46,8 @@ let transfer rpc_config
get_branch rpc_config block branch >>=? fun (net_id, branch) ->
begin match arg with
| Some arg ->
Client_proto_programs.parse_data arg >>=? fun arg ->
return (Some arg.ast)
Lwt.return (Michelson_v1_parser.parse_expression arg) >>=? fun { expanded = arg } ->
return (Some arg)
| None -> return None
end >>=? fun parameters ->
Client_proto_rpcs.Context.Contract.counter
@ -105,9 +105,8 @@ let originate_account rpc_config
let originate_contract rpc_config
block ?force ?branch
~source ~src_pk ~src_sk ~manager_pkh ~balance ?delegatable ?delegatePubKey
~(code:Script.code) ~init ~fee ~spendable () =
Client_proto_programs.parse_data init >>=? fun storage ->
let storage = Script.{ storage=storage.ast ; storage_type = code.storage_type } in
~code ~init ~fee ~spendable () =
Lwt.return (Michelson_v1_parser.parse_expression init) >>=? fun { expanded = storage } ->
Client_proto_rpcs.Context.Contract.counter
rpc_config block source >>=? fun pcounter ->
let counter = Int32.succ pcounter in
@ -279,7 +278,7 @@ let commands () =
| None ->
cctxt.error "This is not a smart contract."
| Some storage ->
cctxt.answer "%a" Client_proto_programs.print_storage storage >>= fun () ->
cctxt.answer "%a" Michelson_v1_printer.print_expr_unwrapped storage >>= fun () ->
return ()
end ;
@ -384,7 +383,7 @@ let commands () =
combine with -init if the storage type is not unit"
@@ stop)
begin fun (fee, delegate, force, delegatable, spendable, init)
neu (_, manager) balance (_, source) { ast = code } cctxt ->
neu (_, manager) balance (_, source) { expanded = code } cctxt ->
check_contract cctxt neu >>=? fun () ->
get_delegate_pkh cctxt delegate >>=? fun delegate ->
get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
@ -395,7 +394,11 @@ let commands () =
~spendable:spendable
() >>=function
| Error errs ->
Client_proto_programs.report_errors cctxt errs >>= fun () ->
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details: true
~show_source: true
?parsed:None) errs >>= fun () ->
cctxt.error "origination simulation failed"
| Ok (oph, contract) ->
message_injection cctxt
@ -443,7 +446,11 @@ let commands () =
~source ~src_pk ~src_sk ~destination
~arg ~amount ~fee () >>= function
| Error errs ->
Client_proto_programs.report_errors cctxt errs >>= fun () ->
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details: false
~show_source: true
?parsed:None) errs >>= fun () ->
cctxt.error "transfer simulation failed"
| Ok (oph, contracts) ->
message_injection cctxt ~force:force ~contracts oph >>= fun () ->

2
src/client/embedded/alpha/client_proto_context.mli
View File

@ -57,7 +57,7 @@ val originate_contract:
balance:Tez.t ->
?delegatable:bool ->
?delegatePubKey:public_key_hash ->
code:Script.code ->
code:Script.expr ->
init:string ->
fee:Tez.t ->
spendable:bool ->

792
src/client/embedded/alpha/client_proto_programs.ml
View File

@ -9,691 +9,21 @@
module Ed25519 = Environment.Ed25519
open Client_proto_args
let report_parse_error prefix exn =
let open Lexing in
let open Script_located_ir in
let print_point ppf { line ; column } =
Format.fprintf ppf
"at line %d character %d"
line column in
let print_token ppf = function
| Michelson_parser.Open_paren
| Michelson_parser.Close_paren ->
Format.fprintf ppf "parenthesis"
| Michelson_parser.Open_brace
| Michelson_parser.Close_brace ->
Format.fprintf ppf "curly brace"
| Michelson_parser.String _ ->
Format.fprintf ppf "string constant"
| Michelson_parser.Int _ ->
Format.fprintf ppf "integer constant"
| Michelson_parser.Ident _ ->
Format.fprintf ppf "identifier"
| Michelson_parser.Annot _ ->
Format.fprintf ppf "annotation"
| Michelson_parser.Comment _
| Michelson_parser.Eol_comment _ ->
Format.fprintf ppf "comment"
| Michelson_parser.Semi ->
Format.fprintf ppf "semi colon" in
let print_loc ppf loc =
Format.fprintf ppf "in %s, " prefix ;
if loc.start.line = loc.stop.line then
if loc.start.column = loc.stop.column then
Format.fprintf ppf
"at line %d character %d"
loc.start.line loc.start.column
else
Format.fprintf ppf
"at line %d characters %d to %d"
loc.start.line loc.start.column loc.stop.column
else
Format.fprintf ppf
"from line %d character %d to line %d character %d"
loc.start.line loc.start.column loc.stop.line loc.stop.column in
match exn with
| Script_located_ir.Missing_program_field n ->
failwith "missing script %s" n
| Michelson_parser.Invalid_utf8_sequence (point, str) ->
failwith "%a, invalid UTF-8 sequence %S" print_point point str
| Michelson_parser.Unexpected_character (point, str) ->
failwith "%a, unexpected character %s" print_point point str
| Michelson_parser.Undefined_escape_character (point, str) ->
failwith "%a, undefined escape character \"%s\"" print_point point str
| Michelson_parser.Missing_break_after_number point ->
failwith "%a, missing break" print_point point
| Michelson_parser.Unterminated_string loc ->
failwith "%a, unterminated string" print_loc loc
| Michelson_parser.Unterminated_integer loc ->
failwith "%a, unterminated integer" print_loc loc
| Michelson_parser.Unterminated_comment loc ->
failwith "%a, unterminated comment" print_loc loc
| Michelson_parser.Unclosed { loc ; token } ->
failwith "%a, unclosed %a" print_loc loc print_token token
| Michelson_parser.Unexpected { loc ; token } ->
failwith "%a, unexpected %a" print_loc loc print_token token
| Michelson_parser.Extra { loc ; token } ->
failwith "%a, extra %a" print_loc loc print_token token
| Michelson_parser.Misaligned node ->
failwith "%a, misaligned expression" print_loc (node_location node)
| Michelson_parser.Empty ->
failwith "empty expression"
| Failure s ->
failwith "%s" s
| exn ->
failwith "%s" @@ Printexc.to_string exn
let print_location_mark ppf = function
| None -> ()
| Some l -> Format.fprintf ppf " /* %d */" l
let no_locations _ = None
let print_annotation ppf = function
| None -> ()
| Some a -> Format.fprintf ppf " %s@," a
let rec print_expr_unwrapped_help emacs locations ppf = function
| Script.Prim (loc, name, [], None) ->
begin match locations loc with
| None -> Format.fprintf ppf "%s" name
| Some _ as l -> Format.fprintf ppf "%s%a" name print_location_mark l
end
| Script.Prim (loc, name, _, (Some _ as annot)) ->
Format.fprintf ppf (if emacs then "%s%a %a" else "@[<hov 2>%s%a@ %a]")
name print_location_mark (locations loc) print_annotation annot
| Script.Prim (loc, name, args, annot) ->
Format.fprintf ppf "@[<hv 2>%s%a%a@ %a@]"
name
print_location_mark (locations loc)
print_annotation annot
(Format.pp_print_list
~pp_sep: Format.pp_print_space
(print_expr_help emacs locations))
args
| Script.Seq (loc, [], None) ->
begin match locations loc with
| None -> Format.fprintf ppf "{}"
| Some _ as l -> Format.fprintf ppf "{%a }" print_location_mark l
end
| Script.Seq (loc, exprs, annot) ->
begin match locations loc with
| None -> Format.fprintf ppf "@[<hv 2>{ "
| Some _ as l -> Format.fprintf ppf "@[<hv 2>{%a@ " print_location_mark l
end ;
Format.fprintf ppf "%a%a@] }"
(Format.pp_print_list
~pp_sep: (fun ppf () -> Format.fprintf ppf " ;@ ")
(print_expr_unwrapped_help emacs locations))
exprs
print_annotation annot
| Script.Int (loc, n) ->
Format.fprintf ppf "%s%a" n print_location_mark (locations loc)
| Script.String (loc, s) ->
Format.fprintf ppf "%S%a" s print_location_mark (locations loc)
and print_expr_help emacs locations ppf = function
| Script.Prim (_, _, _ :: _, _)
| Script.Prim (_, _, [], Some _) as expr ->
Format.fprintf ppf "(%a)" (print_expr_unwrapped_help emacs locations) expr
| Script.Prim (loc, _, [], None) as expr when locations loc <> None ->
Format.fprintf ppf "(%a)" (print_expr_unwrapped_help emacs locations) expr
| expr -> print_expr_unwrapped_help emacs locations ppf expr
let print_expr_unwrapped = print_expr_unwrapped_help false
let print_expr = print_expr_help false
let print_storage ppf ({ storage } : Script.storage) =
print_expr no_locations ppf storage
let print_stack_help emacs ppf = function
| [] -> Format.fprintf ppf (if emacs then "()" else "[]")
| more ->
Format.fprintf ppf (if emacs then "(%a)" else "@[<hov 2>[ %a ]@]")
(Format.pp_print_list
~pp_sep: (fun ppf () -> Format.fprintf ppf (if emacs then "@ " else " :@ "))
((if emacs then print_expr else print_expr_unwrapped) no_locations))
more
let print_stack = print_stack_help false
let print_emacs_stack = print_stack_help true
let print_typed_code locations ppf (expr, type_map) =
let print_stack ppf = function
| [] -> Format.fprintf ppf "[]"
| more ->
Format.fprintf ppf "@[<hov 2>[ %a ]@]"
(Format.pp_print_list
~pp_sep: (fun ppf () -> Format.fprintf ppf " :@ ")
(print_expr_unwrapped no_locations))
more in
let print_annot ppf = function
| None -> ()
| Some annot -> Format.fprintf ppf " %s@," annot in
let rec print_typed_code_unwrapped ppf expr =
match expr with
| Script.Prim (loc, name, [], None) ->
Format.fprintf ppf "%s%a"
name print_location_mark (locations loc)
| Script.Prim (loc, name, [], Some annot) ->
Format.fprintf ppf "(%s %s%a)"
name annot print_location_mark (locations loc)
| Script.Prim (loc, name, args, annot) ->
Format.fprintf ppf "@[<v 2>%s%a%a@ %a@]"
name print_annot annot print_location_mark (locations loc)
(Format.pp_print_list
~pp_sep: Format.pp_print_space
print_typed_code)
args
| Script.Seq (loc, [], None) ->
begin match List.assoc loc type_map with
| exception Not_found -> Format.fprintf ppf "{}"
| (first, _) ->
match locations loc with
| None ->
Format.fprintf ppf "{} /* %a */"
print_stack first
| Some _ as l ->
Format.fprintf ppf "{%a %a }"
print_location_mark l print_stack first
end
| Script.Seq (loc, [], Some annot) ->
begin match List.assoc loc type_map with
| exception Not_found -> Format.fprintf ppf "{ %@%s }" annot
| (first, _) ->
match locations loc with
| None ->
Format.fprintf ppf "{ %@%s } /* %a */"
annot
print_stack first
| Some _ as l ->
Format.fprintf ppf "{ %@%s%a %a }"
annot print_location_mark l print_stack first
end
| Script.Seq (loc, exprs, annot) ->
begin match locations loc, annot with
| None, None ->
Format.fprintf ppf "@[<v 2>{ "
| None, Some annot ->
Format.fprintf ppf "@[<v 2>{ %@%s@," annot
| Some _ as l, _ ->
Format.fprintf ppf "@[<v 2>{%a%a@,"
print_annot annot
print_location_mark l
end ;
let rec loop = function
| [] -> assert false
| [ Script.Int (loc, _) | String (loc, _) | Prim (loc, _, _, _) as expr ] ->
begin match List.assoc loc type_map with
| exception Not_found ->
Format.fprintf ppf "%a }@]"
print_typed_code_unwrapped expr
| (before, after) ->
Format.fprintf ppf "/* %a */@,%a@,/* %a */ }@]"
print_stack before
print_typed_code_unwrapped expr
print_stack after
end ;
| Script.Int (loc, _) | String (loc, _) | Prim (loc, _, _, _) as expr :: rest ->
begin match List.assoc loc type_map with
| exception Not_found ->
Format.fprintf ppf "%a ;@,"
print_typed_code_unwrapped expr ;
loop rest
| (before, _) ->
Format.fprintf ppf "/* %a */@,%a ;@,"
print_stack before
print_typed_code_unwrapped expr ;
loop rest
end ;
| [ Seq (_, _, _) as expr ] ->
Format.fprintf ppf "%a }@]"
print_typed_code_unwrapped expr
| Seq (_, _, _) as expr :: rest ->
Format.fprintf ppf "%a@,"
print_typed_code_unwrapped expr ;
loop rest in
loop exprs ;
| Script.Int (loc, n) ->
Format.fprintf ppf "%s%a" n print_location_mark (locations loc)
| Script.String (loc, s) ->
Format.fprintf ppf "%S%a" s print_location_mark (locations loc)
and print_typed_code ppf = function
| Script.Prim (_, _, _ :: _, _) as expr ->
Format.fprintf ppf "(%a)" print_typed_code_unwrapped expr
| expr -> print_typed_code_unwrapped ppf expr in
print_typed_code_unwrapped ppf expr
let print_program locations ppf ((c : Script.code), type_map) =
Format.fprintf ppf
"@[<v 0>%a ;@,%a ;@,%a ;@,\
@[<hov 2>code@ %a@]@]"
(print_expr_unwrapped no_locations) (Script.Prim (-1, "storage", [ c.storage_type ], None))
(print_expr_unwrapped no_locations) (Script.Prim (-1, "parameter", [ c.arg_type ], None))
(print_expr_unwrapped no_locations) (Script.Prim (-1, "return", [ c.ret_type ], None))
(print_typed_code locations) (c.code, type_map)
let collect_error_locations errs =
let open Script_typed_ir in
let open Script_ir_translator in
let open Script_interpreter in
let rec collect acc = function
| (Ill_typed_data (_, _, _)
| Ill_formed_type (_, _)
| Ill_typed_contract (_, _, _, _, _)) :: _
| [] -> acc
| (Invalid_arity (loc, _, _, _)
| Invalid_namespace (loc, _, _, _)
| Invalid_primitive (loc, _, _)
| Invalid_case (loc, _)
| Invalid_kind (loc, _, _)
| Fail_not_in_tail_position loc
| Undefined_binop (loc, _, _, _)
| Undefined_unop (loc, _, _)
| Bad_return (loc, _, _)
| Bad_stack (loc, _, _, _)
| Unmatched_branches (loc, _, _)
| Transfer_in_lambda loc
| Transfer_in_dip loc
| Invalid_constant (loc, _, _)
| Invalid_contract (loc, _)
| Comparable_type_expected (loc, _)
| Overflow loc
| Reject loc) :: rest ->
collect (loc :: acc) rest
| _ :: rest -> collect acc rest in
collect [] errs
let report_errors cctxt errs =
let open Client_commands in
let open Script_typed_ir in
let open Script_ir_translator in
let open Script_interpreter in
let rec print_ty (type t) ppf (ty : t ty) =
let expr = unparse_ty ty in
print_expr no_locations ppf expr in
let rec print_stack_ty (type t) ?(depth = max_int) ppf (s : t stack_ty) =
let rec loop
: type t. int -> Format.formatter -> t stack_ty -> unit
= fun depth ppf -> function
| Empty_t -> ()
| _ when depth <= 0 ->
Format.fprintf ppf "..."
| Item_t (last, Empty_t) ->
Format.fprintf ppf "%a"
print_ty last
| Item_t (last, rest) ->
Format.fprintf ppf "%a :@ %a"
print_ty last (loop (depth - 1)) rest in
match s with
| Empty_t ->
Format.fprintf ppf "[]"
| sty ->
Format.fprintf ppf "@[<hov 2>[ %a ]@]" (loop depth) sty in
let rec print_enumeration ppf = function
| [ single ] ->
Format.fprintf ppf "%a"
Format.pp_print_text single
| [ prev ; last ] ->
Format.fprintf ppf "%a@ or@ %a"
Format.pp_print_text prev Format.pp_print_text last
| first :: rest ->
Format.fprintf ppf "%a,@ %a"
Format.pp_print_text first print_enumeration rest
| [] -> assert false in
let print_error locations err =
let print_loc ppf loc =
match locations loc with
| None ->
Format.fprintf ppf "At (unmarked) location %d, " loc
| Some loc ->
Format.fprintf ppf "At mark /* %d */, " loc in
match err with
| Ill_typed_data (name, expr, ty) ->
cctxt.warning
"@[<hv 0>@[<hov 2>Ill typed %adata:@ %a@]@ \
@[<hov 2>is not an expression of type@ %a@]@]"
(fun ppf -> function
| None -> ()
| Some s -> Format.fprintf ppf "%s " s)
name
(print_expr locations) expr
print_ty ty
| Ill_formed_type (name, expr) ->
cctxt.warning
"@[<hov 2>Ill formed type %aexpression@ %a@]"
(fun ppf -> function
| None -> ()
| Some s -> Format.fprintf ppf "%s " s)
name
(print_expr locations) expr
| Apply.Bad_contract_parameter (c, None, _) ->
cctxt.warning
"@[<v 0>Account %a is not a smart contract, it does not take arguments.@,\
The `-arg' flag cannot be used when transferring to an account.@]"
Contract.pp c
| Apply.Bad_contract_parameter (c, Some expected, None) ->
cctxt.warning
"@[<v 0>Contract %a expected an argument of type@, %a@,but no argument was provided.@,\
The `-arg' flag can be used when transferring to a smart contract.@]"
Contract.pp c
(print_expr_unwrapped no_locations) expected
| Apply.Bad_contract_parameter (c, Some expected, Some argument) ->
cctxt.warning
"@[<v 0>Contract %a expected an argument of type@, %a@but received@, %a@]"
Contract.pp c
(print_expr_unwrapped no_locations) expected
(print_expr_unwrapped no_locations) argument
| Ill_typed_contract (expr, arg_ty, ret_ty, storage_ty, type_map) ->
cctxt.warning
"@[<v 2>Ill typed contract:@ %a@]"
(print_program locations)
({ Script.storage_type = unparse_ty storage_ty ;
arg_type = unparse_ty arg_ty ;
ret_type = unparse_ty ret_ty ;
code = expr }, type_map)
| Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty) ->
cctxt.warning
"@[<v 2>Runtime error in contract %a:@ %a@]"
Contract.pp contract
(print_program locations)
({ Script.storage_type = unparse_ty storage_ty ;
arg_type = unparse_ty arg_ty ;
ret_type = unparse_ty ret_ty ;
code = expr }, [])
| Invalid_arity (loc, name, exp, got) ->
cctxt.warning
"%aprimitive %s expects %d arguments but is given %d."
print_loc loc name exp got
| Invalid_namespace (loc, name, exp, got) ->
let human_namespace = function
| Instr_namespace -> ("an", "instruction")
| Type_namespace -> ("a", "type name")
| Constant_namespace -> ("a", "constant constructor") in
cctxt.warning
"@[%aunexpected %s %s, only@ %s@ %s@ can@ be@ used@ here."
print_loc loc
(snd (human_namespace got))
name
(fst (human_namespace exp)) (snd (human_namespace exp))
| Invalid_primitive (loc, exp, got) ->
cctxt.warning
"@[%ainvalid primitive %s, only@ %a@ can@ be@ used@ here."
print_loc loc
got
print_enumeration exp
| Invalid_case (loc, name) ->
cctxt.warning
"%a%s is not a valid primitive name."
print_loc loc
name
| Invalid_kind (loc, exp, got) ->
let human_kind = function
| Seq_kind -> ("a", "sequence")
| Prim_kind -> ("a", "primitive")
| Int_kind -> ("an", "int")
| String_kind -> ("a", "string") in
cctxt.warning
"@[%aunexpected %s, only@ %a@ can@ be@ used@ here."
print_loc loc
(snd (human_kind got))
print_enumeration
(List.map (fun k -> let (a, n) = human_kind k in a ^ " " ^ n) exp)
| Duplicate_map_keys (_, expr) ->
cctxt.warning
"@[<v 2>Map literals cannot contain duplicate keys, \
however a duplicate key was found:@ \
@[%a@]"
(print_expr no_locations) expr
| Unordered_map_keys (_, expr) ->
cctxt.warning
"@[<v 2>Keys in a map literal must be in strictly ascending order, \
but they were unordered in literal:@ \
@[%a@]"
(print_expr no_locations) expr
| Duplicate_set_values (_, expr) ->
cctxt.warning
"@[<v 2>Set literals cannot contain duplicate values, \
however a duplicate value was found:@ \
@[%a@]"
(print_expr no_locations) expr
| Unordered_set_values (_, expr) ->
cctxt.warning
"@[<v 2>Values in a set literal must be in strictly ascending order, \
but they were unordered in literal:@ \
@[%a@]"
(print_expr no_locations) expr
| Fail_not_in_tail_position loc ->
cctxt.warning
"%aThe FAIL instruction must appear in a tail position."
print_loc loc
| Undefined_binop (loc, name, tya, tyb) ->
cctxt.warning
"@[<hov 0>@[<hov 2>%aoperator %s is undefined between@ %a@]@ \
@[<hov 2>and@ %a.@]@]"
print_loc loc
name
print_ty tya
print_ty tyb
| Undefined_unop (loc, name, ty) ->
cctxt.warning
"@[<hov 0>@[<hov 2>%aoperator %s is undefined on@ %a@]@]"
print_loc loc
name
print_ty ty
| Bad_return (loc, got, exp) ->
cctxt.warning
"@[<v 2>%awrong stack type at end of body:@,\
- @[<hov>expected return stack type:@ %a,@]@,\
- @[<hov>actual stack type:@ %a.@]@]"
print_loc loc
(fun ppf -> print_stack_ty ppf) (Item_t (exp, Empty_t))
(fun ppf -> print_stack_ty ppf) got
| Bad_stack (loc, name, depth, sty) ->
cctxt.warning
"@[<hov 2>%awrong stack type for instruction %s:@ %a.@]"
print_loc loc name (print_stack_ty ~depth) sty
| Unmatched_branches (loc, sta, stb) ->
cctxt.warning
"@[<v 2>%atwo branches don't end with the same stack type:@,\
- @[<hov>first stack type:@ %a,@]@,\
- @[<hov>other stack type:@ %a.@]@]"
print_loc loc
(fun ppf -> print_stack_ty ppf) sta
(fun ppf -> print_stack_ty ppf) stb
| Transfer_in_lambda loc ->
cctxt.warning
"%aThe TRANSFER_TOKENS instruction cannot appear in a lambda."
print_loc loc
| Transfer_in_dip loc ->
cctxt.warning
"%aThe TRANSFER_TOKENS instruction cannot appear within a DIP."
print_loc loc
| Bad_stack_length ->
cctxt.warning
"Bad stack length."
| Bad_stack_item lvl ->
cctxt.warning
"Bad stack item %d ."
lvl
| Invalid_constant (loc, got, exp) ->
cctxt.warning
"@[<hov 0>@[<hov 2>%avalue@ %a@]@ \
@[<hov 2>is invalid for type@ %a.@]@]"
print_loc loc
(fun ppf -> print_expr no_locations ppf) got
print_ty exp
| Invalid_contract (loc, contract) ->
cctxt.warning
"%ainvalid contract %a."
print_loc loc Contract.pp contract
| Comparable_type_expected (loc, ty) ->
cctxt.warning "%acomparable type expected."
print_loc loc >>= fun () ->
cctxt.warning "@[<hov 0>@[<hov 2>Type@ %a@]@ is not comparable.@]"
print_ty ty
| Inconsistent_types (tya, tyb) ->
cctxt.warning
"@[<hov 0>@[<hov 2>Type@ %a@]@ \
@[<hov 2>is not compatible with type@ %a.@]@]"
print_ty tya print_ty tyb
| Reject _ -> cctxt.warning "Script reached FAIL instruction"
| Overflow _ -> cctxt.warning "Unexpected arithmetic overflow"
| err ->
cctxt.warning "%a"
Environment.Error_monad.pp_print_error [ err ] in
let rec print_error_trace locations errs =
let locations = match errs with
| (Ill_typed_data (_, _, _)
| Ill_formed_type (_, _)
| Ill_typed_contract (_, _, _, _, _)
| Runtime_contract_error (_, _, _, _, _)) :: rest ->
let collected =
collect_error_locations rest in
let assoc, _ =
List.fold_left
(fun (acc, i) l ->
if List.mem_assoc l acc then
(acc, i)
else
((l, i) :: acc, i + 1))
([], 1) collected in
(fun l -> try Some (List.assoc l assoc) with Not_found -> None)
| _ -> locations in
match errs with
| [] -> Lwt.return ()
| err :: errs ->
print_error locations err >>= fun () ->
print_error_trace locations errs in
Lwt_list.iter_s
(function
| Environment.Ecoproto_error errs ->
print_error_trace no_locations errs
| err -> cctxt.warning "%a" pp_print_error [ err ])
errs
type 'a parsed =
{ ast : 'a ;
source : string ;
loc_table : (string * (int * Script_located_ir.location) list) list }
let parse_program source =
try
let fields = Michelson_parser.parse_toplevel (Michelson_parser.tokenize source) in
let fields = List.map Script_located_ir.strip_locations fields in
let rec get_field n = function
| (Script.Prim (_, pn, [ ctns ], _), locs) :: _ when n = pn -> ctns, locs
| _ :: rest -> get_field n rest
| [] -> raise (Script_located_ir.Missing_program_field n) in
let code, code_loc_table = get_field "code" fields in
let arg_type, parameter_loc_table = get_field "parameter" fields in
let ret_type, return_loc_table = get_field "return" fields in
let storage_type, storage_loc_table = get_field "storage" fields in
let ast = Script.{ code ; arg_type ; ret_type ; storage_type } in
let loc_table =
[ "code", code_loc_table ;
"parameter", parameter_loc_table ;
"return", return_loc_table ;
"storage", storage_loc_table ] in
return { ast ; source ; loc_table }
with
| exn -> report_parse_error "program" exn
let parse_data source =
try
let node = Michelson_parser.parse_expression (Michelson_parser.tokenize source) in
let ast, loc_table = Script_located_ir.strip_locations node in
let loc_table = [ "data", loc_table ] in
return { ast ; source ; loc_table }
with
| exn -> report_parse_error "data" exn
let parse_data_type source =
try
let node = Michelson_parser.parse_expression (Michelson_parser.tokenize source) in
let ast, loc_table = Script_located_ir.strip_locations node in
let loc_table = [ "data", loc_table ] in
return { ast ; source ; loc_table }
with
| exn -> report_parse_error "type" exn
let unexpand_macros type_map (program : Script.code) =
let open Script in
let rec first_prim_in_sequence = function
| Int _ | String _ -> None
| Prim (loc, _, _, _) -> Some loc
| Seq (_, children, _) ->
let rec loop = function
| [] -> None
| child :: children ->
match first_prim_in_sequence child with
| None -> loop children
| Some loc -> Some loc in
loop children in
let rec last_prim_in_sequence = function
| Int _ | String _ -> None
| Prim (loc, _, _, _) -> Some loc
| Seq (_, children, _) ->
let rec reversed = function
| [] -> None
| child :: children ->
match last_prim_in_sequence child with
| None -> reversed children
| Some loc -> Some loc in
reversed (List.rev children) in
let rec unexpand type_map original =
match Michelson_macros.unexpand original with
| Seq (loc, children, annot) ->
let type_map, children =
List.fold_left
(fun (type_map, acc) node ->
let type_map, node = unexpand type_map node in
type_map, node :: acc)
(type_map, []) children in
type_map, Seq (loc, List.rev children, annot)
| Prim (loc, name, children, annot) ->
let type_map =
match original with
| Seq _ ->
if List.mem_assoc loc type_map then
type_map
else
begin match first_prim_in_sequence original, last_prim_in_sequence original with
| None, _ | _, None -> type_map
| Some floc, Some lloc ->
let fty, _ = List.assoc floc type_map in
let _, lty = List.assoc lloc type_map in
(loc, (fty, lty)) :: type_map
end
| _ -> type_map in
let type_map, children =
List.fold_left
(fun (type_map, acc) node ->
let type_map, node = unexpand type_map node in
type_map, node :: acc)
(type_map, []) children in
type_map, Prim (loc, name, List.rev children, annot)
| oth -> type_map, oth in
let type_map, code = unexpand type_map program.code in
type_map, { program with code }
open Michelson_v1_printer
module Program = Client_aliases.Alias (struct
type t = Script.code parsed
type t = Michelson_v1_parser.parsed
let encoding =
let open Data_encoding in
let loc_table_encoding =
assoc (list (tup2 uint16 Script_located_ir.location_encoding)) in
conv
(fun { ast ; source ; loc_table } -> (ast, source, loc_table))
(fun (ast, source, loc_table) -> { ast ; source ; loc_table })
(obj3
(req "ast" Script.code_encoding)
(req "source" string)
(req "loc_table" loc_table_encoding))
let of_source _cctxt s = parse_program s
let to_source _ { source } = return source
Data_encoding.conv
(fun { Michelson_v1_parser.source } -> source)
(fun source ->
match Michelson_v1_parser.parse_toplevel source with
| Ok parsed -> parsed
| Error _ -> Pervasives.failwith "could not decode Michelson program alias")
Data_encoding.string
let of_source _cctxt source =
Lwt.return (Michelson_v1_parser.parse_toplevel source)
let to_source _ { Michelson_v1_parser.source } = return source
let name = "program"
end)
@ -702,7 +32,7 @@ let group =
title = "Commands for managing the record of known programs" }
let data_parameter =
Cli_entries.parameter (fun _ -> parse_data)
Cli_entries.parameter (fun _ data -> Lwt.return (Michelson_v1_parser.parse_expression data))
let commands () =
let open Cli_entries in
@ -772,36 +102,40 @@ let commands () =
(fun (trace_stack, amount) program storage input cctxt ->
let open Data_encoding in
let print_errors errs =
report_errors cctxt errs >>= fun () ->
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source: true
~parsed:program) errs >>= fun () ->
cctxt.error "error running program" >>= fun () ->
return () in
if trace_stack then
Client_proto_rpcs.Helpers.trace_code cctxt.rpc_config
cctxt.config.block program.ast (storage.ast, input.ast, amount) >>= function
cctxt.config.block program.expanded (storage.expanded, input.expanded, amount) >>= function
| Ok (storage, output, trace) ->
cctxt.message
"@[<v 0>@[<v 2>storage@,%a@]@,\
@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
(print_expr no_locations) storage
(print_expr no_locations) output
print_expr storage
print_expr output
(Format.pp_print_list
(fun ppf (loc, gas, stack) ->
Format.fprintf ppf
"- @[<v 0>location: %d (remaining gas: %d)@,\
[ @[<v 0>%a ]@]@]"
loc gas
(Format.pp_print_list (print_expr no_locations))
(Format.pp_print_list print_expr)
stack))
trace >>= fun () ->
return ()
| Error errs -> print_errors errs
else
Client_proto_rpcs.Helpers.run_code cctxt.rpc_config
cctxt.config.block program.ast (storage.ast, input.ast, amount) >>= function
cctxt.config.block program.expanded (storage.expanded, input.expanded, amount) >>= function
| Ok (storage, output) ->
cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
(print_expr no_locations) storage
(print_expr no_locations) output >>= fun () ->
print_expr storage
print_expr output >>= fun () ->
return ()
| Error errs ->
print_errors errs);
@ -814,64 +148,36 @@ let commands () =
(fun (show_types, emacs_mode) program cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.typecheck_code
cctxt.rpc_config cctxt.config.block program.ast >>= fun res ->
cctxt.rpc_config cctxt.config.block program.expanded >>= fun res ->
if emacs_mode then
let emacs_type_map type_map =
(Utils.filter_map
(fun (n, loc) ->
try
let bef, aft = List.assoc n type_map in
Some (loc, bef, aft)
with
Not_found -> None)
(List.assoc "code" program.loc_table),
[]) in
begin match res with
| Ok type_map ->
Lwt.return (emacs_type_map type_map)
let type_map, errs = match res with
| Ok type_map -> type_map, []
| Error (Environment.Ecoproto_error
(Script_ir_translator.Ill_typed_contract (_, type_map ) :: _)
:: _ as errs) ->
type_map, errs
| Error errs ->
let msg = Buffer.create 5000 in
let cctxt = Client_commands.make_context
(fun _ t -> Buffer.add_string msg t ; Buffer.add_char msg '\n' ; Lwt.return ()) in
match errs with
| Environment.Ecoproto_error (Script_ir_translator.Ill_formed_type
(Some ("return" | "parameter" | "storage" as field), _) :: errs) :: _ ->
report_errors cctxt [ Environment.Ecoproto_error errs ] >>= fun () ->
Lwt.return ([], [ List.assoc 0 (List.assoc field program.loc_table), Buffer.contents msg ])
| Environment.Ecoproto_error (Script_ir_translator.Ill_typed_contract (_, _, _, _, type_map) :: errs) :: _ ->
(report_errors cctxt [ Environment.Ecoproto_error errs ] >>= fun () ->
let (types, _) = emacs_type_map type_map in
let loc = match collect_error_locations errs with
| hd :: _ -> hd
| [] -> 0 in
Lwt.return (types, [ List.assoc loc (List.assoc "code" program.loc_table), Buffer.contents msg ]))
| _ -> Lwt.return ([], [])
end >>= fun (types, errors) ->
[], errs in
cctxt.message
"((types . (%a)) (errors . (%a)))"
(Format.pp_print_list
(fun ppf ({ Script_located_ir.start = { point = s } ; stop = { point = e } },
bef, aft) ->
Format.fprintf ppf "(%d %d %a %a)" (s + 1) (e + 1)
print_emacs_stack bef print_emacs_stack aft))
types
(Format.pp_print_list
(fun ppf ({ Script_located_ir.start = { point = s } ; stop = { point = e } },
err) ->
Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) err))
errors >>= fun () ->
"(@[<v 0>(types . %a)@ (errors . %a)@])"
Michelson_v1_emacs.print_type_map (program, type_map)
Michelson_v1_emacs.report_errors (program, errs) >>= fun () ->
return ()
else
match res with
| Ok type_map ->
let type_map, program = unexpand_macros type_map program.ast in
let program = inject_types type_map program in
cctxt.message "Well typed" >>= fun () ->
if show_types then
cctxt.message "%a" (print_program no_locations) (program, type_map) >>= fun () ->
cctxt.message "%a" Micheline_printer.print_expr program >>= fun () ->
return ()
else return ()
| Error errs ->
report_errors cctxt errs >>= fun () ->
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details: show_types
~show_source: true
~parsed:program) errs >>= fun () ->
cctxt.error "ill-typed program") ;
command ~group ~desc: "ask the node to typecheck a data expression"
@ -886,12 +192,16 @@ let commands () =
(fun () data exp_ty cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config
cctxt.config.block (data.ast, exp_ty.ast) >>= function
cctxt.config.block (data.expanded, exp_ty.expanded) >>= function
| Ok () ->
cctxt.message "Well typed" >>= fun () ->
return ()
| Error errs ->
report_errors cctxt errs >>= fun () ->
cctxt.warning "%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source: true
?parsed:None) errs >>= fun () ->
cctxt.error "ill-typed data") ;
command ~group
@ -905,7 +215,7 @@ let commands () =
(fun () data cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config
cctxt.config.block (data.ast) >>= function
cctxt.config.block (data.expanded) >>= function
| Ok hash ->
cctxt.message "%S" hash >>= fun () ->
return ()
@ -928,7 +238,7 @@ let commands () =
(fun () data (_, key) cctxt ->
let open Data_encoding in
Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config
cctxt.config.block (data.ast) >>= function
cctxt.config.block (data.expanded) >>= function
| Ok hash ->
let signature = Ed25519.sign key (MBytes.of_string hash) in
cctxt.message "Hash: %S@.Signature: %S"

15
src/client/embedded/alpha/client_proto_programs.mli
View File

@ -7,19 +7,6 @@
(* *)
(**************************************************************************)
type 'a parsed =
{ ast : 'a ;
source : string ;
loc_table : (string * (int * Script_located_ir.location) list) list }
val parse_program: string -> Script.code parsed tzresult Lwt.t
val parse_data: string -> Script.expr parsed tzresult Lwt.t
val parse_data_type: string -> Script.expr parsed tzresult Lwt.t
val print_storage: Format.formatter -> Script.storage -> unit
val report_errors: Client_commands.context -> error list -> unit Lwt.t
module Program : Client_aliases.Alias with type t = Script.code parsed
module Program : Client_aliases.Alias with type t = Michelson_v1_parser.parsed
val commands: unit -> Client_commands.command list

8
src/client/embedded/alpha/client_proto_rpcs.mli
View File

@ -137,7 +137,7 @@ module Context : sig
block -> Contract.t -> Script.t option tzresult Lwt.t
val storage:
Client_rpcs.config ->
block -> Contract.t -> Script.storage option tzresult Lwt.t
block -> Contract.t -> Script.expr option tzresult Lwt.t
end
end
@ -155,18 +155,18 @@ module Helpers : sig
(Contract.t list) tzresult Lwt.t
val run_code:
Client_rpcs.config ->
block -> Script.code ->
block -> Script.expr ->
(Script.expr * Script.expr * Tez.t) ->
(Script.expr * Script.expr) tzresult Lwt.t
val trace_code:
Client_rpcs.config ->
block -> Script.code ->
block -> Script.expr ->
(Script.expr * Script.expr * Tez.t) ->
(Script.expr * Script.expr *
(Script.location * int * Script.expr list) list) tzresult Lwt.t
val typecheck_code:
Client_rpcs.config ->
block -> Script.code -> Script_ir_translator.type_map tzresult Lwt.t
block -> Script.expr -> Script_ir_translator.type_map tzresult Lwt.t
val typecheck_data:
Client_rpcs.config ->
block -> Script.expr * Script.expr -> unit tzresult Lwt.t

6
src/client/embedded/alpha/michelson_macros.ml
View File

@ -7,7 +7,9 @@
(* *)
(**************************************************************************)
open Script_located_ir
open Micheline
type 'l node = ('l, string) Micheline.node
let expand_caddadr original =
match original with
@ -427,8 +429,6 @@ let expand original =
expand_if_some ;
expand_if_right ]
open Script
let unexpand_caddadr expanded =
let rec rsteps acc = function
| [] -> Some acc

52
src/client/embedded/alpha/michelson_macros.mli
View File

@ -7,34 +7,34 @@
(* *)
(**************************************************************************)
open Script_located_ir
open Micheline
val expand : node -> node
type 'l node = ('l, string) Micheline.node
val expand_caddadr : node -> node option
val expand_set_caddadr : node -> node option
val expand_map_caddadr : node -> node option
val expand_dxiiivp : node -> node option
val expand_paaiair : node -> node option
val expand_duuuuup : node -> node option
val expand_compare : node -> node option
val expand_asserts : node -> node option
val expand_unpaaiair : node -> node option
val expand_if_some : node -> node option
val expand_if_right : node -> node option
val expand : 'l node -> 'l node
open Script
val expand_caddadr : 'l node -> 'l node option
val expand_set_caddadr : 'l node -> 'l node option
val expand_map_caddadr : 'l node -> 'l node option
val expand_dxiiivp : 'l node -> 'l node option
val expand_paaiair : 'l node -> 'l node option
val expand_duuuuup : 'l node -> 'l node option
val expand_compare : 'l node -> 'l node option
val expand_asserts : 'l node -> 'l node option
val expand_unpaaiair : 'l node -> 'l node option
val expand_if_some : 'l node -> 'l node option
val expand_if_right : 'l node -> 'l node option
val unexpand : expr -> expr
val unexpand : 'l node -> 'l node
val unexpand_caddadr : expr -> expr option
val unexpand_set_caddadr : expr -> expr option
val unexpand_map_caddadr : expr -> expr option
val unexpand_dxiiivp : expr -> expr option
val unexpand_paaiair : expr -> expr option
val unexpand_duuuuup : expr -> expr option
val unexpand_compare : expr -> expr option
val unexpand_asserts : expr -> expr option
val unexpand_unpaaiair : expr -> expr option
val unexpand_if_some : expr -> expr option
val unexpand_if_right : expr -> expr option
val unexpand_caddadr : 'l node -> 'l node option
val unexpand_set_caddadr : 'l node -> 'l node option
val unexpand_map_caddadr : 'l node -> 'l node option
val unexpand_dxiiivp : 'l node -> 'l node option
val unexpand_paaiair : 'l node -> 'l node option
val unexpand_duuuuup : 'l node -> 'l node option
val unexpand_compare : 'l node -> 'l node option
val unexpand_asserts : 'l node -> 'l node option
val unexpand_unpaaiair : 'l node -> 'l node option
val unexpand_if_some : 'l node -> 'l node option
val unexpand_if_right : 'l node -> 'l node option

521
src/client/embedded/alpha/michelson_parser.ml
View File

@ -1,521 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Script_located_ir
exception Invalid_utf8_sequence of point * string
exception Unexpected_character of point * string
exception Undefined_escape_character of point * string
exception Missing_break_after_number of point
exception Unterminated_string of location
exception Unterminated_integer of location
exception Unterminated_comment of location
type token_value =
| String of string
| Int of string
| Ident of string
| Annot of string
| Comment of string
| Eol_comment of string
| Semi
| Open_paren | Close_paren
| Open_brace | Close_brace
type token =
{ token : token_value ;
loc : location }
let tokenize source =
let decoder = Uutf.decoder ~encoding:`UTF_8 (`String source) in
let here () =
{ point = Uutf.decoder_count decoder ;
byte = Uutf.decoder_byte_count decoder ;
line = Uutf.decoder_line decoder ;
column = Uutf.decoder_col decoder } in
let tok start stop token =
{ loc = { start ; stop } ; token } in
let stack = ref [] in
let next () =
match !stack with
| charloc :: charlocs ->
stack := charlocs ;
charloc
| [] ->
let loc = here () in
match Uutf.decode decoder with
| `Await -> assert false
| `Malformed s -> raise (Invalid_utf8_sequence (loc, s))
| `Uchar _ | `End as other -> other, loc in
let back charloc =
stack := charloc :: !stack in
let uchar_to_char c =
if Uchar.is_char c then
Some (Uchar.to_char c)
else
None in
let rec skip acc =
match next () with
| `End, _ -> List.rev acc
| `Uchar c, start ->
begin match uchar_to_char c with
| Some ('a'..'z' | 'A'..'Z') -> ident acc start (fun s -> Ident s)
| Some '@' -> ident acc start (fun s -> Annot s)
| Some '-' ->
begin match next () with
| `End, stop ->
raise (Unterminated_integer { start ; stop })
| `Uchar c, stop ->
begin match uchar_to_char c with
| Some '0' -> base acc start
| Some ('1'..'9') -> integer `dec acc start false
| Some _ | None ->
raise (Unterminated_integer { start ; stop })
end
end
| Some '0' -> base acc start
| Some ('1'..'9') -> integer `dec acc start false
| Some (' ' | '\n') -> skip acc
| Some ';' -> skip (tok start (here ()) Semi :: acc)
| Some '{' -> skip (tok start (here ()) Open_brace :: acc)
| Some '}' -> skip (tok start (here ()) Close_brace :: acc)
| Some '(' -> skip (tok start (here ()) Open_paren :: acc)
| Some ')' -> skip (tok start (here ()) Close_paren :: acc)
| Some '"' -> string acc [] start
| Some '#' -> eol_comment acc start
| Some '/' ->
begin match next () with
| `Uchar c, _ when Uchar.equal c (Uchar.of_char '*') ->
comment acc start 0
| (`Uchar _ | `End), _ ->
raise (Unexpected_character (start, "/"))
end
| Some _ | None ->
let byte = Uutf.decoder_byte_count decoder in
let s = String.sub source start.byte (byte - start.byte) in
raise (Unexpected_character (start, s))
end
and base acc start =
match next () with
| (`Uchar c, stop) as charloc ->
begin match uchar_to_char c with
| Some ('0'.. '9') -> integer `dec acc start false
| Some 'x' -> integer `hex acc start true
| Some 'b' -> integer `bin acc start true
| Some ('a' | 'c'..'w' | 'y' | 'z' | 'A'..'Z') ->
raise (Missing_break_after_number stop)
| Some _ | None ->
back charloc ;
skip (tok start (here ()) (Int "0") :: acc)
end
| (_, stop) as other ->
back other ;
skip (tok start stop (Int "0") :: acc)
and integer base acc start first =
let tok stop =
let value =
String.sub source start.byte (stop.byte - start.byte) in
tok start stop (Int value) in
match next () with
| (`Uchar c, stop) as charloc ->
begin match base, Uchar.to_char c with
| `dec, ('0'.. '9') ->
integer `dec acc start false
| `dec, ('a'..'z' | 'A'..'Z') ->
raise (Missing_break_after_number stop)
| `hex, ('0'..'9' | 'a'..'f' | 'A'..'F') ->
integer `hex acc start false
| `hex, ('g'..'z' | 'G'..'Z') ->
raise (Missing_break_after_number stop)
| `bin, ('0' | '1') ->
integer `bin acc start false
| `bin, ('2'..'9' | 'a'..'z' | 'A'..'Z') ->
raise (Missing_break_after_number stop)
| (`bin | `hex), _ when first ->
raise (Unterminated_integer { start ; stop })
| _ ->
back charloc ;
skip (tok stop :: acc)
end
| (`End, stop) as other ->
if first && base = `bin || base = `hex then
raise (Unterminated_integer { start ; stop }) ;
back other ;
skip (tok stop :: acc)
and string acc sacc start =
let tok () =
tok start (here ()) (String (String.concat "" (List.rev sacc))) in
match next () with
| `End, stop -> raise (Unterminated_string { start ; stop })
| `Uchar c, stop ->
match uchar_to_char c with
| Some '"' -> skip (tok () :: acc)
| Some '\n' -> raise (Unterminated_string { start ; stop })
| Some '\\' ->
begin match next () with
| `End, stop -> raise (Unterminated_string { start ; stop })
| `Uchar c, loc ->
match uchar_to_char c with
| Some '"' -> string acc ("\"" :: sacc) start
| Some 'r' -> string acc ("\r" :: sacc) start
| Some 'n' -> string acc ("\n" :: sacc) start
| Some 't' -> string acc ("\t" :: sacc) start
| Some 'b' -> string acc ("\b" :: sacc) start
| Some '\\' -> string acc ("\\" :: sacc) start
| Some _ | None ->
let byte = Uutf.decoder_byte_count decoder in
let s = String.sub source loc.byte (byte - loc.byte) in
raise (Undefined_escape_character (loc, s))
end
| Some _ | None ->
let byte = Uutf.decoder_byte_count decoder in
let s = String.sub source stop.byte (byte - stop.byte) in
string acc (s :: sacc) start
and ident acc start ret =
let tok stop =
let name =
String.sub source start.byte (stop.byte - start.byte) in
tok start stop (ret name) in
match next () with
| (`Uchar c, stop) as charloc ->
begin match uchar_to_char c with
| Some ('a'..'z' | 'A'..'Z' | '_' | '0'..'9') ->
ident acc start ret
| Some _ | None ->
back charloc ;
skip (tok stop :: acc)
end
| (_, stop) as other ->
back other ;
skip (tok stop :: acc)
and comment acc start lvl =
match next () with
| `End, stop -> raise (Unterminated_comment { start ; stop })
| `Uchar c, _ ->
begin match uchar_to_char c with
| Some '*' ->
begin match next () with
| `Uchar c, _ when Uchar.equal c (Uchar.of_char '/') ->
if lvl = 0 then
let stop = here () in
let text =
String.sub source start.byte (stop.byte - start.byte) in
skip (tok start stop (Comment text) :: acc)
else
comment acc start (lvl - 1)
| other ->
back other ;
comment acc start lvl
end
| Some '/' ->
begin match next () with
| `Uchar c, _ when Uchar.equal c (Uchar.of_char '*') ->
comment acc start (lvl + 1)
| other ->
back other ;
comment acc start lvl
end
| Some _ | None -> comment acc start lvl
end
and eol_comment acc start =
let tok stop =
let text = String.sub source start.byte (stop.byte - start.byte) in
tok start stop (Eol_comment text) in
match next () with
| `Uchar c, stop ->
begin match uchar_to_char c with
| Some '\n' -> skip (tok stop :: acc)
| Some _ | None -> eol_comment acc start
end
| (_, stop) as other ->
back other ;
skip (tok stop :: acc) in
skip []
(* Beginning of a sequence of consecutive primitives *)
let min_point : node list -> point = function
| [] -> point_zero
| Int ({ start }, _) :: _
| String ({ start }, _) :: _
| Prim ({ start }, _, _, _) :: _
| Seq ({ start }, _, _) :: _ -> start
(* End of a sequence of consecutive primitives *)
let rec max_point : node list -> point = function
| [] -> point_zero
| _ :: (_ :: _ as rest) -> max_point rest
| Int ({ stop }, _) :: []
| String ({ stop }, _) :: []
| Prim ({ stop }, _, _, _) :: []
| Seq ({ stop }, _, _) :: [] -> stop
(* An item in the parser's state stack.
Not every value of type [mode list] is a valid parsing context.
It must respect the following additional invariants.
- a state stack always ends in [Toplevel _],
- [Toplevel _] does not appear anywhere else,
- [Unwrapped _] cannot appear directly on top of [Wrapped _],
- [Wrapped _] cannot appear directly on top of [Sequence _],
- [Wrapped _] cannot appear directly on top of [Sequence _]. *)
type mode =
| Toplevel of node list
| Expression of node option
| Sequence of token * node list * string option
| Unwrapped of location * string * node list * string option
| Wrapped of token * string * node list * string option
(* Enter a new parsing state. *)
let push_mode mode stack =
mode :: stack
(* Leave a parsing state. *)
let pop_mode = function
| [] -> assert false
| _ :: rest -> rest
(* Usually after a [pop_mode], jump back into the previous parsing
state, injecting the current reduction (insert the just parsed item
of a sequence or argument of a primitive application). *)
let fill_mode result = function
| [] -> assert false
| Expression _ :: _ :: _ -> assert false
| Expression (Some _) :: [] -> assert false
| Toplevel _ :: _ :: _ -> assert false
| Expression None :: [] ->
Expression (Some result) :: []
| Toplevel exprs :: [] ->
Toplevel (result :: exprs) :: []
| Sequence (token, exprs, annot) :: rest ->
Sequence (token, result :: exprs, annot) :: rest
| Wrapped (token, name, exprs, annot) :: rest ->
Wrapped (token, name, result :: exprs, annot) :: rest
| Unwrapped (start, name, exprs, annot) :: rest ->
Unwrapped (start, name, result :: exprs, annot) :: rest
exception Unclosed of token
exception Unexpected of token
exception Extra of token
exception Misaligned of node
exception Empty
let rec parse
?expand:(do_expand = true)
?check:(do_check = true)
tokens stack =
(* Two steps:
- 1. parse without checking indentation [parse]
- 2. check indentation [check] (inlined in 1)
- 3. expand macros (inlined in 1, after 2) *)
match stack, tokens with
(* Start by preventing all absurd cases, so now the pattern
matching exhaustivity can tell us that we treater all
possible tokens for all possible valid states. *)
| [], _
| [ Wrapped _ ], _
| [ Unwrapped _ ], _
| Unwrapped _ :: Unwrapped _ :: _, _
| Unwrapped _ :: Wrapped _ :: _, _
| Toplevel _ :: _ :: _, _
| Expression _ :: _ :: _, _ ->
assert false
(* Return *)
| Expression (Some result) :: _, [] ->
[ result ]
| Expression (Some _) :: _, token :: _ ->
raise (Unexpected token)
| Expression None :: _, [] ->
raise Empty
| Toplevel [ Seq (_, exprs, _) as expr ] :: [],
[] ->
if do_check then check ~toplevel: false expr ;
let exprs =
if do_expand then
List.map Michelson_macros.expand exprs
else exprs in
exprs
| Toplevel exprs :: [],
[] ->
let exprs = List.rev exprs in
let loc = { start = min_point exprs ; stop = max_point exprs } in
let expr = Seq (loc, exprs, None) in
if do_check then check ~toplevel: true expr ;
let exprs =
if do_expand then
List.map Michelson_macros.expand exprs
else exprs in
exprs
(* Ignore comments *)
| _,
{ token = Eol_comment _ | Comment _ } :: rest ->
parse rest stack
| (Wrapped _ | Unwrapped _) :: _,
({ token = Open_paren } as token)
:: { token = Eol_comment _ | Comment _ } :: rest ->
parse (token :: rest) stack
(* Erroneous states *)
| (Wrapped _ | Unwrapped _) :: _ ,
({ token = Open_paren } as token)
:: { token = Open_paren | Open_brace } :: _
| Unwrapped _ :: Expression _ :: _ ,
({ token = Semi | Close_brace | Close_paren } as token) :: _
| Expression None :: _ ,
({ token = Semi | Close_brace | Close_paren | Open_brace | Open_paren } as token) :: _ ->
raise (Unexpected token)
| (Sequence _ | Toplevel _) :: _ ,
{ token = Semi } :: ({ token = Semi } as token) :: _ ->
raise (Extra token)
| (Wrapped _ | Unwrapped _) :: _ ,
{ token = Open_paren }
:: ({ token = Int _ | String _ | Annot _ | Close_paren } as token) :: _
| Unwrapped (_, _, _, _) :: Toplevel _ :: _,
({ token = Close_brace } as token) :: _
| Unwrapped (_, _, _, _) :: _,
({ token = Close_paren } as token) :: _
| Toplevel _ :: [],
({ token = Close_paren } as token) :: _
| Toplevel _ :: [],
({ token = Close_brace } as token) :: _
| _,
({ token = Annot _ } as token) :: _ ->
raise (Unexpected token)
| Wrapped (token, _, _, _) :: _,
({ token = Close_brace | Semi } :: _ | [])
| (Sequence _ | Toplevel _) :: _,
({ token = Open_paren } as token) :: _
| (Wrapped _ | Unwrapped _) :: _,
({ token = Open_paren } as token) :: ({ token = Close_brace | Semi } :: _ | [])
| (Sequence (token, _, _) :: _ | Unwrapped _ :: Sequence (token, _, _) :: _),
({ token = Close_paren } :: _ | [])->
raise (Unclosed token)
(* Valid states *)
| (Toplevel _ | Sequence (_, _, _)) :: _ ,
{ token = Ident name ; loc } :: { token = Annot annot } :: rest ->
let mode = Unwrapped (loc, name, [], Some annot) in
parse rest (push_mode mode stack)
| (Expression None | Toplevel _ | Sequence (_, _, _)) :: _ ,
{ token = Ident name ; loc } :: rest ->
let mode = Unwrapped (loc, name, [], None) in
parse rest (push_mode mode stack)
| (Expression None | Sequence _ | Toplevel _ | Unwrapped _ | Wrapped _) :: _,
{ token = Int value ; loc } :: rest ->
let expr : node = Int (loc, value) in
if do_check then check ~toplevel: false expr ;
let expr =
if do_expand then
Michelson_macros.expand expr
else expr in
parse rest (fill_mode expr stack)
| (Expression None | Sequence _ | Toplevel _ | Unwrapped _ | Wrapped _) :: _,
{ token = String contents ; loc } :: rest ->
let expr : node = String (loc, contents) in
if do_check then check ~toplevel: false expr ;
let expr =
if do_expand then
Michelson_macros.expand expr
else expr in
parse rest (fill_mode expr stack)
| Sequence ({ loc = { start } }, exprs, annot) :: _ ,
{ token = Close_brace ; loc = { stop } } :: rest ->
let exprs = List.rev exprs in
let expr = Seq ({ start ; stop }, exprs, annot) in
if do_check then check ~toplevel: false expr ;
let expr =
if do_expand then
Michelson_macros.expand expr
else expr in
parse rest (fill_mode expr (pop_mode stack))
| (Sequence _ | Toplevel _) :: _ ,
{ token = Semi } :: rest ->
parse rest stack
| Unwrapped ({ start ; stop }, name, exprs, annot) :: Expression _ :: _,
([] as rest)
| Unwrapped ({ start ; stop }, name, exprs, annot) :: Toplevel _ :: _,
({ token = Semi } :: _ | [] as rest)
| Unwrapped ({ start ; stop }, name, exprs, annot) :: Sequence _ :: _ ,
({ token = Close_brace | Semi } :: _ as rest)
| Wrapped ({ loc = { start ; stop } }, name, exprs, annot) :: _ ,
{ token = Close_paren } :: rest ->
let exprs = List.rev exprs in
let stop = if exprs = [] then stop else max_point exprs in
let expr = Prim ({ start ; stop }, name, exprs, annot) in
if do_check then check ~toplevel: false expr ;
let expr =
if do_expand then
Michelson_macros.expand expr
else expr in
parse rest (fill_mode expr (pop_mode stack))
| (Wrapped _ | Unwrapped _) :: _ ,
({ token = Open_paren } as token) :: { token = Ident name } :: { token = Annot annot } :: rest ->
let mode = Wrapped (token, name, [], Some annot) in
parse rest (push_mode mode stack)
| (Wrapped _ | Unwrapped _) :: _ ,
({ token = Open_paren } as token) :: { token = Ident name } :: rest ->
let mode = Wrapped (token, name, [], None) in
parse rest (push_mode mode stack)
| (Wrapped _ | Unwrapped _) :: _ ,
{ token = Ident name ; loc } :: rest ->
let expr = Prim (loc, name, [], None) in
if do_check then check ~toplevel: false expr ;
let expr =
if do_expand then
Michelson_macros.expand expr
else expr in
parse rest (fill_mode expr stack)
| (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _) :: _ ,
({ token = Open_brace } as token) :: { token = Annot annot } :: rest ->
let mode = Sequence (token, [], Some annot) in
parse rest (push_mode mode stack)
| (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _) :: _ ,
({ token = Open_brace } as token) :: rest ->
let mode = Sequence (token, [], None) in
parse rest (push_mode mode stack)
(* indentation checker *)
and check ?(toplevel = false) = function
| Seq ({ start ; stop }, [], _) as expr ->
if start.column >= stop.column then
raise (Misaligned expr)
| Prim ({ start ; stop }, _, first :: rest, _)
| Seq ({ start ; stop }, first :: rest, _) as expr ->
let { column = first_column ; line = first_line } =
min_point [ first ] in
if start.column >= stop.column then
raise (Misaligned expr) ;
if not toplevel && start.column >= first_column then
raise (Misaligned expr) ;
(* In a sequence or in the arguments of a primitive, we
require all items to be aligned, but we relax the rule to
allow consecutive items to be writtem on the same line. *)
let rec in_line_or_aligned prev_start_line = function
| [] -> ()
| expr :: rest ->
let { column ; line = start_line } = min_point [ expr ] in
let { line = stop_line } = max_point [ expr ] in
if stop_line <> prev_start_line
&& column <> first_column then
raise (Misaligned expr) ;
in_line_or_aligned start_line rest in
in_line_or_aligned first_line rest
| Prim (_, _, [], _) | String _ | Int _ -> ()
let parse_expression ?expand ?check tokens =
let result = match tokens with
| ({ token = Open_paren } as token) :: { token = Ident name } :: { token = Annot annot } :: rest ->
let mode = Wrapped (token, name, [], Some annot) in
parse ?expand ?check rest [ mode ; Expression None ]
| ({ token = Open_paren } as token) :: { token = Ident name } :: rest ->
let mode = Wrapped (token, name, [], None) in
parse ?expand ?check rest [ mode ; Expression None ]
| _ ->
parse ?expand ?check tokens [ Expression None ] in
match result with
| [ single ] -> single
| _ -> assert false
let parse_toplevel ?expand ?check tokens =
parse ?expand ?check tokens [ Toplevel [] ]

44
src/client/embedded/alpha/michelson_parser.mli
View File

@ -1,44 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Script_located_ir
exception Invalid_utf8_sequence of point * string
exception Unexpected_character of point * string
exception Undefined_escape_character of point * string
exception Missing_break_after_number of point
exception Unterminated_string of location
exception Unterminated_integer of location
exception Unterminated_comment of location
type token_value =
| String of string
| Int of string
| Ident of string
| Annot of string
| Comment of string
| Eol_comment of string
| Semi
| Open_paren | Close_paren
| Open_brace | Close_brace
type token =
{ token : token_value ;
loc : location }
val tokenize : string -> token list
exception Unclosed of token
exception Unexpected of token
exception Extra of token
exception Misaligned of node
exception Empty
val parse_toplevel : ?expand:bool -> ?check:bool -> token list -> node list
val parse_expression : ?expand:bool -> ?check:bool -> token list -> node

107
src/client/embedded/alpha/michelson_v1_emacs.ml Normal file
View File

@ -0,0 +1,107 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Micheline
let print_expr ppf expr =
let rec print_expr ppf = function
| Int (_, value) -> Format.fprintf ppf "%s" value
| String (_, value) -> Micheline_printer.print_string ppf value
| Seq (_, items, _) ->
Format.fprintf ppf "(seq %a)"
(Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
items
| Prim (_, name, [], _) ->
Format.fprintf ppf "%s" name
| Prim (_, name, items, _) ->
Format.fprintf ppf "(%s %a)" name
(Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr) items in
let root = root (Michelson_v1_primitives.strings_of_prims expr) in
Format.fprintf ppf "@[<h>%a@]" print_expr root
open Micheline_parser
open Script_ir_translator
let print_type_map ppf (parsed, type_map) =
let rec print_expr_types ppf = function
| Seq (loc, [], _)
| Prim (loc, _, [], _)
| Int (loc, _)
| String (loc, _) ->
print_item ppf loc
| Seq (loc, items, _)
| Prim (loc, _, items, _) ->
print_item ppf loc ;
List.iter (print_expr_types ppf) items
and print_stack ppf items =
Format.fprintf ppf "(%a)"
(Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
items
and print_item ppf loc = try
let { start = { point = s } ; stop = { point = e } }, locs =
List.assoc loc parsed.Michelson_v1_parser.expansion_table in
let locs = List.sort compare locs in
let (bef, aft) = List.assoc (List.hd locs) type_map in
Format.fprintf ppf "(@[<h>%d %d %a %a@])@,"
s e
print_stack bef
print_stack aft
with Not_found -> () in
Format.fprintf ppf "(@[<v 0>%a@])"
print_expr_types (root parsed.unexpanded)
let first_error_location errs =
let rec find = function
| [] -> 0
| Ill_formed_type (_, _, loc) :: _
| Invalid_arity (loc, _, _, _) :: _
| Invalid_namespace (loc, _, _, _) :: _
| Invalid_primitive (loc, _, _) :: _
| Invalid_kind (loc, _, _) :: _
| Fail_not_in_tail_position loc :: _
| Undefined_binop (loc, _, _, _) :: _
| Undefined_unop (loc, _, _) :: _
| Bad_return (loc, _, _) :: _
| Bad_stack (loc, _, _, _) :: _
| Unmatched_branches (loc, _, _) :: _
| Transfer_in_lambda loc :: _
| Transfer_in_dip loc :: _
| Invalid_constant (loc, _, _) :: _
| Invalid_contract (loc, _) :: _
| Comparable_type_expected (loc, _) :: _ -> loc
| _ :: rest -> find rest in
find errs
let report_errors ppf (parsed, errs) =
Format.fprintf ppf "(@[<v 0>%a@])"
(Format.pp_print_list
(fun ppf err ->
let errs, loc =
match err with
| Environment.Ecoproto_error (top :: errs) ->
[ Environment.Ecoproto_error (top :: errs) ],
begin match top with
| Ill_typed_contract (expr, _)
| Ill_typed_data (_, expr, _) ->
if expr = parsed.Michelson_v1_parser.expanded then
first_error_location (top :: errs)
else 0
| _ -> 0
end
| err -> [ err ], 0 in
let message =
Format.asprintf "%a"
(Michelson_v1_error_reporter.report_errors
~details: false ~show_source: false ~parsed)
errs in
let { start = { point = s } ; stop = { point = e } } =
let oloc = List.assoc loc parsed.unexpansion_table in
fst (List.assoc oloc parsed.expansion_table) in
Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) message))
errs

21
src/client/embedded/alpha/michelson_v1_emacs.mli Normal file
View File

@ -0,0 +1,21 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
val print_expr :
Format.formatter ->
Script.expr ->
unit
val print_type_map :
Format.formatter ->
Michelson_v1_parser.parsed * Script_ir_translator.type_map ->
unit
val report_errors :
Format.formatter ->
Michelson_v1_parser.parsed * Error_monad.error list ->
unit

338
src/client/embedded/alpha/michelson_v1_error_reporter.ml Normal file
View File

@ -0,0 +1,338 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Script_typed_ir
open Script_ir_translator
open Script_interpreter
open Michelson_v1_printer
let print_ty (type t) ppf (ty : t ty) =
unparse_ty ty
|> Micheline.strip_locations
|> Michelson_v1_printer.print_expr ppf
let rec print_stack_ty (type t) ?(depth = max_int) ppf (s : t stack_ty) =
let print_ty (type t) ppf (ty : t ty) =
unparse_ty ty
|> Micheline.strip_locations
|> Michelson_v1_printer.print_expr_unwrapped ppf in
let rec loop
: type t. int -> Format.formatter -> t stack_ty -> unit
= fun depth ppf -> function
| Empty_t -> ()
| _ when depth <= 0 ->
Format.fprintf ppf "..."
| Item_t (last, Empty_t) ->
Format.fprintf ppf "%a"
print_ty last
| Item_t (last, rest) ->
Format.fprintf ppf "%a :@ %a"
print_ty last (loop (depth - 1)) rest in
match s with
| Empty_t ->
Format.fprintf ppf "[]"
| sty ->
Format.fprintf ppf "@[<hov 2>[ %a ]@]" (loop depth) sty
let rec print_enumeration ppf = function
| [ single ] ->
Format.fprintf ppf "%a"
Format.pp_print_text single
| [ prev ; last ] ->
Format.fprintf ppf "%a@ or@ %a"
Format.pp_print_text prev Format.pp_print_text last
| first :: rest ->
Format.fprintf ppf "%a,@ %a"
Format.pp_print_text first print_enumeration rest
| [] -> assert false
let collect_error_locations errs =
let rec collect acc = function
| Ill_formed_type (_, _, loc) :: _ -> loc :: acc
| (Ill_typed_data (_, _, _)
| Ill_typed_contract (_, _)) :: _
| [] -> acc
| (Invalid_arity (loc, _, _, _)
| Invalid_namespace (loc, _, _, _)
| Invalid_primitive (loc, _, _)
| Invalid_kind (loc, _, _)
| Fail_not_in_tail_position loc
| Undefined_binop (loc, _, _, _)
| Undefined_unop (loc, _, _)
| Bad_return (loc, _, _)
| Bad_stack (loc, _, _, _)
| Unmatched_branches (loc, _, _)
| Transfer_in_lambda loc
| Transfer_in_dip loc
| Invalid_constant (loc, _, _)
| Invalid_contract (loc, _)
| Comparable_type_expected (loc, _)
| Overflow loc
| Reject loc) :: rest ->
collect (loc :: acc) rest
| _ :: rest -> collect acc rest in
collect [] errs
let report_errors ~details ~show_source ?parsed ppf errs =
let rec print_trace locations errs =
let print_loc ppf loc =
match locations loc with
| None ->
Format.fprintf ppf "At (unshown) location %d, " loc
| Some loc ->
Format.fprintf ppf "%s,@ "
(String.capitalize_ascii
(Format.asprintf "%a" Micheline_parser.print_location loc)) in
let parsed_locations parsed loc = try
let oloc = List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in
let ploc, _ = List.assoc oloc parsed.expansion_table in
Some ploc
with Not_found -> None in
let print_source ppf (parsed, _hilights (* TODO *)) =
let lines =
String.split_on_char '\n' parsed.Michelson_v1_parser.source in
let cols =
String.length (string_of_int (List.length lines)) in
Format.fprintf ppf "@[<v 0>%a@]"
(Format.pp_print_list
(fun ppf (i, l) ->
Format.fprintf ppf "%0*d: %s" cols i l))
(List.mapi (fun i l -> (i + 1, l)) lines) in
match errs with
| [] -> ()
| Ill_typed_data (name, expr, ty) :: rest ->
let parsed =
match parsed with
| Some parsed when expr = parsed.Michelson_v1_parser.expanded -> parsed
| Some _ | None -> Michelson_v1_printer.unparse_expression expr in
let hilights = collect_error_locations rest in
Format.fprintf ppf
"@[<hov 0>@[<hov 2>Ill typed %adata:@ %a@]@ \
@[<hov 2>is not an expression of type@ %a@]@]"
(fun ppf -> function
| None -> ()
| Some s -> Format.fprintf ppf "%s " s)
name
print_source (parsed, hilights)
print_ty ty ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace (parsed_locations parsed) rest
| Ill_formed_type (_, expr, loc) :: rest ->
let parsed =
match parsed with
| Some parsed when expr = parsed.Michelson_v1_parser.expanded -> parsed
| Some _ | None -> Michelson_v1_printer.unparse_expression expr in
let hilights = collect_error_locations errs in
if show_source then
Format.fprintf ppf
"@[<v 2>%aill formed type:@ %a@]"
print_loc loc print_source (parsed, hilights)
else
Format.fprintf ppf
"Ill formed type." ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace (parsed_locations parsed) rest
| Ill_typed_contract (expr, type_map) :: rest ->
let parsed =
match parsed with
| Some parsed when not details && expr = parsed.Michelson_v1_parser.expanded -> parsed
| Some _ | None -> Michelson_v1_printer.unparse_toplevel ~type_map expr in
let hilights = collect_error_locations rest in
if show_source then
Format.fprintf ppf
"@[<v 0>Ill typed contract:@, %a@]"
print_source (parsed, hilights)
else
Format.fprintf ppf "Ill typed contract.";
if rest <> [] then Format.fprintf ppf "@," ;
print_trace (parsed_locations parsed) rest
| Missing_field prim :: rest ->
Format.fprintf ppf "@[<v 0>Missing contract field: %s@]"
(Michelson_v1_primitives.string_of_prim prim) ;
print_trace locations rest
| Runtime_contract_error (contract, expr) :: rest ->
let parsed =
match parsed with
| Some parsed when expr = parsed.Michelson_v1_parser.expanded -> parsed
| Some _ | None -> Michelson_v1_printer.unparse_toplevel expr in
let hilights = collect_error_locations rest in
Format.fprintf ppf
"@[<v 2>Runtime error in contract %a:@ %a@]"
Contract.pp contract
print_source (parsed, hilights) ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace (parsed_locations parsed) rest
| err :: rest ->
begin match err with
| Apply.Bad_contract_parameter (c, None, _) ->
Format.fprintf ppf
"@[<v 0>Account %a is not a smart contract, it does not take arguments.@,\
The `-arg' flag cannot be used when transferring to an account.@]"
Contract.pp c
| Apply.Bad_contract_parameter (c, Some expected, None) ->
Format.fprintf ppf
"@[<v 0>Contract %a expected an argument of type@, %a@,but no argument was provided.@,\
The `-arg' flag can be used when transferring to a smart contract.@]"
Contract.pp c
print_expr expected
| Apply.Bad_contract_parameter (c, Some expected, Some argument) ->
Format.fprintf ppf
"@[<v 0>Contract %a expected an argument of type@, %a@but received@, %a@]"
Contract.pp c
print_expr expected
print_expr argument
| Invalid_arity (loc, name, exp, got) ->
Format.fprintf ppf
"%aprimitive %s expects %d arguments but is given %d."
print_loc loc (Michelson_v1_primitives.string_of_prim name) exp got
| Invalid_namespace (loc, name, exp, got) ->
let human_namespace = function
| Instr_namespace -> ("an", "instruction")
| Type_namespace -> ("a", "type name")
| Constant_namespace -> ("a", "constant constructor")
| Keyword_namespace -> ("a", "keyword") in
Format.fprintf ppf
"@[%aunexpected %s %s, only %s %s can be used here."
print_loc loc
(snd (human_namespace got))
(Michelson_v1_primitives.string_of_prim name)
(fst (human_namespace exp)) (snd (human_namespace exp))
| Invalid_primitive (loc, exp, got) ->
Format.fprintf ppf
"@[%ainvalid primitive %s, only %a can be used here."
print_loc loc
(Michelson_v1_primitives.string_of_prim got)
print_enumeration
(List.map Michelson_v1_primitives.string_of_prim exp)
| Invalid_kind (loc, exp, got) ->
let human_kind = function
| Seq_kind -> ("a", "sequence")
| Prim_kind -> ("a", "primitive")
| Int_kind -> ("an", "int")
| String_kind -> ("a", "string") in
Format.fprintf ppf
"@[%aunexpected %s, only@ %a@ can be used here."
print_loc loc
(snd (human_kind got))
print_enumeration
(List.map (fun k -> let (a, n) = human_kind k in a ^ " " ^ n) exp)
| Duplicate_map_keys (_, expr) ->
Format.fprintf ppf
"@[<v 2>Map literals cannot contain duplicate keys, \
however a duplicate key was found:@ \
@[%a@]"
print_expr expr
| Unordered_map_keys (_, expr) ->
Format.fprintf ppf
"@[<v 2>Keys in a map literal must be in strictly ascending order, \
but they were unordered in literal:@ \
@[%a@]"
print_expr expr
| Duplicate_set_values (_, expr) ->
Format.fprintf ppf
"@[<v 2>Set literals cannot contain duplicate values, \
however a duplicate value was found:@ \
@[%a@]"
print_expr expr
| Unordered_set_values (_, expr) ->
Format.fprintf ppf
"@[<v 2>Values in a set literal must be in strictly ascending order, \
but they were unordered in literal:@ \
@[%a@]"
print_expr expr
| Fail_not_in_tail_position loc ->
Format.fprintf ppf
"%aThe FAIL instruction must appear in a tail position."
print_loc loc
| Undefined_binop (loc, name, tya, tyb) ->
Format.fprintf ppf
"@[<hov 0>@[<hov 2>%aoperator %s is undefined between@ %a@]@ \
@[<hov 2>and@ %a.@]@]"
print_loc loc
(Michelson_v1_primitives.string_of_prim name)
print_ty tya
print_ty tyb
| Undefined_unop (loc, name, ty) ->
Format.fprintf ppf
"@[<hov 0>@[<hov 2>%aoperator %s is undefined on@ %a@]@]"
print_loc loc
(Michelson_v1_primitives.string_of_prim name)
print_ty ty
| Bad_return (loc, got, exp) ->
Format.fprintf ppf
"@[<v 2>%awrong stack type at end of body:@,\
- @[<v 0>expected return stack type:@ %a,@]@,\
- @[<v 0>actual stack type:@ %a.@]@]"
print_loc loc
(fun ppf -> print_stack_ty ppf) (Item_t (exp, Empty_t))
(fun ppf -> print_stack_ty ppf) got
| Bad_stack (loc, name, depth, sty) ->
Format.fprintf ppf
"@[<hov 2>%awrong stack type for instruction %s:@ %a.@]"
print_loc loc
(Michelson_v1_primitives.string_of_prim name)
(print_stack_ty ~depth) sty
| Unmatched_branches (loc, sta, stb) ->
Format.fprintf ppf
"@[<v 2>%atwo branches don't end with the same stack type:@,\
- @[<hov>first stack type:@ %a,@]@,\
- @[<hov>other stack type:@ %a.@]@]"
print_loc loc
(fun ppf -> print_stack_ty ppf) sta
(fun ppf -> print_stack_ty ppf) stb
| Transfer_in_lambda loc ->
Format.fprintf ppf
"%aThe TRANSFER_TOKENS instruction cannot appear in a lambda."
print_loc loc
| Transfer_in_dip loc ->
Format.fprintf ppf
"%aThe TRANSFER_TOKENS instruction cannot appear within a DIP."
print_loc loc
| Bad_stack_length ->
Format.fprintf ppf
"Bad stack length."
| Bad_stack_item lvl ->
Format.fprintf ppf
"Bad stack item %d."
lvl
| Invalid_constant (loc, got, exp) ->
Format.fprintf ppf
"@[<hov 0>@[<hov 2>%avalue@ %a@]@ \
@[<hov 2>is invalid for type@ %a.@]@]"
print_loc loc
print_expr got
print_ty exp
| Invalid_contract (loc, contract) ->
Format.fprintf ppf
"%ainvalid contract %a."
print_loc loc Contract.pp contract
| Comparable_type_expected (loc, ty) ->
Format.fprintf ppf "%acomparable type expected."
print_loc loc ;
Format.fprintf ppf "@[<hov 0>@[<hov 2>Type@ %a@]@ is not comparable.@]"
print_ty ty
| Inconsistent_types (tya, tyb) ->
Format.fprintf ppf
"@[<hov 0>@[<hov 2>Type@ %a@]@ \
@[<hov 2>is not compatible with type@ %a.@]@]"
print_ty tya print_ty tyb
| Reject _ -> Format.fprintf ppf "Script reached FAIL instruction"
| Overflow _ -> Format.fprintf ppf "Unexpected arithmetic overflow"
| err ->
Format.fprintf ppf "%a"
Environment.Error_monad.pp_print_error [ err ]
end ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest in
Format.fprintf ppf "@[<v 0>%a@]"
(Format.pp_print_list
(fun ppf -> function
| Environment.Ecoproto_error errs -> print_trace (fun _ -> None) errs
| err -> pp_print_error ppf [ err ]))
errs

16
src/client/embedded/alpha/michelson_v1_error_reporter.mli Normal file
View File

@ -0,0 +1,16 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
val report_errors :
details: bool ->
show_source: bool ->
?parsed: Michelson_v1_parser.parsed ->
Format.formatter ->
Error_monad.error list ->
unit

68
src/client/embedded/alpha/michelson_v1_parser.ml Normal file
View File

@ -0,0 +1,68 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Micheline_parser
open Micheline
type parsed =
{ source : string ;
unexpanded : string canonical ;
expanded : Michelson_v1_primitives.prim canonical ;
expansion_table : (int * (Micheline_parser.location * int list)) list ;
unexpansion_table : (int * int) list }
let expand_all source ast =
let unexpanded, loc_table =
extract_locations ast in
let rec expand expr =
match Michelson_macros.expand expr with
| Seq (loc, items, annot) ->
Seq (loc, List.map expand items, annot)
| Prim (loc, name, args, annot) ->
Prim (loc, name, List.map expand args, annot)
| Int _ | String _ as atom -> atom in
let expanded, unexpansion_table =
extract_locations (expand (root unexpanded)) in
let expansion_table =
let sorted =
List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table in
let grouped =
let rec group = function
| acc, [] -> acc
| [], (u, e) :: r ->
group ([ (e, [ u ]) ], r)
| ((pe, us) :: racc as acc), (u, e) :: r ->
if e = pe then
group (((e, u :: us) :: racc), r)
else
group (((e, [ u ]) :: acc), r) in
group ([], sorted) in
List.map2
(fun (l, ploc) (l', elocs) ->
assert (l = l') ;
(l, (ploc, elocs)))
(List.sort compare loc_table)
(List.sort compare grouped) in
Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) >>? fun expanded ->
ok { source ; unexpanded ; expanded ; expansion_table ; unexpansion_table }
let parse_toplevel ?check source =
Micheline_parser.tokenize source >>? fun tokens ->
Micheline_parser.parse_toplevel ?check tokens >>? fun asts ->
let ast = match asts with
| [ ast ] -> ast
| asts ->
let start = min_point asts and stop = max_point asts in
Seq (Michelson_macros.{ start ; stop }, asts, None) in
expand_all source ast
let parse_expression ?check source =
Micheline_parser.tokenize source >>? fun tokens ->
Micheline_parser.parse_expression ?check tokens >>? fun ast ->
expand_all source ast

31
src/client/embedded/alpha/michelson_v1_parser.mli Normal file
View File

@ -0,0 +1,31 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
(** The result of parsing and expanding a Michelson V1 script or data. *)
type parsed =
{ source :
(** The original source code. *)
string ;
unexpanded :
(** Original expression with macros. *)
string Micheline.canonical ;
expanded :
(** Expression with macros fully expanded. *)
Script.expr ;
expansion_table :
(** Associates unexpanded nodes to their parsing locations and
the nodes expanded from it in the expanded expression. *)
(int * (Micheline_parser.location * int list)) list ;
unexpansion_table :
(** Associates an expanded node to its source in the unexpanded
expression. *)
(int * int) list }
val parse_toplevel : ?check:bool -> string -> parsed tzresult
val parse_expression : ?check:bool -> string -> parsed tzresult

106
src/client/embedded/alpha/michelson_v1_printer.ml Normal file
View File

@ -0,0 +1,106 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Micheline
open Micheline_printer
let anon = { comment = None }
let print_expr ppf expr =
expr
|> Michelson_v1_primitives.strings_of_prims
|> Micheline.inject_locations (fun _ -> anon)
|> print_expr ppf
let print_expr_unwrapped ppf expr =
expr
|> Michelson_v1_primitives.strings_of_prims
|> Micheline.inject_locations (fun _ -> anon)
|> print_expr_unwrapped ppf
let print_stack ppf = function
| [] -> Format.fprintf ppf "[]"
| more ->
Format.fprintf ppf "@[<hov 0>[ %a ]@]"
(Format.pp_print_list
~pp_sep: (fun ppf () -> Format.fprintf ppf "@ : ")
print_expr_unwrapped)
more
let inject_types type_map parsed =
let rec inject_expr = function
| Seq (loc, items, annot) ->
Seq (inject_loc `before loc, List.map inject_expr items, annot)
| Prim (loc, name, items, annot) ->
Prim (inject_loc `after loc, name, List.map inject_expr items, annot)
| Int (loc, value) ->
Int (inject_loc `after loc, value)
| String (loc, value) ->
String (inject_loc `after loc, value)
and inject_loc which loc = try
let stack =
let locs =
List.assoc loc parsed.Michelson_v1_parser.expansion_table
|> snd
|> List.sort compare in
let (bef, aft) =
List.assoc (List.hd locs) type_map in
match which with
| `before -> bef
| `after -> aft in
{ comment = Some (Format.asprintf "%a" print_stack stack) }
with Not_found -> { comment = None } in
inject_expr (root parsed.unexpanded)
let unparse ?type_map parse expanded =
let rec unexpand expr =
match Michelson_macros.unexpand expr with
| Seq (loc, items, annot) ->
Seq (loc, List.map unexpand items, annot)
| Prim (loc, name, args, annot) ->
Prim (loc, name, List.map unexpand args, annot)
| Int _ | String _ as atom -> atom in
let source =
match type_map with
| Some type_map ->
let unexpanded, unexpansion_table =
expanded
|> Michelson_v1_primitives.strings_of_prims
|> root |> unexpand |> Micheline.extract_locations in
let rec inject_expr = function
| Seq (loc, items, annot) ->
Seq (inject_loc `before loc, List.map inject_expr items, annot)
| Prim (loc, name, items, annot) ->
Prim (inject_loc `after loc, name, List.map inject_expr items, annot)
| Int (loc, value) ->
Int (inject_loc `after loc, value)
| String (loc, value) ->
String (inject_loc `after loc, value)
and inject_loc which loc = try
let stack =
let (bef, aft) =
List.assoc (List.assoc loc unexpansion_table) type_map in
match which with
| `before -> bef
| `after -> aft in
{ comment = Some (Format.asprintf "%a" print_stack stack) }
with Not_found -> { comment = None } in
unexpanded |> root |> inject_expr
|> Format.asprintf "%a" Micheline_printer.print_expr
| None ->
expanded |> Michelson_v1_primitives.strings_of_prims
|> root |> unexpand |> Micheline.strip_locations
|> Micheline_printer.printable (fun n -> n)
|> Format.asprintf "%a" Micheline_printer.print_expr in
match parse source with
| Ok res -> res
| Error _ -> Pervasives.failwith "Michelson_v1_printer.unexpand"
let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel
let unparse_expression = unparse Michelson_v1_parser.parse_expression

27
src/client/embedded/alpha/michelson_v1_printer.mli Normal file
View File

@ -0,0 +1,27 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
val print_expr :
Format.formatter -> Script_repr.expr -> unit
val print_expr_unwrapped :
Format.formatter -> Script_repr.expr -> unit
(** Insert the type map returned by the typechecker as comments in a
printable Micheline AST. *)
val inject_types :
Script_ir_translator.type_map ->
Michelson_v1_parser.parsed ->
Micheline_printer.node
(** Unexpand the macros and produce the result of parsing an
intermediate pretty printed source. Useful when working with
contracts extracted from the blockchain and not local files. *)
val unparse_toplevel : ?type_map: Script_ir_translator.type_map -> Script.expr -> Michelson_v1_parser.parsed
val unparse_expression : Script.expr -> Michelson_v1_parser.parsed

26
src/client/embedded/alpha/script_located_ir.ml
View File

@ -7,19 +7,15 @@
(* *)
(**************************************************************************)
type point =
type point = Micheline_parser.point =
{ point : int ;
byte : int ;
line : int ;
column : int }
let point_zero =
{ point = 0 ;
byte = 0 ;
line = 0 ;
column = 0 }
let point_zero = Micheline_parser.point_zero
type location =
type location = Micheline_parser.location =
{ start : point ;
stop : point }
@ -41,11 +37,9 @@ let location_encoding =
(req "start" point_encoding)
(req "stop" point_encoding))
type node =
| Int of location * string
| String of location * string
| Prim of location * string * node list * string option
| Seq of location * node list * string option
type node = (location, string) Micheline.node
open Micheline
let node_location = function
| Int (loc, _)
@ -61,16 +55,16 @@ let strip_locations root =
match l with
| Int (loc, v) ->
loc_table := (id, loc) :: !loc_table ;
Script.Int (id, v)
Int (id, v)
| String (loc, v) ->
loc_table := (id, loc) :: !loc_table ;
Script.String (id, v)
String (id, v)
| Seq (loc, seq, annot) ->
loc_table := (id, loc) :: !loc_table ;
Script.Seq (id, List.map strip_locations seq, annot)
Seq (id, List.map strip_locations seq, annot)
| Prim (loc, name, seq, annot) ->
loc_table := (id, loc) :: !loc_table ;
Script.Prim (id, name, List.map strip_locations seq, annot) in
Prim (id, name, List.map strip_locations seq, annot) in
let stripped = strip_locations root in
stripped, List.rev !loc_table

1
src/proto/alpha/TEZOS_PROTOCOL
View File

@ -17,6 +17,7 @@
"Seed_repr",
"Script_int_repr",
"Script_timestamp_repr",
"Michelson_v1_primitives",
"Script_repr",
"Contract_repr",
"Roll_repr",

27
src/proto/alpha/apply.ml
View File

@ -91,15 +91,19 @@ let apply_manager_operation_content
Contract.get_script ctxt destination >>=? function
| None -> begin
match parameters with
| None | Some (Prim (_, "Unit", [], _)) ->
| None ->
return (ctxt, origination_nonce, None)
| Some _ -> fail (Bad_contract_parameter (destination, None, parameters))
| Some arg ->
match Micheline.root arg with
| Prim (_, D_Unit, [], _) ->
return (ctxt, origination_nonce, None)
| _ -> fail (Bad_contract_parameter (destination, None, parameters))
end
| Some { code ; storage } ->
| Some script ->
let call_contract argument =
Script_interpreter.execute
origination_nonce
source destination ctxt storage code amount argument
source destination ctxt script amount argument
(Constants.instructions_per_transaction ctxt)
>>= function
| Ok (storage_res, _res, _steps, ctxt, origination_nonce) ->
@ -111,23 +115,26 @@ let apply_manager_operation_content
return (ctxt, origination_nonce, None)
| Error err ->
return (ctxt, origination_nonce, Some err) in
match parameters, code.arg_type with
| None, Prim (_, "unit", _, _) -> call_contract (Prim (0, "Unit", [], None))
| Some parameters, arg_type -> begin
Lwt.return (Script_ir_translator.parse_toplevel script.code) >>=? fun (arg_type, _, _, _) ->
let arg_type = Micheline.strip_locations arg_type in
match parameters, Micheline.root arg_type with
| None, Prim (_, T_unit, _, _) ->
call_contract (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None)))
| Some parameters, _ -> begin
Script_ir_translator.typecheck_data ctxt (parameters, arg_type) >>= function
| Ok () -> call_contract parameters
| Error errs ->
let err = Bad_contract_parameter (destination, Some arg_type, Some parameters) in
return (ctxt, origination_nonce, Some ((err :: errs)))
end
| None, arg_type -> fail (Bad_contract_parameter (destination, Some arg_type, None))
| None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None))
end
| Origination { manager ; delegate ; script ;
spendable ; delegatable ; credit } ->
begin match script with
| None -> return None
| Some ({ Script.storage ; code } as script) ->
Script_ir_translator.parse_script ctxt storage code >>=? fun _ ->
| Some script ->
Script_ir_translator.parse_script ctxt script >>=? fun _ ->
return (Some (script, (Script_interpreter.dummy_code_fee, Script_interpreter.dummy_storage_fee)))
end >>=? fun script ->
Contract.spend ctxt source Constants.origination_burn >>=? fun ctxt ->

4
src/proto/alpha/contract_storage.ml
View File

@ -309,18 +309,16 @@ let contract_fee c contract =
Lwt.return Tez_repr.(Constants_repr.minimal_contract_balance +? script_fees)
let update_script_storage_and_fees c contract storage_fees storage =
let open Script_repr in
Storage.Contract.Balance.get_option c contract >>=? function
| None ->
(* The contract was destroyed *)
return c
| Some balance ->
Storage.Contract.Storage.get c contract >>=? fun { storage_type } ->
Storage.Contract.Storage_fees.set c contract storage_fees >>=? fun c ->
contract_fee c contract >>=? fun fee ->
fail_unless Tez_repr.(balance > fee)
(Cannot_pay_storage_fee (contract, balance, fee)) >>=? fun () ->
Storage.Contract.Storage.set c contract { storage; storage_type }
Storage.Contract.Storage.set c contract storage
let spend_from_script c contract amount =
Storage.Contract.Balance.get c contract >>=? fun balance ->

2
src/proto/alpha/contract_storage.mli
View File

@ -37,7 +37,7 @@ val get_balance: Storage.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t
val get_counter: Storage.t -> Contract_repr.t -> int32 tzresult Lwt.t
val get_script: Storage.t -> Contract_repr.t -> Script_repr.t option tzresult Lwt.t
val get_storage: Storage.t -> Contract_repr.t -> Script_repr.storage option tzresult Lwt.t
val get_storage: Storage.t -> Contract_repr.t -> Script_repr.expr option tzresult Lwt.t
val update_script_storage_and_fees: Storage.t -> Contract_repr.t -> Tez_repr.t -> Script_repr.expr -> Storage.t tzresult Lwt.t

618
src/proto/alpha/michelson_v1_primitives.ml Normal file
View File

@ -0,0 +1,618 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Micheline
type error += Unknown_primitive of string
type error += Invalid_case of string
type prim =
| K_parameter
| K_return
| K_storage
| K_code
| D_False
| D_Item
| D_Left
| D_List
| D_Map
| D_None
| D_Pair
| D_Right
| D_Set
| D_Some
| D_True
| D_Unit
| I_H
| I_ABS
| I_ADD
| I_AMOUNT
| I_AND
| I_BALANCE
| I_CAR
| I_CDR
| I_CHECK_SIGNATURE
| I_COMPARE
| I_CONCAT
| I_CONS
| I_CREATE_ACCOUNT
| I_CREATE_CONTRACT
| I_DEFAULT_ACCOUNT
| I_DIP
| I_DROP
| I_DUP
| I_EDIV
| I_EMPTY_MAP
| I_EMPTY_SET
| I_EQ
| I_EXEC
| I_FAIL
| I_GE
| I_GET
| I_GT
| I_HASH_KEY
| I_IF
| I_IF_CONS
| I_IF_LEFT
| I_IF_NONE
| I_INT
| I_LAMBDA
| I_LE
| I_LEFT
| I_LOOP
| I_LSL
| I_LSR
| I_LT
| I_MANAGER
| I_MAP
| I_MEM
| I_MUL
| I_NEG
| I_NEQ
| I_NIL
| I_NONE
| I_NOT
| I_NOW
| I_OR
| I_PAIR
| I_PUSH
| I_REDUCE
| I_RIGHT
| I_SIZE
| I_SOME
| I_SOURCE
| I_STEPS_TO_QUOTA
| I_SUB
| I_SWAP
| I_TRANSFER_TOKENS
| I_UNIT
| I_UPDATE
| I_XOR
| T_bool
| T_contract
| T_int
| T_key
| T_key_hash
| T_lambda
| T_list
| T_map
| T_nat
| T_option
| T_or
| T_pair
| T_set
| T_signature
| T_string
| T_tez
| T_timestamp
| T_unit
let valid_case name =
let is_lower = function '_' | 'a'..'z' -> true | _ -> false in
let is_upper = function '_' | 'A'..'Z' -> true | _ -> false in
let rec for_all a b f =
Compare.Int.(a > b) || f a && for_all (a + 1) b f in
let len = String.length name in
Compare.Int.(len <> 0)
&&
Compare.Char.(String.get name 0 <> '_')
&&
((is_upper (String.get name 0)
&& for_all 1 (len - 1) (fun i -> is_upper (String.get name i)))
||
(is_upper (String.get name 0)
&& for_all 1 (len - 1) (fun i -> is_lower (String.get name i)))
||
(is_lower (String.get name 0)
&& for_all 1 (len - 1) (fun i -> is_lower (String.get name i))))
let string_of_prim = function
| K_parameter -> "parameter"
| K_return -> "return"
| K_storage -> "storage"
| K_code -> "code"
| D_False -> "False"
| D_Item -> "Item"
| D_Left -> "Left"
| D_List -> "List"
| D_Map -> "Map"
| D_None -> "None"
| D_Pair -> "Pair"
| D_Right -> "Right"
| D_Set -> "Set"
| D_Some -> "Some"
| D_True -> "True"
| D_Unit -> "Unit"
| I_H -> "H"
| I_ABS -> "ABS"
| I_ADD -> "ADD"
| I_AMOUNT -> "AMOUNT"
| I_AND -> "AND"
| I_BALANCE -> "BALANCE"
| I_CAR -> "CAR"
| I_CDR -> "CDR"
| I_CHECK_SIGNATURE -> "CHECK_SIGNATURE"
| I_COMPARE -> "COMPARE"
| I_CONCAT -> "CONCAT"
| I_CONS -> "CONS"
| I_CREATE_ACCOUNT -> "CREATE_ACCOUNT"
| I_CREATE_CONTRACT -> "CREATE_CONTRACT"
| I_DEFAULT_ACCOUNT -> "DEFAULT_ACCOUNT"
| I_DIP -> "DIP"
| I_DROP -> "DROP"
| I_DUP -> "DUP"
| I_EDIV -> "EDIV"
| I_EMPTY_MAP -> "EMPTY_MAP"
| I_EMPTY_SET -> "EMPTY_SET"
| I_EQ -> "EQ"
| I_EXEC -> "EXEC"
| I_FAIL -> "FAIL"
| I_GE -> "GE"
| I_GET -> "GET"
| I_GT -> "GT"
| I_HASH_KEY -> "HASH_KEY"
| I_IF -> "IF"
| I_IF_CONS -> "IF_CONS"
| I_IF_LEFT -> "IF_LEFT"
| I_IF_NONE -> "IF_NONE"
| I_INT -> "INT"
| I_LAMBDA -> "LAMBDA"
| I_LE -> "LE"
| I_LEFT -> "LEFT"
| I_LOOP -> "LOOP"
| I_LSL -> "LSL"
| I_LSR -> "LSR"
| I_LT -> "LT"
| I_MANAGER -> "MANAGER"
| I_MAP -> "MAP"
| I_MEM -> "MEM"
| I_MUL -> "MUL"
| I_NEG -> "NEG"
| I_NEQ -> "NEQ"
| I_NIL -> "NIL"
| I_NONE -> "NONE"
| I_NOT -> "NOT"
| I_NOW -> "NOW"
| I_OR -> "OR"
| I_PAIR -> "PAIR"
| I_PUSH -> "PUSH"
| I_REDUCE -> "REDUCE"
| I_RIGHT -> "RIGHT"
| I_SIZE -> "SIZE"
| I_SOME -> "SOME"
| I_SOURCE -> "SOURCE"
| I_STEPS_TO_QUOTA -> "STEPS_TO_QUOTA"
| I_SUB -> "SUB"
| I_SWAP -> "SWAP"
| I_TRANSFER_TOKENS -> "TRANSFER_TOKENS"
| I_UNIT -> "UNIT"
| I_UPDATE -> "UPDATE"
| I_XOR -> "XOR"
| T_bool -> "bool"
| T_contract -> "contract"
| T_int -> "int"
| T_key -> "key"
| T_key_hash -> "key_hash"
| T_lambda -> "lambda"
| T_list -> "list"
| T_map -> "map"
| T_nat -> "nat"
| T_option -> "option"
| T_or -> "or"
| T_pair -> "pair"
| T_set -> "set"
| T_signature -> "signature"
| T_string -> "string"
| T_tez -> "tez"
| T_timestamp -> "timestamp"
| T_unit -> "unit"
let prim_of_string = function
| "parameter" -> ok K_parameter
| "return" -> ok K_return
| "storage" -> ok K_storage
| "code" -> ok K_code
| "False" -> ok D_False
| "Item" -> ok D_Item
| "Left" -> ok D_Left
| "List" -> ok D_List
| "Map" -> ok D_Map
| "None" -> ok D_None
| "Pair" -> ok D_Pair
| "Right" -> ok D_Right
| "Set" -> ok D_Set
| "Some" -> ok D_Some
| "True" -> ok D_True
| "Unit" -> ok D_Unit
| "H" -> ok I_H
| "ABS" -> ok I_ABS
| "ADD" -> ok I_ADD
| "AMOUNT" -> ok I_AMOUNT
| "AND" -> ok I_AND
| "BALANCE" -> ok I_BALANCE
| "CAR" -> ok I_CAR
| "CDR" -> ok I_CDR
| "CHECK_SIGNATURE" -> ok I_CHECK_SIGNATURE
| "COMPARE" -> ok I_COMPARE
| "CONCAT" -> ok I_CONCAT
| "CONS" -> ok I_CONS
| "CREATE_ACCOUNT" -> ok I_CREATE_ACCOUNT
| "CREATE_CONTRACT" -> ok I_CREATE_CONTRACT
| "DEFAULT_ACCOUNT" -> ok I_DEFAULT_ACCOUNT
| "DIP" -> ok I_DIP
| "DROP" -> ok I_DROP
| "DUP" -> ok I_DUP
| "EDIV" -> ok I_EDIV
| "EMPTY_MAP" -> ok I_EMPTY_MAP
| "EMPTY_SET" -> ok I_EMPTY_SET
| "EQ" -> ok I_EQ
| "EXEC" -> ok I_EXEC
| "FAIL" -> ok I_FAIL
| "GE" -> ok I_GE
| "GET" -> ok I_GET
| "GT" -> ok I_GT
| "HASH_KEY" -> ok I_HASH_KEY
| "IF" -> ok I_IF
| "IF_CONS" -> ok I_IF_CONS
| "IF_LEFT" -> ok I_IF_LEFT
| "IF_NONE" -> ok I_IF_NONE
| "INT" -> ok I_INT
| "LAMBDA" -> ok I_LAMBDA
| "LE" -> ok I_LE
| "LEFT" -> ok I_LEFT
| "LOOP" -> ok I_LOOP
| "LSL" -> ok I_LSL
| "LSR" -> ok I_LSR
| "LT" -> ok I_LT
| "MANAGER" -> ok I_MANAGER
| "MAP" -> ok I_MAP
| "MEM" -> ok I_MEM
| "MUL" -> ok I_MUL
| "NEG" -> ok I_NEG
| "NEQ" -> ok I_NEQ
| "NIL" -> ok I_NIL
| "NONE" -> ok I_NONE
| "NOT" -> ok I_NOT
| "NOW" -> ok I_NOW
| "OR" -> ok I_OR
| "PAIR" -> ok I_PAIR
| "PUSH" -> ok I_PUSH
| "REDUCE" -> ok I_REDUCE
| "RIGHT" -> ok I_RIGHT
| "SIZE" -> ok I_SIZE
| "SOME" -> ok I_SOME
| "SOURCE" -> ok I_SOURCE
| "STEPS_TO_QUOTA" -> ok I_STEPS_TO_QUOTA
| "SUB" -> ok I_SUB
| "SWAP" -> ok I_SWAP
| "TRANSFER_TOKENS" -> ok I_TRANSFER_TOKENS
| "UNIT" -> ok I_UNIT
| "UPDATE" -> ok I_UPDATE
| "XOR" -> ok I_XOR
| "bool" -> ok T_bool
| "contract" -> ok T_contract
| "int" -> ok T_int
| "key" -> ok T_key
| "key_hash" -> ok T_key_hash
| "lambda" -> ok T_lambda
| "list" -> ok T_list
| "map" -> ok T_map
| "nat" -> ok T_nat
| "option" -> ok T_option
| "or" -> ok T_or
| "pair" -> ok T_pair
| "set" -> ok T_set
| "signature" -> ok T_signature
| "string" -> ok T_string
| "tez" -> ok T_tez
| "timestamp" -> ok T_timestamp
| "unit" -> ok T_unit
| n ->
if valid_case n then
error (Unknown_primitive n)
else
error (Invalid_case n)
let prims_of_strings expr =
let rec convert = function
| Int _ | String _ as expr -> ok expr
| Prim (_, prim, args, annot) ->
prim_of_string prim >>? fun prim ->
List.fold_left
(fun acc arg ->
acc >>? fun args ->
convert arg >>? fun arg ->
ok (arg :: args))
(ok []) args >>? fun args ->
ok (Prim (0, prim, List.rev args, annot))
| Seq (_, args, annot) ->
List.fold_left
(fun acc arg ->
acc >>? fun args ->
convert arg >>? fun arg ->
ok (arg :: args))
(ok []) args >>? fun args ->
ok (Seq (0, List.rev args, annot)) in
convert (root expr) >>? fun expr ->
ok (strip_locations expr)
let strings_of_prims expr =
let rec convert = function
| Int _ | String _ as expr -> expr
| Prim (_, prim, args, annot) ->
let prim = string_of_prim prim in
let args = List.map convert args in
Prim (0, prim, args, annot)
| Seq (_, args, annot) ->
let args = List.map convert args in
Seq (0, args, annot) in
strip_locations (convert (root expr))
let prim_encoding =
let to_int = function
| K_parameter -> 0
| K_return -> 1
| K_storage -> 2
| K_code -> 3
| D_False -> 4
| D_Item -> 5
| D_Left -> 6
| D_List -> 7
| D_Map -> 8
| D_None -> 9
| D_Pair -> 10
| D_Right -> 11
| D_Set -> 12
| D_Some -> 13
| D_True -> 14
| D_Unit -> 15
| I_H -> 16
| I_ABS -> 17
| I_ADD -> 18
| I_AMOUNT -> 19
| I_AND -> 20
| I_BALANCE -> 21
| I_CAR -> 22
| I_CDR -> 23
| I_CHECK_SIGNATURE -> 24
| I_COMPARE -> 25
| I_CONCAT -> 26
| I_CONS -> 27
| I_CREATE_ACCOUNT -> 28
| I_CREATE_CONTRACT -> 29
| I_DEFAULT_ACCOUNT -> 30
| I_DIP -> 31
| I_DROP -> 32
| I_DUP -> 33
| I_EDIV -> 34
| I_EMPTY_MAP -> 35
| I_EMPTY_SET -> 36
| I_EQ -> 37
| I_EXEC -> 38
| I_FAIL -> 39
| I_GE -> 40
| I_GET -> 41
| I_GT -> 42
| I_HASH_KEY -> 43
| I_IF -> 44
| I_IF_CONS -> 45
| I_IF_LEFT -> 46
| I_IF_NONE -> 47
| I_INT -> 48
| I_LAMBDA -> 49
| I_LE -> 50
| I_LEFT -> 51
| I_LOOP -> 52
| I_LSL -> 53
| I_LSR -> 54
| I_LT -> 55
| I_MANAGER -> 56
| I_MAP -> 57
| I_MEM -> 58
| I_MUL -> 59
| I_NEG -> 60
| I_NEQ -> 61
| I_NIL -> 62
| I_NONE -> 63
| I_NOT -> 64
| I_NOW -> 65
| I_OR -> 66
| I_PAIR -> 67
| I_PUSH -> 68
| I_REDUCE -> 69
| I_RIGHT -> 70
| I_SIZE -> 71
| I_SOME -> 72
| I_SOURCE -> 73
| I_STEPS_TO_QUOTA -> 74
| I_SUB -> 75
| I_SWAP -> 76
| I_TRANSFER_TOKENS -> 77
| I_UNIT -> 78
| I_UPDATE -> 79
| I_XOR -> 80
| T_bool -> 81
| T_contract -> 82
| T_int -> 83
| T_key -> 84
| T_key_hash -> 85
| T_lambda -> 86
| T_list -> 87
| T_map -> 88
| T_nat -> 89
| T_option -> 90
| T_or -> 91
| T_pair -> 92
| T_set -> 93
| T_signature -> 94
| T_string -> 95
| T_tez -> 96
| T_timestamp -> 97
| T_unit -> 99 in
let of_int_map = [|
K_parameter ;
K_return ;
K_storage ;
K_code ;
D_False ;
D_Item ;
D_Left ;
D_List ;
D_Map ;
D_None ;
D_Pair ;
D_Right ;
D_Set ;
D_Some ;
D_True ;
D_Unit ;
I_H ;
I_ABS ;
I_ADD ;
I_AMOUNT ;
I_AND ;
I_BALANCE ;
I_CAR ;
I_CDR ;
I_CHECK_SIGNATURE ;
I_COMPARE ;
I_CONCAT ;
I_CONS ;
I_CREATE_ACCOUNT ;
I_CREATE_CONTRACT ;
I_DEFAULT_ACCOUNT ;
I_DIP ;
I_DROP ;
I_DUP ;
I_EDIV ;
I_EMPTY_MAP ;
I_EMPTY_SET ;
I_EQ ;
I_EXEC ;
I_FAIL ;
I_GE ;
I_GET ;
I_GT ;
I_HASH_KEY ;
I_IF ;
I_IF_CONS ;
I_IF_LEFT ;
I_IF_NONE ;
I_INT ;
I_LAMBDA ;
I_LE ;
I_LEFT ;
I_LOOP ;
I_LSL ;
I_LSR ;
I_LT ;
I_MANAGER ;
I_MAP ;
I_MEM ;
I_MUL ;
I_NEG ;
I_NEQ ;
I_NIL ;
I_NONE ;
I_NOT ;
I_NOW ;
I_OR ;
I_PAIR ;
I_PUSH ;
I_REDUCE ;
I_RIGHT ;
I_SIZE ;
I_SOME ;
I_SOURCE ;
I_STEPS_TO_QUOTA ;
I_SUB ;
I_SWAP ;
I_TRANSFER_TOKENS ;
I_UNIT ;
I_UPDATE ;
I_XOR ;
T_bool ;
T_contract ;
T_int ;
T_key ;
T_key_hash ;
T_lambda ;
T_list ;
T_map ;
T_nat ;
T_option ;
T_or ;
T_pair ;
T_set ;
T_signature ;
T_string ;
T_tez ;
T_timestamp ;
T_unit |] in
let of_int i =
if Compare.Int.(i >= 0 || i <= 99) then
of_int_map.(i)
else
raise Data_encoding.No_case_matched in
let open Data_encoding in
let binary =
conv to_int of_int uint8 in
let json =
string_enum
(List.map (fun op -> string_of_prim op, op)
(Array.to_list of_int_map)) in
splitted ~json ~binary
let () =
register_error_kind
`Permanent
~id:"unknownPrimitiveNameTypeError"
~title: "Unknown primitive name (typechecking error)"
~description:
"In a script or data expression, a primitive was unknown."
~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n)
Data_encoding.(obj1 (req "wrongPrimitiveName" string))
(function
| Unknown_primitive got -> Some got
| _ -> None)
(fun got ->
Unknown_primitive got) ;
register_error_kind
`Permanent
~id:"invalidPrimitiveNameCaseTypeError"
~title: "Invalid primitive name case (typechecking error)"
~description:
"In a script or data expression, a primitive name is \
neither uppercase, lowercase or capitalized."
Data_encoding.(obj1 (req "wrongPrimitiveName" string))
(function
| Invalid_case name -> Some name
| _ -> None)
(fun name ->
Invalid_case name)

122
src/proto/alpha/michelson_v1_primitives.mli Normal file
View File

@ -0,0 +1,122 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
type error += Unknown_primitive of string (* `Permanent *)
type error += Invalid_case of string (* `Permanent *)
type prim =
| K_parameter
| K_return
| K_storage
| K_code
| D_False
| D_Item
| D_Left
| D_List
| D_Map
| D_None
| D_Pair
| D_Right
| D_Set
| D_Some
| D_True
| D_Unit
| I_H
| I_ABS
| I_ADD
| I_AMOUNT
| I_AND
| I_BALANCE
| I_CAR
| I_CDR
| I_CHECK_SIGNATURE
| I_COMPARE
| I_CONCAT
| I_CONS
| I_CREATE_ACCOUNT
| I_CREATE_CONTRACT
| I_DEFAULT_ACCOUNT
| I_DIP
| I_DROP
| I_DUP
| I_EDIV
| I_EMPTY_MAP
| I_EMPTY_SET
| I_EQ
| I_EXEC
| I_FAIL
| I_GE
| I_GET
| I_GT
| I_HASH_KEY
| I_IF
| I_IF_CONS
| I_IF_LEFT
| I_IF_NONE
| I_INT
| I_LAMBDA
| I_LE
| I_LEFT
| I_LOOP
| I_LSL
| I_LSR
| I_LT
| I_MANAGER
| I_MAP
| I_MEM
| I_MUL
| I_NEG
| I_NEQ
| I_NIL
| I_NONE
| I_NOT
| I_NOW
| I_OR
| I_PAIR
| I_PUSH
| I_REDUCE
| I_RIGHT
| I_SIZE
| I_SOME
| I_SOURCE
| I_STEPS_TO_QUOTA
| I_SUB
| I_SWAP
| I_TRANSFER_TOKENS
| I_UNIT
| I_UPDATE
| I_XOR
| T_bool
| T_contract
| T_int
| T_key
| T_key_hash
| T_lambda
| T_list
| T_map
| T_nat
| T_option
| T_or
| T_pair
| T_set
| T_signature
| T_string
| T_tez
| T_timestamp
| T_unit
val prim_encoding : prim Data_encoding.encoding
val string_of_prim : prim -> string
val prim_of_string : string -> prim tzresult
val prims_of_strings : string Micheline.canonical -> prim Micheline.canonical tzresult
val strings_of_prims : prim Micheline.canonical -> string Micheline.canonical

84
src/proto/alpha/script_interpreter.ml
View File

@ -20,7 +20,7 @@ let dummy_storage_fee = Tez.fifty_cents
type error += Quota_exceeded
type error += Reject of Script.location
type error += Overflow of Script.location
type error += Runtime_contract_error : Contract.t * Script.expr * _ ty * _ ty * _ ty -> error
type error += Runtime_contract_error : Contract.t * Script.expr -> error
let () =
let open Data_encoding in
@ -47,18 +47,15 @@ let () =
~id:"scriptRuntimeError"
~title: "Script runtime error"
~description: "Toplevel error for all runtime script errors"
(obj5
(obj2
(req "contractHandle" Contract.encoding)
(req "contractCode" Script.expr_encoding)
(req "contractParameterType" ex_ty_enc)
(req "contractReturnType" ex_ty_enc)
(req "contractStorageType" ex_ty_enc))
(req "contractCode" Script.expr_encoding))
(function
| Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty) ->
Some (contract, expr, Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty)
| Runtime_contract_error (contract, expr) ->
Some (contract, expr)
| _ -> None)
(fun (contract, expr, Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty) ->
Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty));
(fun (contract, expr) ->
Runtime_contract_error (contract, expr));
(* ---- interpreter ---------------------------------------------------------*)
@ -71,7 +68,7 @@ let rec unparse_stack
= function
| Empty, Empty_t -> []
| Item (v, rest), Item_t (ty, rest_ty) ->
unparse_data ty v :: unparse_stack (rest, rest_ty)
Micheline.strip_locations (unparse_data ty v) :: unparse_stack (rest, rest_ty)
let rec interp
: type p r.
@ -442,7 +439,7 @@ let rec interp
Contract.spend_from_script ctxt source amount >>=? fun ctxt ->
Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? fun destination_script ->
let sto = unparse_data storage_type sto in
let sto = Micheline.strip_locations (unparse_data storage_type sto) in
Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto >>=? fun ctxt ->
begin match destination_script with
| None ->
@ -450,9 +447,9 @@ let rec interp
Lwt.return (ty_eq tp Unit_t |>
record_trace (Invalid_contract (loc, destination))) >>=? fun (Eq _) ->
return (ctxt, qta, origination)
| Some { code ; storage } ->
| Some script ->
let p = unparse_data tp p in
execute origination source destination ctxt storage code amount p qta
execute origination source destination ctxt script amount p qta
>>=? fun (csto, ret, qta, ctxt, origination) ->
Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee csto >>=? fun ctxt ->
trace
@ -462,8 +459,8 @@ let rec interp
end >>=? fun (ctxt, qta, origination) ->
Contract.get_script ctxt source >>=? (function
| None -> assert false
| Some { storage = { storage } } ->
parse_data ctxt storage_type storage >>=? fun sto ->
| Some { storage } ->
parse_data ctxt storage_type (Micheline.root storage) >>=? fun sto ->
logged_return ~origination (Item ((), Item (sto, Empty)), qta - 1, ctxt))
end
| Transfer_tokens storage_type,
@ -472,11 +469,11 @@ let rec interp
Contract.credit ctxt destination amount >>=? fun ctxt ->
Contract.get_script ctxt destination >>=? function
| None -> fail (Invalid_contract (loc, destination))
| Some { code ; storage } ->
let sto = unparse_data storage_type sto in
| Some script ->
let sto = Micheline.strip_locations (unparse_data storage_type sto) in
Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto >>=? fun ctxt ->
let p = unparse_data tp p in
execute origination source destination ctxt storage code amount p qta
execute origination source destination ctxt script amount p qta
>>=? fun (sto, ret, qta, ctxt, origination) ->
Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee sto >>=? fun ctxt ->
trace
@ -484,8 +481,8 @@ let rec interp
(parse_data ctxt tr ret) >>=? fun v ->
Contract.get_script ctxt source >>=? (function
| None -> assert false
| Some { storage = { storage } } ->
parse_data ctxt storage_type storage >>=? fun sto ->
| Some { storage } ->
parse_data ctxt storage_type (Micheline.root storage) >>=? fun sto ->
logged_return ~origination (Item (v, Item (sto, Empty)), qta - 1, ctxt))
end
| Create_account,
@ -501,11 +498,20 @@ let rec interp
let contract = Contract.default_contract key in
logged_return (Item ((Unit_t, Unit_t, contract), rest), qta - 1, ctxt)
| Create_contract (g, p, r),
Item (manager, Item (delegate, Item (spendable, Item (delegatable, Item (credit,
Item (Lam (_, code), Item (init, rest))))))) ->
let code, storage =
{ code; arg_type = unparse_ty p; ret_type = unparse_ty r; storage_type = unparse_ty g },
{ storage = unparse_data g init; storage_type = unparse_ty g } in
Item (manager, Item
(delegate, Item
(spendable, Item
(delegatable, Item
(credit, Item
(Lam (_, code), Item
(init, rest))))))) ->
let code =
Micheline.strip_locations
(Seq (0, [ Prim (0, K_parameter, [ unparse_ty p ], None) ;
Prim (0, K_return, [ unparse_ty r ], None) ;
Prim (0, K_storage, [ unparse_ty g ], None) ;
Prim (0, K_code, [ Micheline.root code ], None) ], None)) in
let storage = Micheline.strip_locations (unparse_data g init) in
Contract.spend_from_script ctxt source credit >>=? fun ctxt ->
Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance ->
Contract.originate ctxt
@ -528,7 +534,7 @@ let rec interp
| Hash_key, Item (key, rest) ->
logged_return (Item (Ed25519.Public_key.hash key, rest), qta -1, ctxt)
| H ty, Item (v, rest) ->
let hash = Script.hash_expr (unparse_data ty v) in
let hash = Script.hash_expr (Micheline.strip_locations (unparse_data ty v)) in
logged_return (Item (hash, rest), qta - 1, ctxt)
| Steps_to_quota, rest ->
let steps = Script_int.abs (Script_int.of_int qta) in
@ -549,23 +555,25 @@ let rec interp
(* ---- contract handling ---------------------------------------------------*)
and execute ?log origination orig source ctxt storage script amount arg qta =
parse_script ctxt storage script
and execute ?log origination orig source ctxt script amount arg qta =
parse_script ctxt script
>>=? fun (Ex_script { code; arg_type; ret_type; storage; storage_type }) ->
parse_data ctxt arg_type arg >>=? fun arg ->
trace
(Runtime_contract_error (source, script.code, arg_type, ret_type, storage_type))
(Runtime_contract_error (source, script.code))
(interp ?log origination qta orig source amount ctxt code (arg, storage))
>>=? fun (ret, qta, ctxt, origination) ->
let ret, storage = ret in
return (unparse_data storage_type storage,
>>=? fun ((ret, storage), qta, ctxt, origination) ->
return (Micheline.strip_locations (unparse_data storage_type storage),
unparse_data ret_type ret,
qta, ctxt, origination)
let trace origination orig source ctxt storage script amount arg qta =
let trace origination orig source ctxt script amount arg qta =
let log = ref [] in
execute ~log origination orig source ctxt storage script amount arg qta >>=? fun res ->
return (res, List.rev !log)
execute ~log origination orig source ctxt script amount (Micheline.root arg) qta
>>=? fun (sto, res, qta, ctxt, origination) ->
return ((sto, Micheline.strip_locations res, qta, ctxt, origination), List.rev !log)
let execute orig source ctxt storage script amount arg qta =
execute orig source ctxt storage script amount arg qta
let execute origination orig source ctxt script amount arg qta =
execute origination orig source ctxt script amount (Micheline.root arg) qta
>>=? fun (sto, res, qta, ctxt, origination) ->
return (sto, Micheline.strip_locations res, qta, ctxt, origination)

7
src/proto/alpha/script_interpreter.mli
View File

@ -8,12 +8,11 @@
(**************************************************************************)
open Tezos_context
open Script_typed_ir
type error += Quota_exceeded
type error += Overflow of Script.location
type error += Reject of Script.location
type error += Runtime_contract_error : Contract.t * Script.expr * _ ty * _ ty * _ ty -> error
type error += Runtime_contract_error : Contract.t * Script.expr -> error
val dummy_code_fee : Tez.t
val dummy_storage_fee : Tez.t
@ -21,14 +20,14 @@ val dummy_storage_fee : Tez.t
val execute:
Contract.origination_nonce ->
Contract.t -> Contract.t -> Tezos_context.t ->
Script.storage -> Script.code -> Tez.t ->
Script.t -> Tez.t ->
Script.expr -> int ->
(Script.expr * Script.expr * int * context * Contract.origination_nonce) tzresult Lwt.t
val trace:
Contract.origination_nonce ->
Contract.t -> Contract.t -> Tezos_context.t ->
Script.storage -> Script.code -> Tez.t ->
Script.t -> Tez.t ->
Script.expr -> int ->
((Script.expr * Script.expr * int * context * Contract.origination_nonce) *
(Script.location * int * Script.expr list) list) tzresult Lwt.t

1111
src/proto/alpha/script_ir_translator.ml
View File

File diff suppressed because it is too large Load Diff

45
src/proto/alpha/script_ir_translator.mli
View File

@ -19,23 +19,25 @@ type ex_script = Ex_script : ('a, 'b, 'c) Script_typed_ir.script -> ex_script
(* ---- Error definitions ---------------------------------------------------*)
(* Auxiliary types for error documentation *)
type namespace = Type_namespace | Constant_namespace | Instr_namespace
type kind = Int_kind | String_kind | Prim_kind | Seq_kind
type namespace =
Type_namespace | Constant_namespace | Instr_namespace | Keyword_namespace
type kind =
Int_kind | String_kind | Prim_kind | Seq_kind
type type_map = (int * (Script.expr list * Script.expr list)) list
(* Structure errors *)
type error += Invalid_arity of Script.location * string * int * int
type error += Invalid_namespace of Script.location * string * namespace * namespace
type error += Invalid_primitive of Script.location * string list * string
type error += Invalid_case of Script.location * string
type error += Invalid_arity of Script.location * Script.prim * int * int
type error += Invalid_namespace of Script.location * Script.prim * namespace * namespace
type error += Invalid_primitive of Script.location * Script.prim list * Script.prim
type error += Invalid_kind of Script.location * kind list * kind
type error += Missing_field of Script.prim
(* Instruction typing errors *)
type error += Fail_not_in_tail_position of Script.location
type error += Undefined_binop : Script.location * string * _ Script_typed_ir.ty * _ Script_typed_ir.ty -> error
type error += Undefined_unop : Script.location * string * _ Script_typed_ir.ty -> error
type error += Undefined_binop : Script.location * Script.prim * _ Script_typed_ir.ty * _ Script_typed_ir.ty -> error
type error += Undefined_unop : Script.location * Script.prim * _ Script_typed_ir.ty -> error
type error += Bad_return : Script.location * _ Script_typed_ir.stack_ty * _ Script_typed_ir.ty -> error
type error += Bad_stack : Script.location * string * int * _ Script_typed_ir.stack_ty -> error
type error += Bad_stack : Script.location * Script.prim * int * _ Script_typed_ir.stack_ty -> error
type error += Unmatched_branches : Script.location * _ Script_typed_ir.stack_ty * _ Script_typed_ir.stack_ty -> error
type error += Transfer_in_lambda of Script.location
type error += Transfer_in_dip of Script.location
@ -54,8 +56,8 @@ type error += Duplicate_set_values of Script.location * Script.expr
(* Toplevel errors *)
type error += Ill_typed_data : string option * Script.expr * _ Script_typed_ir.ty -> error
type error += Ill_formed_type of string option * Script.expr
type error += Ill_typed_contract : Script.expr * _ Script_typed_ir.ty * _ Script_typed_ir.ty * _ Script_typed_ir.ty * type_map -> error
type error += Ill_formed_type of string option * Script.expr * Script.location
type error += Ill_typed_contract : Script.expr * type_map -> error
(* ---- Sets and Maps -------------------------------------------------------*)
@ -83,26 +85,29 @@ val ty_eq :
('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq tzresult
val parse_data :
?type_logger: (int * (Script.expr list * Script.expr list) -> unit) ->
context -> 'a Script_typed_ir.ty -> Script.expr -> 'a tzresult Lwt.t
?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
context -> 'a Script_typed_ir.ty -> Script.node -> 'a tzresult Lwt.t
val unparse_data :
'a Script_typed_ir.ty -> 'a -> Script.expr
'a Script_typed_ir.ty -> 'a -> Script.node
val parse_ty :
Script.expr -> ex_ty tzresult
Script.node -> ex_ty tzresult
val unparse_ty :
'a Script_typed_ir.ty -> Script.expr
'a Script_typed_ir.ty -> Script.node
val type_map_enc : type_map Data_encoding.encoding
val ex_ty_enc : ex_ty Data_encoding.encoding
val parse_toplevel
: Script.expr -> (Script.node * Script.node * Script.node * Script.node) tzresult
val typecheck_code :
context -> Script.code -> type_map tzresult Lwt.t
context -> Script.expr -> type_map tzresult Lwt.t
val typecheck_data :
?type_logger: (int * (Script.expr list * Script.expr list) -> unit) ->
?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
context -> Script.expr * Script.expr -> unit tzresult Lwt.t
val parse_script :
?type_logger: (int * (Script.expr list * Script.expr list) -> unit) ->
context -> Script.storage -> Script.code -> ex_script tzresult Lwt.t
?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
context -> Script.t -> ex_script tzresult Lwt.t

133
src/proto/alpha/script_repr.ml
View File

@ -9,142 +9,25 @@
open Tezos_hash
(* Tezos protocol "bootstrap" - untyped script representation *)
type location = Micheline.canonical_location
type location = int
let location_encoding = Micheline.canonical_location_encoding
let location_encoding =
let open Data_encoding in
def
"scriptLocation" @@
describe
~title:
"Script location"
~description:
"The location of a node in a script (code, data or type) \
as its index in the expression tree in prefix order, with \
zero being the root and adding one for every basic node, \
sequence and primitive application." @@
int31
type expr = Michelson_v1_primitives.prim Micheline.canonical
type expr = (* TODO: turn the location into an alpha ? *)
| Int of location * string
| String of location * string
| Prim of location * string * expr list * string option
| Seq of location * expr list * string option
type node = (location, Michelson_v1_primitives.prim) Micheline.node
let expr_encoding =
let open Data_encoding in
let int_encoding =
obj1 (req "int" string) in
let string_encoding =
obj1 (req "string" string) in
let prim_encoding expr_encoding =
let json =
union
[ case string
(function (v, [], None) -> Some v | _ -> None)
(fun v -> (v, [], None)) ;
case (assoc (tup2 (list expr_encoding) (option string)))
(fun (v, args, annot) -> Some [ (v, (args, annot)) ])
(function
| [ (v, (args, annot)) ] -> (v, args, annot)
| _ -> Json.cannot_destruct "invalid script expression") ] in
let binary =
obj3 (req "prim" string) (req "args" (list expr_encoding)) (opt "annot" string) in
splitted ~json ~binary in
let seq_encoding expr_encoding =
list expr_encoding in
mu "tezosScriptExpression" (fun expr_encoding ->
describe
~title: "Script expression (data, type or code)" @@
union ~tag_size:`Uint8
[ case ~tag:0 int_encoding
(function Int (_, v) -> Some v | _ -> None)
(fun v -> Int (-1, v)) ;
case ~tag:1 string_encoding
(function String (_, v) -> Some v | _ -> None)
(fun v -> String (-1, v)) ;
case ~tag:2 (prim_encoding expr_encoding)
(function
| Prim (_, v, args, annot) -> Some (v, args, annot)
| _ -> None)
(function (prim, args, annot) -> Prim (-1, prim, args, annot)) ;
case ~tag:3 (seq_encoding expr_encoding)
(function Seq (_, v, _annot) -> Some v | _ -> None)
(fun args -> Seq (-1, args, None)) ])
let update_locations ir =
let rec update_locations i = function
| Int (_, v) -> (Int (i, v), succ i)
| String (_, v) -> (String (i, v), succ i)
| Prim (_, name, args, annot) ->
let (nargs, ni) =
List.fold_left (fun (nargs, ni) arg ->
let narg, ni = update_locations ni arg in
(narg :: nargs, ni))
([], succ i) args in
(Prim (i, name, List.rev nargs, annot), ni)
| Seq (_, args, annot) ->
let (nargs, ni) =
List.fold_left (fun (nargs, ni) arg ->
let narg, ni = update_locations ni arg in
(narg :: nargs, ni))
([], succ i) args in
(Seq (i, List.rev nargs, annot), ni) in
fst (update_locations 1 ir)
let expr_encoding =
Data_encoding.conv
(fun to_write -> to_write)
(fun just_read -> update_locations just_read)
expr_encoding
type code =
{ code : expr ;
arg_type : expr ;
ret_type : expr ;
storage_type : expr }
type storage =
{ storage : expr ;
storage_type : expr }
open Data_encoding
let storage_encoding =
conv
(fun { storage ; storage_type } -> (storage, storage_type))
(fun (storage, storage_type) -> { storage ; storage_type })
(obj2
(req "storage" expr_encoding)
(req "storageType" expr_encoding))
let code_encoding =
conv
(fun { code; arg_type; ret_type; storage_type } ->
(code, arg_type, ret_type, storage_type))
(fun (code, arg_type, ret_type, storage_type) ->
{ code; arg_type; ret_type; storage_type })
(obj4
(req "code" expr_encoding)
(req "argType" expr_encoding)
(req "retType" expr_encoding)
(req "storageType" expr_encoding))
let expr_encoding = Micheline.canonical_encoding Michelson_v1_primitives.prim_encoding
let hash_expr data =
let bytes = Data_encoding.Binary.to_bytes expr_encoding data in
Script_expr_hash.(hash_bytes [ bytes ] |> to_b58check)
type t =
{ code : code ;
storage : storage }
type t = { code : expr ; storage : expr }
let encoding =
let open Data_encoding in
conv
(function { code ; storage } -> (code, storage))
(fun { code ; storage } -> (code, storage))
(fun (code, storage) -> { code ; storage })
(obj2
(req "code" code_encoding)
(req "storage" storage_encoding))
(obj2 (req "code" expr_encoding) (req "storage" expr_encoding))

42
src/proto/alpha/script_repr.mli
View File

@ -7,44 +7,18 @@
(* *)
(**************************************************************************)
(* A smart contract is some code and some storage. The storage has a
type and an initial value. The code is the code itself, the types of
its arguments, the type of its result, and the type of the storage
it is using.
type location = Micheline.canonical_location
All of them are expressed in a simple [expr] type, combining
[Int] (integer constant), [String] (string constant), [Prim]
(a generic primitive for most operations) and [Seq] a sequence
of operations.
*)
type expr = Michelson_v1_primitives.prim Micheline.canonical
type location =
int
type expr =
| Int of location * string
| String of location * string
| Prim of location * string * expr list * string option
| Seq of location * expr list * string option
type code =
{ code : expr ;
arg_type : expr ;
ret_type : expr ;
storage_type : expr }
type storage =
{ storage : expr ;
storage_type : expr }
type t =
{ code : code ;
storage : storage }
type node = (location, Michelson_v1_primitives.prim) Micheline.node
val location_encoding : location Data_encoding.t
val expr_encoding : expr Data_encoding.t
val storage_encoding : storage Data_encoding.t
val code_encoding : code Data_encoding.t
val encoding : t Data_encoding.t
val hash_expr : expr -> string
type t = { code : expr ; storage : expr }
val encoding : t Data_encoding.encoding

6
src/proto/alpha/services.ml
View File

@ -305,7 +305,7 @@ module Context = struct
RPC.service
~description: "Access the data of the contract."
~input: empty
~output: (wrap_tzerror (option Script.storage_encoding))
~output: (wrap_tzerror (option Script.expr_encoding))
RPC.Path.(custom_root / "context" / "contracts" /: Contract.arg / "storage")
type info = {
@ -365,7 +365,7 @@ module Helpers = struct
let run_code_input_encoding =
(obj6
(req "script" Script.code_encoding)
(req "script" Script.expr_encoding)
(req "storage" Script.expr_encoding)
(req "input" Script.expr_encoding)
(req "amount" Tez.encoding)
@ -414,7 +414,7 @@ module Helpers = struct
let typecheck_code custom_root =
RPC.service
~description: "Typecheck a piece of code in the current context"
~input: Script.code_encoding
~input: Script.expr_encoding
~output: (wrap_tzerror Script_ir_translator.type_map_enc)
RPC.Path.(custom_root / "helpers" / "typecheck_code")

10
src/proto/alpha/services_registration.ml
View File

@ -265,8 +265,6 @@ let () =
| None ->
Contract.default_contract
(List.hd (Bootstrap.accounts ctxt)).Bootstrap.public_key_hash in
let storage : Script.storage =
{ storage ; storage_type = (script : Script.code).storage_type } in
let qta =
Constants.instructions_per_transaction ctxt in
let origination_nonce =
@ -278,24 +276,24 @@ let () =
(script, storage, input, amount, contract, qta, origination_nonce) in
register1 Services.Helpers.run_code
(fun ctxt parameters ->
let (script, storage, input, amount, contract, qta, origination_nonce) =
let (code, storage, input, amount, contract, qta, origination_nonce) =
run_parameters ctxt parameters in
Script_interpreter.execute
origination_nonce
contract (* transaction initiator *)
contract (* script owner *)
ctxt storage script amount input
ctxt { storage ; code } amount input
qta >>=? fun (sto, ret, _qta, _ctxt, _) ->
Error_monad.return (sto, ret)) ;
register1 Services.Helpers.trace_code
(fun ctxt parameters ->
let (script, storage, input, amount, contract, qta, origination_nonce) =
let (code, storage, input, amount, contract, qta, origination_nonce) =
run_parameters ctxt parameters in
Script_interpreter.trace
origination_nonce
contract (* transaction initiator *)
contract (* script owner *)
ctxt storage script amount input
ctxt { storage ; code } amount input
qta >>=? fun ((sto, ret, _qta, _ctxt, _), trace) ->
Error_monad.return (sto, ret, trace))

8
src/proto/alpha/storage.ml
View File

@ -340,19 +340,19 @@ module Contract = struct
module Code =
Make_indexed_data_storage(struct
type key = Contract_repr.t
type value = Script_repr.code
type value = Script_repr.expr
let name = "contract code"
let key = Key.Contract.code
let encoding = Script_repr.code_encoding
let encoding = Script_repr.expr_encoding
end)
module Storage =
Make_indexed_data_storage(struct
type key = Contract_repr.t
type value = Script_repr.storage
type value = Script_repr.expr
let name = "contract storage"
let key = Key.Contract.storage
let encoding = Script_repr.storage_encoding
let encoding = Script_repr.expr_encoding
end)
module Code_fees =

4
src/proto/alpha/storage.mli
View File

@ -162,12 +162,12 @@ module Contract : sig
module Code : Indexed_data_storage
with type key = Contract_repr.t
and type value = Script_repr.code
and type value = Script_repr.expr
and type context := t
module Storage : Indexed_data_storage
with type key = Contract_repr.t
and type value = Script_repr.storage
and type value = Script_repr.expr
and type context := t
module Code_fees : Indexed_data_storage

6
src/proto/alpha/tezos_context.ml
View File

@ -45,8 +45,10 @@ module Script_timestamp = struct
|> Timestamp.to_seconds
|> of_int64
end
module Script = Script_repr
module Script = struct
include Michelson_v1_primitives
include Script_repr
end
type public_key = Ed25519.Public_key.t
type public_key_hash = Ed25519.Public_key_hash.t
type secret_key = Ed25519.Secret_key.t

128
src/proto/alpha/tezos_context.mli
View File

@ -125,34 +125,120 @@ end
module Script : sig
type location = int
type prim = Michelson_v1_primitives.prim =
| K_parameter
| K_return
| K_storage
| K_code
| D_False
| D_Item
| D_Left
| D_List
| D_Map
| D_None
| D_Pair
| D_Right
| D_Set
| D_Some
| D_True
| D_Unit
| I_H
| I_ABS
| I_ADD
| I_AMOUNT
| I_AND
| I_BALANCE
| I_CAR
| I_CDR
| I_CHECK_SIGNATURE
| I_COMPARE
| I_CONCAT
| I_CONS
| I_CREATE_ACCOUNT
| I_CREATE_CONTRACT
| I_DEFAULT_ACCOUNT
| I_DIP
| I_DROP
| I_DUP
| I_EDIV
| I_EMPTY_MAP
| I_EMPTY_SET
| I_EQ
| I_EXEC
| I_FAIL
| I_GE
| I_GET
| I_GT
| I_HASH_KEY
| I_IF
| I_IF_CONS
| I_IF_LEFT
| I_IF_NONE
| I_INT
| I_LAMBDA
| I_LE
| I_LEFT
| I_LOOP
| I_LSL
| I_LSR
| I_LT
| I_MANAGER
| I_MAP
| I_MEM
| I_MUL
| I_NEG
| I_NEQ
| I_NIL
| I_NONE
| I_NOT
| I_NOW
| I_OR
| I_PAIR
| I_PUSH
| I_REDUCE
| I_RIGHT
| I_SIZE
| I_SOME
| I_SOURCE
| I_STEPS_TO_QUOTA
| I_SUB
| I_SWAP
| I_TRANSFER_TOKENS
| I_UNIT
| I_UPDATE
| I_XOR
| T_bool
| T_contract
| T_int
| T_key
| T_key_hash
| T_lambda
| T_list
| T_map
| T_nat
| T_option
| T_or
| T_pair
| T_set
| T_signature
| T_string
| T_tez
| T_timestamp
| T_unit
type expr =
| Int of location * string
| String of location * string
| Prim of location * string * expr list * string option
| Seq of location * expr list * string option
type location = Micheline.canonical_location
type code = {
code: expr ;
arg_type: expr ;
ret_type: expr ;
storage_type: expr ;
}
type expr = prim Micheline.canonical
type storage = {
storage: expr ;
storage_type: expr ;
}
type node = (location, prim) Micheline.node
type t =
{ code : code ;
storage : storage }
{ code : expr ;
storage : expr }
val location_encoding: location Data_encoding.t
val expr_encoding: expr Data_encoding.t
val storage_encoding: storage Data_encoding.t
val code_encoding: code Data_encoding.t
val prim_encoding: prim Data_encoding.t
val encoding: t Data_encoding.t
val hash_expr : expr -> string
@ -345,7 +431,7 @@ module Contract : sig
val get_script:
context -> contract -> (Script.t option) tzresult Lwt.t
val get_storage:
context -> contract -> (Script.storage option) tzresult Lwt.t
context -> contract -> (Script.expr option) tzresult Lwt.t
val get_counter: context -> contract -> int32 tzresult Lwt.t
val get_balance: