Michelson: Switch parser/printer/representation to Micheline

src/client/embedded/alpha/client_proto_context.ml

@@ -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 ->
+        Lwt.return (Michelson_v1_parser.parse_expression arg) >>=? fun { expanded = arg } ->
-        return (Some arg.ast)
+        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 () =
+    ~code ~init ~fee ~spendable () =
-  Client_proto_programs.parse_data init >>=? fun storage ->
+  Lwt.return (Michelson_v1_parser.parse_expression init) >>=? fun { expanded = storage } ->
-  let storage = Script.{ storage=storage.ast ; storage_type = code.storage_type } in
   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 () ->

src/client/embedded/alpha/client_proto_context.mli

@@ -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 ->

src/client/embedded/alpha/client_proto_programs.ml

@@ -9,691 +9,21 @@
 
 module Ed25519 = Environment.Ed25519
 open Client_proto_args
-
+open Michelson_v1_printer
-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 }
 
 module Program = Client_aliases.Alias (struct
-    type t = Script.code parsed
+    type t = Michelson_v1_parser.parsed
     let encoding =
-      let open Data_encoding in
+      Data_encoding.conv
-      let loc_table_encoding =
+        (fun { Michelson_v1_parser.source } -> source)
-        assoc (list (tup2 uint16 Script_located_ir.location_encoding)) in
+        (fun source ->
-      conv
+           match Michelson_v1_parser.parse_toplevel source with
-        (fun { ast ; source ; loc_table } -> (ast, source, loc_table))
+           | Ok parsed -> parsed
-        (fun (ast, source, loc_table) -> { ast ; source ; loc_table })
+           | Error _ -> Pervasives.failwith "could not decode Michelson program alias")
-        (obj3
+        Data_encoding.string
-           (req "ast" Script.code_encoding)
+    let of_source _cctxt source =
-           (req "source" string)
+      Lwt.return (Michelson_v1_parser.parse_toplevel source)
-           (req "loc_table" loc_table_encoding))
+    let to_source _ { Michelson_v1_parser.source } = return source
-    let of_source _cctxt s = parse_program s
-    let to_source _ { 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 storage
-                 (print_expr no_locations) output
+                 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 storage
-                 (print_expr no_locations) output >>= fun () ->
+                 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 =
+           let type_map, errs = match res with
-             (Utils.filter_map
+             | Ok type_map -> type_map, []
-                (fun (n, loc) ->
+             | Error (Environment.Ecoproto_error
-                   try
+                        (Script_ir_translator.Ill_typed_contract (_, type_map ) :: _)
-                     let bef, aft = List.assoc n type_map in
+                      :: _ as errs) ->
-                     Some (loc, bef, aft)
+                 type_map, errs
-                   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)
              | Error errs ->
-                 let msg = Buffer.create 5000 in
+                 [], errs 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) ->
            cctxt.message
-             "((types . (%a)) (errors . (%a)))"
+             "(@[<v 0>(types . %a)@ (errors . %a)@])"
-             (Format.pp_print_list
+             Michelson_v1_emacs.print_type_map (program, type_map)
-                (fun ppf ({ Script_located_ir.start = { point = s } ; stop = { point = e } },
+             Michelson_v1_emacs.report_errors (program, errs) >>= fun () ->
-                          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 () ->
            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"

src/client/embedded/alpha/client_proto_programs.mli

@@ -7,19 +7,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type 'a parsed =
+module Program : Client_aliases.Alias with type t = Michelson_v1_parser.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
 
 val commands: unit -> Client_commands.command list

src/client/embedded/alpha/client_proto_rpcs.mli

@@ -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

src/client/embedded/alpha/michelson_macros.ml

@@ -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

src/client/embedded/alpha/michelson_macros.mli

@@ -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 : 'l node -> 'l node
-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
 
-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_caddadr : 'l node -> 'l node option
-val unexpand_set_caddadr : expr -> expr option
+val unexpand_set_caddadr : 'l node -> 'l node option
-val unexpand_map_caddadr : expr -> expr option
+val unexpand_map_caddadr : 'l node -> 'l node option
-val unexpand_dxiiivp : expr -> expr option
+val unexpand_dxiiivp : 'l node -> 'l node option
-val unexpand_paaiair : expr -> expr option
+val unexpand_paaiair : 'l node -> 'l node option
-val unexpand_duuuuup : expr -> expr option
+val unexpand_duuuuup : 'l node -> 'l node option
-val unexpand_compare : expr -> expr option
+val unexpand_compare : 'l node -> 'l node option
-val unexpand_asserts : expr -> expr option
+val unexpand_asserts : 'l node -> 'l node option
-val unexpand_unpaaiair : expr -> expr option
+val unexpand_unpaaiair : 'l node -> 'l node option
-val unexpand_if_some : expr -> expr option
+val unexpand_if_some : 'l node -> 'l node option
-val unexpand_if_right : expr -> expr option
+val unexpand_if_right : 'l node -> 'l node option

src/client/embedded/alpha/michelson_parser.ml

@@ -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 [] ]

src/client/embedded/alpha/michelson_parser.mli

@@ -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

src/client/embedded/alpha/michelson_v1_emacs.ml

@@ -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

src/client/embedded/alpha/michelson_v1_emacs.mli

@@ -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

src/client/embedded/alpha/michelson_v1_error_reporter.ml

@@ -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

src/client/embedded/alpha/michelson_v1_error_reporter.mli

@@ -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

src/client/embedded/alpha/michelson_v1_parser.ml

@@ -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

src/client/embedded/alpha/michelson_v1_parser.mli

@@ -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

src/client/embedded/alpha/michelson_v1_printer.ml

@@ -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

src/client/embedded/alpha/michelson_v1_printer.mli

@@ -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

src/client/embedded/alpha/script_located_ir.ml

@@ -7,19 +7,15 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type point =
+type point = Micheline_parser.point =
   { point : int ;
     byte : int ;
     line : int ;
     column : int }
 
-let point_zero =
+let point_zero = Micheline_parser.point_zero
-  { point = 0 ;
-    byte = 0 ;
-    line = 0 ;
-    column = 0 }
 
-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 =
+type node = (location, string) Micheline.node
-  | Int of location * string
+
-  | String of location * string
+open Micheline
-  | Prim of location * string * node list * string option
-  | Seq of location * node list * string option
 
 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
 

src/proto/alpha/TEZOS_PROTOCOL

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

src/proto/alpha/apply.ml

@@ -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
+          Lwt.return (Script_ir_translator.parse_toplevel script.code) >>=? fun (arg_type, _, _, _) ->
-          | None, Prim (_, "unit", _, _) -> call_contract (Prim (0, "Unit", [], None))
+          let arg_type = Micheline.strip_locations arg_type in
-          | Some parameters, arg_type -> begin
+          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) ->
+        | Some script ->
-            Script_ir_translator.parse_script ctxt storage code >>=? fun _ ->
+            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 ->

src/proto/alpha/contract_storage.ml

@@ -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 ->

src/proto/alpha/contract_storage.mli

@@ -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
 

src/proto/alpha/michelson_v1_primitives.ml

@@ -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)

src/proto/alpha/michelson_v1_primitives.mli

@@ -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

src/proto/alpha/script_interpreter.ml

@@ -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 "contractCode" Script.expr_encoding))
-       (req "contractParameterType" ex_ty_enc)
-       (req "contractReturnType" ex_ty_enc)
-       (req "contractStorageType" ex_ty_enc))
     (function
-      | Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty) ->
+      | Runtime_contract_error (contract, expr) ->
-          Some (contract, expr, Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty)
+          Some (contract, expr)
       | _ -> None)
-    (fun (contract, expr, Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty) ->
+    (fun (contract, expr) ->
-       Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty));
+       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.
@@ -237,21 +234,21 @@ let rec interp
               Lwt.return Tez.(x -? y) >>=? fun res ->
               logged_return (Item (res, rest), qta - 1, ctxt)
           | Mul_teznat, Item (x, Item (y, rest)) ->
-             begin
+              begin
-               match Script_int.to_int64 y with
+                match Script_int.to_int64 y with
-               | None -> fail (Overflow loc)
+                | None -> fail (Overflow loc)
-               | Some y ->
+                | Some y ->
-                  Lwt.return Tez.(x *? y) >>=? fun res ->
+                    Lwt.return Tez.(x *? y) >>=? fun res ->
-                  logged_return (Item (res, rest), qta - 1, ctxt)
+                    logged_return (Item (res, rest), qta - 1, ctxt)
-             end
+              end
           | Mul_nattez, Item (y, Item (x, rest)) ->
-             begin
+              begin
-               match Script_int.to_int64 y with
+                match Script_int.to_int64 y with
-               | None -> fail (Overflow loc)
+                | None -> fail (Overflow loc)
-               | Some y ->
+                | Some y ->
-                  Lwt.return Tez.(x *? y) >>=? fun res ->
+                    Lwt.return Tez.(x *? y) >>=? fun res ->
-                  logged_return (Item (res, rest), qta - 1, ctxt)
+                    logged_return (Item (res, rest), qta - 1, ctxt)
-             end
+              end
           (* boolean operations *)
           | Or, Item (x, Item (y, rest)) ->
               logged_return (Item (x || y, rest), qta - 1, ctxt)
@@ -287,53 +284,53 @@ let rec interp
           | Mul_natint, Item (x, Item (y, rest)) ->
               logged_return (Item (Script_int.mul x y, rest), qta - 1, ctxt)
           | Mul_natnat, Item (x, Item (y, rest)) ->
-             logged_return (Item (Script_int.mul_n x y, rest), qta - 1, ctxt)
+              logged_return (Item (Script_int.mul_n x y, rest), qta - 1, ctxt)
 
           | Ediv_teznat, Item (x, Item (y, rest)) ->
-             let x = Script_int.of_int64 (Tez.to_cents x) in
+              let x = Script_int.of_int64 (Tez.to_cents x) in
-             let result =
+              let result =
-               match Script_int.ediv x y with
+                match Script_int.ediv x y with
-               | None -> None
+                | None -> None
-               | Some (q, r) ->
+                | Some (q, r) ->
-                  match Script_int.to_int64 q,
+                    match Script_int.to_int64 q,
-                        Script_int.to_int64 r with
+                          Script_int.to_int64 r with
-                  | Some q, Some r ->
+                    | Some q, Some r ->
-                     begin
+                        begin
-                       match Tez.of_cents q, Tez.of_cents r with
+                          match Tez.of_cents q, Tez.of_cents r with
-                       | Some q, Some r -> Some (q,r)
+                          | Some q, Some r -> Some (q,r)
-                       (* Cannot overflow *)
+                          (* Cannot overflow *)
-                       | _ -> assert false
+                          | _ -> assert false
-                     end
+                        end
-                  (* Cannot overflow *)
+                    (* Cannot overflow *)
-                  | _ -> assert false
+                    | _ -> assert false
               in
               logged_return (Item (result, rest), qta -1, ctxt)
 
           | Ediv_tez, Item (x, Item (y, rest)) ->
-             let x = Script_int.abs (Script_int.of_int64 (Tez.to_cents x)) in
+              let x = Script_int.abs (Script_int.of_int64 (Tez.to_cents x)) in
-             let y = Script_int.abs (Script_int.of_int64 (Tez.to_cents y)) in
+              let y = Script_int.abs (Script_int.of_int64 (Tez.to_cents y)) in
-             begin match Script_int.ediv_n x y with
+              begin match Script_int.ediv_n x y with
-               | None ->
+                | None ->
-                   logged_return (Item (None, rest), qta -1, ctxt)
+                    logged_return (Item (None, rest), qta -1, ctxt)
-               | Some (q, r) ->
+                | Some (q, r) ->
-                   let r =
+                    let r =
-                     match Script_int.to_int64 r with
+                      match Script_int.to_int64 r with
-                     | None -> assert false (* Cannot overflow *)
+                      | None -> assert false (* Cannot overflow *)
-                     | Some r ->
+                      | Some r ->
-                         match Tez.of_cents r with
+                          match Tez.of_cents r with
-                         | None -> assert false (* Cannot overflow *)
+                          | None -> assert false (* Cannot overflow *)
-                         | Some r -> r in
+                          | Some r -> r in
-                   logged_return (Item (Some (q, r), rest), qta -1, ctxt)
+                    logged_return (Item (Some (q, r), rest), qta -1, ctxt)
-             end
+              end
 
           | Ediv_intint, Item (x, Item (y, rest)) ->
-               logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt)
+              logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt)
           | Ediv_intnat, Item (x, Item (y, rest)) ->
-               logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt)
+              logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt)
           | Ediv_natint, Item (x, Item (y, rest)) ->
-               logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt)
+              logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt)
           | Ediv_natnat, Item (x, Item (y, rest)) ->
-               logged_return (Item (Script_int.ediv_n x y, rest), qta -1, ctxt)
+              logged_return (Item (Script_int.ediv_n x y, rest), qta -1, ctxt)
           | Lsl_nat, Item (x, Item (y, rest)) ->
               begin match Script_int.shift_left_n x y with
                 | None -> fail (Overflow loc)
@@ -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 } } ->
+                  | Some { storage } ->
-                      parse_data ctxt storage_type storage >>=? fun sto ->
+                      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 } ->
+              | Some 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 ->
                   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 } } ->
+                      | Some { storage } ->
-                          parse_data ctxt storage_type storage >>=? fun sto ->
+                          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 (manager, Item
-                                                                    Item (Lam (_, code), Item (init, rest))))))) ->
+                    (delegate, Item
-              let code, storage =
+                       (spendable, Item
-                { code; arg_type = unparse_ty p; ret_type = unparse_ty r; storage_type =  unparse_ty g },
+                          (delegatable, Item
-                { storage = unparse_data g init; storage_type =  unparse_ty g } in
+                             (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 =
+and execute ?log origination orig source ctxt script amount arg qta =
-  parse_script ctxt storage script
+  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) ->
+  >>=? fun ((ret, storage), qta, ctxt, origination) ->
-  let ret, storage = ret in
+  return (Micheline.strip_locations (unparse_data storage_type storage),
-  return (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 ->
+  execute ~log origination orig source ctxt script amount (Micheline.root arg) qta
-  return (res, List.rev !log)
+  >>=? 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 =
+let execute origination orig source ctxt script amount arg qta =
-  execute orig source ctxt storage 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)

src/proto/alpha/script_interpreter.mli

@@ -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

src/proto/alpha/script_ir_translator.mli

@@ -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 namespace =
-type kind =  Int_kind | String_kind | Prim_kind | Seq_kind
+    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_arity of Script.location * Script.prim * int * int
-type error += Invalid_namespace of Script.location * string * namespace * namespace
+type error += Invalid_namespace of Script.location * Script.prim * namespace * namespace
-type error += Invalid_primitive of Script.location * string list * string
+type error += Invalid_primitive of Script.location * Script.prim list * Script.prim
-type error += Invalid_case of Script.location * string
 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_binop : Script.location * Script.prim * _ Script_typed_ir.ty * _ Script_typed_ir.ty -> error
-type error += Undefined_unop : Script.location * string * _ 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_formed_type of string option * Script.expr * Script.location
-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_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) ->
+  ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
-  context -> 'a Script_typed_ir.ty -> Script.expr -> 'a tzresult Lwt.t
+  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) ->
+  ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
-  context -> Script.storage -> Script.code -> ex_script tzresult Lwt.t
+  context -> Script.t -> ex_script tzresult Lwt.t

src/proto/alpha/script_repr.ml

@@ -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 =
+type expr = Michelson_v1_primitives.prim Micheline.canonical
-  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 = (* TODO: turn the location into an alpha ? *)
+type node = (location, Michelson_v1_primitives.prim) Micheline.node
-  | Int of location * string
-  | String of location * string
-  | Prim of location * string * expr list * string option
-  | Seq of location * expr list * string option
 
-let expr_encoding =
+let expr_encoding = Micheline.canonical_encoding Michelson_v1_primitives.prim_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 hash_expr data =
   let bytes = Data_encoding.Binary.to_bytes expr_encoding data in
   Script_expr_hash.(hash_bytes [ bytes ] |> to_b58check)
 
-type t =
+type t = { code : expr ; storage : expr }
-  { code : code ;
-    storage : storage }
 
 let encoding =
   let open Data_encoding in
   conv
-    (function { code ; storage } -> (code, storage))
+    (fun { code ; storage } -> (code, storage))
     (fun (code, storage) -> { code ; storage })
-    (obj2
+    (obj2 (req "code" expr_encoding) (req "storage" expr_encoding))
-       (req "code" code_encoding)
-       (req "storage" storage_encoding))

src/proto/alpha/script_repr.mli

@@ -7,44 +7,18 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* A smart contract is some code and some storage. The storage has a
+type location = Micheline.canonical_location
-  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.
 
-  All of them are expressed in a simple [expr] type, combining
+type expr = Michelson_v1_primitives.prim Micheline.canonical
-  [Int] (integer constant), [String] (string constant), [Prim]
-  (a generic primitive for most operations) and [Seq] a sequence
-  of operations.
- *)
 
-type location =
+type node = (location, Michelson_v1_primitives.prim) Micheline.node
-  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 }
 
 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

src/proto/alpha/services.ml

@@ -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")
 

src/proto/alpha/services_registration.ml

@@ -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))
 

src/proto/alpha/storage.ml

@@ -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 =

src/proto/alpha/storage.mli

@@ -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

src/proto/alpha/tezos_context.ml

@@ -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

src/proto/alpha/tezos_context.mli

@@ -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 =
+  type location = Micheline.canonical_location
-    | 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 = {
+  type expr = prim Micheline.canonical
-    code: expr ;
-    arg_type: expr ;
-    ret_type: expr ;
-    storage_type: expr ;
-  }
 
-  type storage = {
+  type node = (location, prim) Micheline.node
-    storage: expr ;
-    storage_type: expr ;
-  }
 
   type t =
-    { code : code ;
+    { code : expr ;
-      storage : storage }
+      storage : expr }
 
   val location_encoding: location Data_encoding.t
   val expr_encoding: expr Data_encoding.t
-  val storage_encoding: storage Data_encoding.t
+  val prim_encoding: prim Data_encoding.t
-  val code_encoding: code 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: