From f50a37e6f481d4ad033de3d25c2051ef8adcdc59 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Wed, 14 Jun 2017 23:35:24 +0200 Subject: [PATCH] Michelson: new parser and macro expander. --- src/client/embedded/Makefile.shared | 10 +- src/client/embedded/alpha/Makefile | 9 +- .../embedded/alpha/client_proto_programs.ml | 338 +++++---- src/client/embedded/alpha/concrete_lexer.mll | 368 ---------- src/client/embedded/alpha/concrete_parser.mly | 280 -------- src/client/embedded/alpha/michelson_macros.ml | 672 ++++++++++++++++++ .../embedded/alpha/michelson_macros.mli | 34 + src/client/embedded/alpha/michelson_parser.ml | 521 ++++++++++++++ .../embedded/alpha/michelson_parser.mli | 44 ++ .../embedded/alpha/script_located_ir.ml | 77 +- src/proto/alpha/apply.ml | 4 +- src/proto/alpha/script_ir_translator.ml | 647 +++++++++-------- src/proto/alpha/script_repr.ml | 32 +- src/proto/alpha/script_repr.mli | 4 +- src/proto/alpha/script_typed_ir.ml | 3 +- src/proto/alpha/tezos_context.mli | 4 +- test/contracts/compare.tz | 2 +- test/contracts/create_contract.tz | 18 +- test/contracts/hardlimit.tz | 6 +- test/test_utils.sh | 4 +- 20 files changed, 1897 insertions(+), 1180 deletions(-) delete mode 100644 src/client/embedded/alpha/concrete_lexer.mll delete mode 100644 src/client/embedded/alpha/concrete_parser.mly create mode 100644 src/client/embedded/alpha/michelson_macros.ml create mode 100644 src/client/embedded/alpha/michelson_macros.mli create mode 100644 src/client/embedded/alpha/michelson_parser.ml create mode 100644 src/client/embedded/alpha/michelson_parser.mli diff --git a/src/client/embedded/Makefile.shared b/src/client/embedded/Makefile.shared index 3c4b859a8..987f9bd11 100644 --- a/src/client/embedded/Makefile.shared +++ b/src/client/embedded/Makefile.shared @@ -37,7 +37,7 @@ ${OBJS} ${OBJS_DEPS}: TARGET="(client_$(PROTO_VERSION).cmx)" ${OBJS}: EXTRA_OCAMLFLAGS = -for-pack Client_$(PROTO_VERSION) ../client_$(PROTO_VERSION).cmx: EXTRA_OCAMLFLAGS = ${OBJS} ${OBJS_DEPS} ../client_$(PROTO_VERSION).cmx: \ - PACKAGES=lwt ocplib-json-typed sodium ocplib-ocamlres + PACKAGES=lwt ocplib-json-typed sodium ocplib-ocamlres uutf ${OBJS} ${OBJS_DEPS} ../client_$(PROTO_VERSION).cmx: \ ../../../proto/client_embedded_proto_${PROTO_VERSION}.cmxa @@ -58,14 +58,6 @@ ${OBJS} ${OBJS_DEPS} ../client_$(PROTO_VERSION).cmx: \ @echo OCAMLOPT ${TARGET} $(notdir $@) @$(OCAMLOPT) ${OCAMLFLAGS} -c $< -%.ml: %.mll - @echo OCAMLLEX ${TARGET} $(notdir $@) - @$(OCAMLLEX) $< - -%.ml %.mli: %.mly - @echo MENHIR ${TARGET} $(notdir $@) - @$(MENHIR) --explain $< - .PHONY: clean clean:: -rm -f ../client_$(PROTO_VERSION).cm* ../client_$(PROTO_VERSION).o diff --git a/src/client/embedded/alpha/Makefile b/src/client/embedded/alpha/Makefile index 0638c88b0..62db8e14f 100644 --- a/src/client/embedded/alpha/Makefile +++ b/src/client/embedded/alpha/Makefile @@ -2,7 +2,8 @@ PROTO_VERSION := alpha CLIENT_INTFS := \ - concrete_parser.mli \ + michelson_macros.mli \ + michelson_parser.mli \ client_proto_rpcs.mli \ client_proto_args.mli \ client_proto_contracts.mli \ @@ -13,7 +14,8 @@ CLIENT_INTFS := \ CLIENT_IMPLS := \ script_located_ir.ml \ - concrete_parser.ml concrete_lexer.ml \ + michelson_macros.ml \ + michelson_parser.ml \ client_proto_rpcs.ml \ client_proto_args.ml \ client_proto_contracts.ml \ @@ -28,10 +30,7 @@ include ../Makefile.shared ${OBJS}: OPENED_MODULES += Environment Tezos_context -predepend: concrete_parser.ml concrete_lexer.ml - .PHONY: clean clean:: -rm -f baker/*.cm* baker/*~ baker/*.o baker/*.a -rm -f baker/*.deps baker/*.deps.byte - -rm -f concrete_lexer.ml concrete_parser.ml concrete_parser.mli diff --git a/src/client/embedded/alpha/client_proto_programs.ml b/src/client/embedded/alpha/client_proto_programs.ml index f79176064..d7e4ee211 100644 --- a/src/client/embedded/alpha/client_proto_programs.ml +++ b/src/client/embedded/alpha/client_proto_programs.ml @@ -10,30 +10,75 @@ module Ed25519 = Environment.Ed25519 open Client_proto_args -let report_parse_error _prefix exn _lexbuf = +let report_parse_error prefix exn = let open Lexing in let open Script_located_ir in - let print_loc ppf (s, e) = - if s.line = e.line then - if s.column = e.column then - Format.fprintf ppf - "at line %d character %d" - s.line s.column + 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" - s.line s.column e.column + 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" - s.line s.column e.line e.column in + loc.start.line loc.start.column loc.stop.line loc.stop.column in match exn with - | Missing_program_field n -> + | Script_located_ir.Missing_program_field n -> failwith "missing script %s" n - | Illegal_character (loc, c) -> - failwith "%a, illegal character %C" print_loc loc c - | Illegal_escape (loc, c) -> - failwith "%a, illegal escape sequence %S" print_loc loc c + | 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 -> @@ -45,41 +90,54 @@ let print_location_mark ppf = function 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, []) -> + | 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 + | Some _ as l -> Format.fprintf ppf "%s%a" name print_location_mark l end - | Script.Prim (loc, name, args) -> - Format.fprintf ppf (if emacs then "%s%a %a" else "@[%s%a@ %a@]") - name print_location_mark (locations loc) + | Script.Prim (loc, name, args, (Some _ as annot)) -> + Format.fprintf ppf (if emacs then "%s%a %a" else "@[%s%a@ %a]") + name print_location_mark (locations loc) print_annotation annot + | Script.Prim (loc, name, args, annot) -> + Format.fprintf ppf "@[%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, []) -> + | 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) -> + | Script.Seq (loc, exprs, annot) -> begin match locations loc with | None -> Format.fprintf ppf "@[{ " | Some _ as l -> Format.fprintf ppf "@[{%a@ " print_location_mark l end ; - Format.fprintf ppf "%a@] }" + 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 (_, _, _ :: _) as expr -> + | 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 @@ -103,19 +161,33 @@ 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 "@[[ %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, []) -> + | Script.Prim (loc, name, [], None) -> Format.fprintf ppf "%s%a" name print_location_mark (locations loc) - | Script.Prim (loc, name, args) -> - Format.fprintf ppf "@[%s%a@ %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 "@[%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, []) -> + | Script.Seq (loc, [], None) -> begin match List.assoc loc type_map with | exception Not_found -> Format.fprintf ppf "{}" | (first, _) -> @@ -127,17 +199,33 @@ let print_typed_code locations ppf (expr, type_map) = Format.fprintf ppf "{%a %a }" print_location_mark l print_stack first end - | Script.Seq (loc, exprs) -> - begin match locations loc with - | None -> + | 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 "@[{ " - | Some _ as l -> - Format.fprintf ppf "@[{%a@," + | None, Some annot -> + Format.fprintf ppf "@[{ %@%s@," annot + | Some _ as l, _ -> + Format.fprintf ppf "@[{%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 ] -> + | [ Script.Int (loc, _) | String (loc, _) | Prim (loc, _, _, _) as expr ] -> begin match List.assoc loc type_map with | exception Not_found -> Format.fprintf ppf "%a }@]" @@ -148,7 +236,7 @@ let print_typed_code locations ppf (expr, type_map) = print_typed_code_unwrapped expr print_stack after end ; - | Script.Int (loc, _) | String (loc, _) | Prim (loc, _, _) as expr :: rest -> + | 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 ;@," @@ -160,10 +248,10 @@ let print_typed_code locations ppf (expr, type_map) = print_typed_code_unwrapped expr ; loop rest end ; - | [ Seq (_, _) as expr ] -> + | [ Seq (_, _, _) as expr ] -> Format.fprintf ppf "%a }@]" print_typed_code_unwrapped expr - | Seq (_, _) as expr :: rest -> + | Seq (_, _, _) as expr :: rest -> Format.fprintf ppf "%a@," print_typed_code_unwrapped expr ; loop rest in @@ -173,20 +261,18 @@ let print_typed_code locations ppf (expr, type_map) = | 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 -> + | 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 - "@[@[storage@ %a ;@]@,\ - @[parameter@ %a ;@]@,\ - @[return@ %a ;@]@,\ + "@[%a ;@,%a ;@,%a ;@,\ @[code@ %a@]@]" - (print_expr no_locations) c.storage_type - (print_expr no_locations) c.arg_type - (print_expr no_locations) c.ret_type + (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 = @@ -489,91 +575,101 @@ type 'a parsed = loc_table : (string * (int * Script_located_ir.location) list) list } let parse_program source = - let lexbuf = Lexing.from_string source in try - return - (Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf |> fun fields -> - let rec get_field n = function - | Script_located_ir.Prim (_, pn, [ ctns ]) :: _ when n = pn -> ctns - | _ :: rest -> get_field n rest - | [] -> raise (Script_located_ir.Missing_program_field n) in - let code, code_loc_table = - Script_located_ir.strip_locations (get_field "code" fields) in - let arg_type, parameter_loc_table = - Script_located_ir.strip_locations (get_field "parameter" fields) in - let ret_type, return_loc_table = - Script_located_ir.strip_locations (get_field "return" fields) in - let storage_type, storage_loc_table = - Script_located_ir.strip_locations (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 - { ast ; source ; loc_table }) + 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 lexbuf + | exn -> report_parse_error "program" exn let parse_data source = - let lexbuf = Lexing.from_string source in try - match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with - | [node] -> - let ast, loc_table = Script_located_ir.strip_locations node in - let loc_table = [ "data", loc_table ] in - return { ast ; source ; loc_table } - | _ -> failwith "single data expression expected" + 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 lexbuf + | exn -> report_parse_error "data" exn let parse_data_type source = - let lexbuf = Lexing.from_string source in try - match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with - | [node] -> - let ast, loc_table = Script_located_ir.strip_locations node in - let loc_table = [ "data", loc_table ] in - return { ast ; source ; loc_table } - | _ -> failwith "single type expression expected" + 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_type: " exn lexbuf + | exn -> report_parse_error "type" exn let unexpand_macros type_map (program : Script.code) = let open Script in - let rec caddr type_map acc = function - | [] -> Some (List.rev acc) - | Prim (loc, "CAR" , []) :: rest when List.mem_assoc loc type_map -> - caddr type_map ((loc, "A") :: acc) rest - | Prim (loc, "CDR" , []) :: rest when List.mem_assoc loc type_map -> - caddr type_map ((loc, "D") :: acc) rest - | _ -> None in - let rec unexpand type_map node = - match node with - | Seq (loc, l) -> - begin match caddr type_map [] l with - | None | Some [] -> - let type_map, l = - List.fold_left - (fun (type_map, acc) e -> - let type_map, e = unexpand type_map e in - type_map, e :: acc) - (type_map, []) - l in - type_map, Seq (loc, List.rev l) - | Some l -> - let locs, steps = List.split l in - let name = "C" ^ String.concat "" steps ^ "R" in - let first, last = List.hd locs, List.hd (List.rev locs) in - let (before, _) = List.assoc first type_map in - let (_, after) = List.assoc last type_map in - let type_map = - List.filter - (fun (loc, _) -> not (List.mem loc locs)) - type_map in - let type_map = (loc, (before, after)) :: type_map in - type_map, Prim (loc, name, []) - end + 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 } @@ -745,15 +841,13 @@ let commands () = cctxt.message "((types . (%a)) (errors . (%a)))" (Format.pp_print_list - (fun ppf (({ Script_located_ir.point = s }, - { Script_located_ir.point = e }), + (fun ppf ({ Script_located_ir.start = { point = s } ; stop = { point = e } }, bef, aft) -> Format.fprintf ppf "(%d %d %a %a)" (s + 1) (e + 1) print_emacs_stack bef print_emacs_stack aft)) types (Format.pp_print_list - (fun ppf (({ Script_located_ir.point = s }, - { Script_located_ir.point = e }), + (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 () -> diff --git a/src/client/embedded/alpha/concrete_lexer.mll b/src/client/embedded/alpha/concrete_lexer.mll deleted file mode 100644 index ef5dd8e63..000000000 --- a/src/client/embedded/alpha/concrete_lexer.mll +++ /dev/null @@ -1,368 +0,0 @@ - -{ - -open Concrete_parser - -open Script_located_ir - -let count_nl s = - let c = ref 0 in - for i = 0 to String.length s - 1 do - if Compare.Char.(s.[i] = '\010') then - incr c - done; - !c - -let update_loc lexbuf nl indent = - let open Lexing in - let lcp = lexbuf.lex_curr_p in - lexbuf.lex_curr_p <- { lcp with - pos_lnum = lcp.pos_lnum + nl; - pos_bol = lcp.pos_cnum - indent; - } - -let may_update_loc lexbuf nl indent = - if Compare.Int.(nl <> 0) then update_loc lexbuf nl indent - -let start_offset lexbuf = - let open Lexing in - let lsp = lexbuf.lex_start_p in - lsp.pos_cnum - lsp.pos_bol - -let end_offset lexbuf = - let open Lexing in - let lcp = lexbuf.lex_curr_p in - lcp.pos_cnum - lcp.pos_bol - -let curr_location lexbuf = - lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p - -let pos pos = - { line = pos.Lexing.pos_lnum ; - column = pos.Lexing.pos_cnum - pos.Lexing.pos_bol ; - point = pos.Lexing.pos_cnum } - -let pos2 (start, stop) = - pos start, pos stop - -(* To translate escape sequences *) - -let char_for_backslash = function - | 'n' -> '\010' - | 'r' -> '\013' - | 'b' -> '\008' - | 't' -> '\009' - | c -> c - -let char_for_decimal_code lexbuf i = - let c = 100 * (int_of_char(Lexing.lexeme_char lexbuf i) - 48) + - 10 * (int_of_char(Lexing.lexeme_char lexbuf (i+1)) - 48) + - (int_of_char(Lexing.lexeme_char lexbuf (i+2)) - 48) in - if Compare.Int.(c < 0 || c > 255) then - raise @@ Illegal_escape (pos2 (curr_location lexbuf), Lexing.lexeme lexbuf) - else char_of_int c - -let char_for_hexadecimal_code lexbuf i = - let d1 = int_of_char (Lexing.lexeme_char lexbuf i) in - let val1 = if Compare.Int.(d1 >= 97) then d1 - 87 - else if Compare.Int.(d1 >= 65) then d1 - 55 - else d1 - 48 - in - let d2 = int_of_char (Lexing.lexeme_char lexbuf (i+1)) in - let val2 = if Compare.Int.(d2 >= 97) then d2 - 87 - else if Compare.Int.(d2 >= 65) then d2 - 55 - else d2 - 48 - in - char_of_int (val1 * 16 + val2) - -(** Lexer state *) - -type state = { - mutable indent_stack: - (int * [`Indent | `Open of (char * (Lexing.position * Lexing.position)) ]) list; - mutable buffer: Concrete_parser.token list; - mutable string_buff: bytes; - mutable string_index: int; - mutable string_start_loc: Lexing.position * Lexing.position; - mutable comment_start_loc: (Lexing.position * Lexing.position) list; -} - -let init_state () = { - indent_stack = []; - buffer = []; - string_index = 0; - string_buff = Bytes.create 256; - string_start_loc = Lexing.dummy_pos, Lexing.dummy_pos; - comment_start_loc = []; -} - - -(** String helpers *) - -let reset_string_buffer st = - st.string_buff <- Bytes.create 256; - st.string_index <- 0 - -let store_string_char st c = - if st.string_index >= Bytes.length st.string_buff then begin - let new_buff = Bytes.create (Bytes.length (st.string_buff) * 2) in - Bytes.blit st.string_buff 0 new_buff 0 (Bytes.length st.string_buff); - st.string_buff <- new_buff - end; - Bytes.set st.string_buff st.string_index c; - st.string_index <- st.string_index + 1 - -let store_string st s = - for i = 0 to String.length s - 1 do - store_string_char st s.[i]; - done - -let store_lexeme st lexbuf = - store_string st (Lexing.lexeme lexbuf) - -let get_stored_string st = - let s = Bytes.sub st.string_buff 0 st.string_index in - st.string_buff <- Bytes.create 256; - Bytes.to_string s - - -(** Indentation helpers *) - -let first_token st = - match st.indent_stack with - | [] -> true - | _ :: _ -> false - -let starting_offset (start, _) = - let open Lexing in - start.pos_cnum - start.pos_bol - -let rec pop_indent st loc xs i = - match xs with - | [] -> assert false - | ((x, _) :: _) as xs when Compare.Int.(x = i) -> - st.indent_stack <- xs; - [NEWLINE] - | (x, `Indent) :: xs -> - if Compare.Int.(x > i) then - DEDENT :: pop_indent st loc xs i - else - raise @@ Invalid_indentation (pos2 loc) - | (_, `Open (c, opener_loc)) :: _ -> - let opener_offset = starting_offset opener_loc in - if Compare.Int.(i > opener_offset) then - raise @@ Invalid_indentation_in_block (pos2 loc, c, pos2 opener_loc) - else - raise @@ Unclosed (pos2 loc, c, pos2 opener_loc) - -let indent_token st loc = - let i = starting_offset loc in - match st.indent_stack with - | (x, `Indent) :: xs when Compare.Int.(x > i) -> - DEDENT :: pop_indent st loc xs i; - | (x, `Open (c, opener_loc)) :: _ when Compare.Int.(x > i) -> - let opener_offset = starting_offset opener_loc in - if Compare.Int.(i > opener_offset) then - raise @@ Invalid_indentation_in_block (pos2 loc, c, pos2 opener_loc) - else - raise @@ Unclosed (pos2 loc, c, pos2 opener_loc) - | (x, _) :: _ when Compare.Int.(x = i) -> - [NEWLINE] - | [] | (_, _) :: _ (* when Compare.Int.(x < i) *) -> - st.indent_stack <- (i, `Indent) :: st.indent_stack; - [INDENT] - -let open_block st opener opener_loc token_offset = - let opener_offset = starting_offset opener_loc in - if Compare.Int.(token_offset <= opener_offset) then - raise @@ Invalid_indentation_after_opener (pos2 opener_loc, opener) ; - st.indent_stack <- - (token_offset, `Open (opener, opener_loc)) :: st.indent_stack; - match opener with - | '{' -> [LBRACE] - | '(' -> [LPAREN] - | _ -> assert false - -let close_block st bol closer closer_loc = - let closer_offset = starting_offset closer_loc in - let rec pop xs = - match xs with - | [] -> raise @@ Unopened (pos2 closer_loc, closer) - | (_, `Indent) :: xs -> DEDENT :: pop xs - | (_, `Open (opener, opener_loc)) :: xs -> - let opener_offset = starting_offset opener_loc in - if bol && Compare.Int.(opener_offset <> closer_offset) then - raise @@ - Unaligned_closer (pos2 closer_loc, opener, closer, pos2 opener_loc) ; - st.indent_stack <- xs; - [ match opener, closer with - | '{', '}' -> RBRACE - | '(', ')' -> RPAREN - | _ -> - raise @@ Unclosed (pos2 closer_loc, opener, pos2 opener_loc) ] - in - pop st.indent_stack - -} - -let eol_comment = '#' [^ '\010'] * -let newline = eol_comment ? ('\010' | "\013\010" ) -let space = [' '] -let firstidentchar = ['A'-'Z' 'a'-'z' '_'] -let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] -let decimal_literal = - ['0'-'9'] ['0'-'9' '_']* -let hex_literal = - '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']* -let oct_literal = - '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* -let bin_literal = - '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* -let int_literal = - '-' ? ( decimal_literal | hex_literal | oct_literal | bin_literal) - -rule indent_tokens st nl = parse - -| space { indent_tokens st nl lexbuf } -| newline { Lexing.new_line lexbuf; indent_tokens st (nl + 1) lexbuf } - -| "" - { let bol = nl <> 0 || first_token st in - if bol then indent_token st (curr_location lexbuf) else [] } - -| "/*" - { st.comment_start_loc <- [curr_location lexbuf]; - comment st nl lexbuf } - -| ('{' | '(' as opener) - { let opener_loc = curr_location lexbuf in - let token_offset = next_token_indent st lexbuf in - let bol = nl <> 0 || first_token st in - let prefix = - if bol then indent_token st opener_loc else [] in - prefix @ open_block st opener opener_loc token_offset } - -| ('}' | ')' as closer) - { let closer_loc = curr_location lexbuf in - let bol = Compare.Int.(nl <> 0) in - close_block st bol closer closer_loc } - -| eof - { List.map - (function - | (_, `Indent) -> DEDENT - | (_, `Open (c, loc)) -> - raise @@ Unclosed (pos2 (curr_location lexbuf), c, pos2 loc)) - st.indent_stack - @ [EOF] - } - -and comment st nl = parse - -| "/*" { st.comment_start_loc <- - curr_location lexbuf :: st.comment_start_loc; - comment st nl lexbuf } - -| "*/" { match st.comment_start_loc with - | [] -> assert false - | [_] -> indent_tokens st nl lexbuf - | _ :: xs -> st.comment_start_loc <- xs; comment st nl lexbuf } - -| "\"" { st.string_start_loc <- curr_location lexbuf; - let nl = - try string st nl lexbuf - with Unterminated_string str_start -> - match st.comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev st.comment_start_loc) in - raise @@ - Unterminated_string_in_comment (pos2 loc, pos2 start, str_start) - in - comment st nl lexbuf } - -| newline { Lexing.new_line lexbuf; comment st (nl+1) lexbuf } - -| eof { match st.comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev st.comment_start_loc) in - raise @@ Unterminated_comment (pos2 loc, pos2 start) } - -| _ { comment st nl lexbuf } - - -(** Eat spacings and return the next token offset. *) -and next_token_indent st = parse - -| space { next_token_indent st lexbuf } - -| newline { Lexing.new_line lexbuf; next_token_indent st lexbuf } - -| "" { end_offset lexbuf } - -(** The lexer for non-indentation tokens. - It should not care about 'space', 'newline', '{}()' nor comments. *) -and raw_token st = parse - -| ";" { SEMICOLON } - -| firstidentchar identchar * - { PRIM (Lexing.lexeme lexbuf) } - -| int_literal - { INT (Lexing.lexeme lexbuf) } - -| "\"" - { reset_string_buffer st; - let string_start = lexbuf.Lexing.lex_start_p in - st.string_start_loc <- curr_location lexbuf; - ignore (string st 0 lexbuf); - lexbuf.Lexing.lex_start_p <- string_start; - STRING (get_stored_string st) } - -| _ - { raise (Illegal_character (pos2 (curr_location lexbuf), - Lexing.lexeme_char lexbuf 0)) - } - -and string st nl = parse - '"' - { nl } - | '\\' newline ([' ' '\t'] * as space) - { update_loc lexbuf 1 (String.length space); - string st nl lexbuf - } - | '\\' ['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] - { store_string_char st (char_for_backslash(Lexing.lexeme_char lexbuf 1)); - string st nl lexbuf } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] - { store_string_char st (char_for_decimal_code lexbuf 1); - string st nl lexbuf } - | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] - { store_string_char st (char_for_hexadecimal_code lexbuf 2); - string st nl lexbuf } - | newline - { match st.comment_start_loc with - | [] -> raise @@ Newline_in_string (pos2 (curr_location lexbuf)) - | _ -> Lexing.new_line lexbuf; string st (nl+1) lexbuf } - | eof - { raise @@ Unterminated_string (pos2 st.string_start_loc) } - | _ - { store_string_char st (Lexing.lexeme_char lexbuf 0); - string st nl lexbuf } - - -{ - - let rec token st lexbuf = - match st.buffer with - | tok :: tokens -> - st.buffer <- tokens; - tok - | [] -> - match indent_tokens st 0 lexbuf with - | [] -> raw_token st lexbuf - | _ :: _ as tokens -> st.buffer <- tokens; token st lexbuf - -} diff --git a/src/client/embedded/alpha/concrete_parser.mly b/src/client/embedded/alpha/concrete_parser.mly deleted file mode 100644 index bc77ea902..000000000 --- a/src/client/embedded/alpha/concrete_parser.mly +++ /dev/null @@ -1,280 +0,0 @@ - -%token DEDENT -%token EOF -%token INDENT -%token LBRACE -%token LPAREN -%token NEWLINE -%token RBRACE -%token RPAREN -%token SEMICOLON - -%token INT -%token PRIM -%token STRING - -%left PRIM INT LPAREN LBRACE STRING -%left apply - -%start tree - -%{ - -open Script_located_ir - -let expand_caddadr original = - match original with - | Prim (loc, str, []) -> - let len = String.length str in - if len > 3 - && String.get str 0 = 'C' - && String.get str (len - 1) = 'R' then - let rec parse i acc = - if i = 0 then - Some (Seq (loc, acc)) - else - match String.get str i with - | 'A' -> parse (i - 1) (Prim (loc, "CAR", []) :: acc) - | 'D' -> parse (i - 1) (Prim (loc, "CDR", []) :: acc) - | _ -> None in - parse (len - 2) [] - else - None - | _ -> None - -exception Not_a_roman - -let decimal_of_roman roman = - (* http://rosettacode.org/wiki/Roman_numerals/Decode#OCaml *) - let arabic = ref 0 in - let lastval = ref 0 in - for i = (String.length roman) - 1 downto 0 do - let n = - match roman.[i] with - | 'M' -> 1000 - | 'D' -> 500 - | 'C' -> 100 - | 'L' -> 50 - | 'X' -> 10 - | 'V' -> 5 - | 'I' -> 1 - | _ -> raise Not_a_roman - in - if Compare.Int.(n < !lastval) - then arabic := !arabic - n - else arabic := !arabic + n; - lastval := n - done; - !arabic - -let expand_dxiiivp original = - match original with - | Prim (loc, str, [ arg ]) -> - let len = String.length str in - if len > 3 - && String.get str 0 = 'D' - && String.get str (len - 1) = 'P' then - try - let depth = decimal_of_roman (String.sub str 1 (len - 2)) in - let rec make i acc = - if i = 0 then - acc - else - make (i - 1) - (Seq (loc, [ Prim (loc, "DIP", [ acc ]) ])) in - Some (make depth arg) - with Not_a_roman -> None - else None - | _ -> None - -exception Not_a_pair - -let expand_paaiair original = - match original with - | Prim (loc, str, []) -> - let len = String.length str in - if len > 4 - && String.get str 0 = 'P' - && String.get str (len - 1) = 'R' then - try - let rec parse i acc = - if i = 0 then - acc - else if String.get str i = 'I' - && String.get str (i - 1) = 'A' then - parse (i - 2) (Prim (loc, "PAIR", []) :: acc) - else if String.get str i = 'A' then - match acc with - | [] -> - raise Not_a_pair - | acc :: accs -> - parse (i - 1) (Prim (loc, "DIP", [ acc ]) :: accs) - else - raise Not_a_pair in - Some (Seq (loc, parse (len - 2) [])) - with Not_a_pair -> None - else - None - | _ -> None - -exception Not_a_dup - -let expand_duuuuup original = - match original with - | Prim (loc, str, []) -> - let len = String.length str in - if len > 3 - && String.get str 0 = 'D' - && String.get str 1 = 'U' - && String.get str (len - 1) = 'P' then - try - let rec parse i acc = - if i = 1 then acc - else if String.get str i = 'U' then - parse (i - 1) - (Seq (loc, [ Prim (loc, "DIP", [ acc ]) ; - Prim (loc, "SWAP", []) ])) - else - raise Not_a_dup in - Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", []) ]))) - with Not_a_dup -> None - else - None - | _ -> None - - -let expand_compare original = - match original with - | Prim (loc, "CMPEQ", []) -> - Some (Seq (loc, [ Prim (loc, "COMPARE", []) ; - Prim (loc, "EQ", []) ])) - | Prim (loc, "CMPNEQ", []) -> - Some (Seq (loc, [ Prim (loc, "COMPARE", []) ; - Prim (loc, "NEQ", []) ])) - | Prim (loc, "CMPLT", []) -> - Some (Seq (loc, [ Prim (loc, "COMPARE", []) ; - Prim (loc, "LT", []) ])) - | Prim (loc, "CMPGT", []) -> - Some (Seq (loc, [ Prim (loc, "COMPARE", []) ; - Prim (loc, "GT", []) ])) - | Prim (loc, "CMPLE", []) -> - Some (Seq (loc, [ Prim (loc, "COMPARE", []) ; - Prim (loc, "LE", []) ])) - | Prim (loc, "CMPGE", []) -> - Some (Seq (loc, [ Prim (loc, "COMPARE", []) ; - Prim (loc, "GE", []) ])) - | Prim (loc, "IFCMPEQ", args) -> - Some (Seq (loc, [ Prim (loc, "COMPARE", []) ; - Prim (loc, "EQ", []) ; - Prim (loc, "IF", args) ])) - | Prim (loc, "IFCMPNEQ", args) -> - Some (Seq (loc, [ Prim (loc, "COMPARE", []) ; - Prim (loc, "NEQ", []) ; - Prim (loc, "IF", args) ])) - | Prim (loc, "IFCMPLT", args) -> - Some (Seq (loc, [ Prim (loc, "COMPARE", []) ; - Prim (loc, "LT", []) ; - Prim (loc, "IF", args) ])) - | Prim (loc, "IFCMPGT", args) -> - Some (Seq (loc, [ Prim (loc, "COMPARE", []) ; - Prim (loc, "GT", []) ; - Prim (loc, "IF", args) ])) - | Prim (loc, "IFCMPLE", args) -> - Some (Seq (loc, [ Prim (loc, "COMPARE", []) ; - Prim (loc, "LE", []) ; - Prim (loc, "IF", args) ])) - | Prim (loc, "IFCMPGE", args) -> - Some (Seq (loc, [ Prim (loc, "COMPARE", []) ; - Prim (loc, "GE", []) ; - Prim (loc, "IF", args) ])) - | Prim (loc, "IFEQ", args) -> - Some (Seq (loc, [ Prim (loc, "EQ", []) ; - Prim (loc, "IF", args) ])) - | Prim (loc, "IFNEQ", args) -> - Some (Seq (loc, [ Prim (loc, "NEQ", []) ; - Prim (loc, "IF", args) ])) - | Prim (loc, "IFLT", args) -> - Some (Seq (loc, [ Prim (loc, "LT", []) ; - Prim (loc, "IF", args) ])) - | Prim (loc, "IFGT", args) -> - Some (Seq (loc, [ Prim (loc, "GT", []) ; - Prim (loc, "IF", args) ])) - | Prim (loc, "IFLE", args) -> - Some (Seq (loc, [ Prim (loc, "LE", []) ; - Prim (loc, "IF", args) ])) - | Prim (loc, "IFGE", args) -> - Some (Seq (loc, [ Prim (loc, "GE", []) ; - Prim (loc, "IF", args) ])) - | _ -> None - -let expand original = - let try_expansions expanders = - match - List.fold_left - (fun acc f -> - match acc with - | None -> f original - | Some rewritten -> Some rewritten) - None expanders with - | None -> original - | Some rewritten -> rewritten in - try_expansions - [ expand_dxiiivp ; - expand_paaiair ; - expand_caddadr ; - expand_duuuuup ; - expand_compare ] - -let loc = function - | Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _) -> loc - -let apply node arg = - match node with - | Prim ((sloc, _), n, args) -> - Prim ((sloc, snd (loc arg)), n, args @ [arg]) - | Int _ | String _ | Seq _ as _node -> - raise (Invalid_application (node_location arg)) - -let rec apply_seq node = function - | [] -> node - | n1 :: n2 -> apply_seq (apply node n1) n2 - -let pos p1 p2 = - ({ line = p1.Lexing.pos_lnum ; - column = p1.Lexing.pos_cnum - p1.Lexing.pos_bol ; - point = p1.Lexing.pos_cnum }, - { line = p2.Lexing.pos_lnum ; - column = p2.Lexing.pos_cnum - p2.Lexing.pos_bol ; - point = p2.Lexing.pos_cnum }) - -%} - -%% - -%public tree: -| node = nodes EOF { node } -| INDENT node = nodes DEDENT EOF { node } - -nodes: -| { [] } -| n1 = node { [n1] } -| n1 = node SEMICOLON n2 = nodes { n1 :: n2 } -| n1 = node SEMICOLON NEWLINE n2 = nodes { n1 :: n2 } -| n1 = node NEWLINE n2 = nodes { n1 :: n2 } - -node: -| node = line_node { expand node } -| line_node error - (* Un seul elt par bloc de '(' ... ')' (pas de NEWLINE ou de ';' *) - { raise (Sequence_in_parens (pos $startpos $endpos)) } -| node = line_node INDENT nodes = nodes DEDENT { expand (apply_seq node nodes) } - -line_node: -| n1 = line_node n2 = line_node %prec apply { apply n1 n2 } -| LPAREN node = node RPAREN { node } -| LBRACE nodes = nodes RBRACE { Seq (pos $startpos $endpos, nodes) } -| prim = PRIM { Prim (pos $startpos $endpos, prim, []) } -| i = INT { Int (pos $startpos $endpos, i) } -| s = STRING { String (pos $startpos $endpos, s) } - -%% diff --git a/src/client/embedded/alpha/michelson_macros.ml b/src/client/embedded/alpha/michelson_macros.ml new file mode 100644 index 000000000..b4daaf6b1 --- /dev/null +++ b/src/client/embedded/alpha/michelson_macros.ml @@ -0,0 +1,672 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Script_located_ir + +let expand_caddadr original = + match original with + | Prim (loc, str, [], annot) -> + let len = String.length str in + if len > 3 + && String.get str 0 = 'C' + && String.get str (len - 1) = 'R' then + let rec parse i ?annot acc = + if i = 0 then + Some (Seq (loc, acc, None)) + else + match String.get str i with + | 'A' -> parse (i - 1) (Prim (loc, "CAR", [], annot) :: acc) + | 'D' -> parse (i - 1) (Prim (loc, "CDR", [], annot) :: acc) + | _ -> None in + parse (len - 2) ?annot [] + else + None + | _ -> None + +let expand_set_caddadr original = + match original with + | Prim (loc, str, [], None) -> + let len = String.length str in + if len >= 7 + && String.sub str 0 5 = "SET_C" + && String.get str (len - 1) = 'R' then + let rec parse i acc = + if i = 4 then + Some acc + else + match String.get str i with + | 'A' -> + let acc = + Seq (loc, + [ Prim (loc, "DUP", [], None) ; + Prim (loc, "DIP", + [ Seq (loc, + [ Prim (loc, "CAR", [], None) ; + acc ], None) ], None) ; + Prim (loc, "CDR", [], None) ; + Prim (loc, "SWAP", [], None) ; + Prim (loc, "PAIR", [], None) ], None) in + parse (i - 1) acc + | 'D' -> + let acc = + Seq (loc, + [ Prim (loc, "DUP", [], None) ; + Prim (loc, "DIP", + [ Seq (loc, + [ Prim (loc, "CDR", [], None) ; + acc ], None) ], None) ; + Prim (loc, "CAR", [], None) ; + Prim (loc, "PAIR", [], None) ], None) in + parse (i - 1) acc + | _ -> None in + match String.get str (len - 2) with + | 'A' -> + let init = + Seq (loc, + [ Prim (loc, "CDR", [], None) ; + Prim (loc, "SWAP", [], None) ; + Prim (loc, "PAIR", [], None) ], None) in + parse (len - 3) init + | 'D' -> + let init = + Seq (loc, + [ Prim (loc, "CAR", [], None) ; + Prim (loc, "PAIR", [], None) ], None) in + parse (len - 3) init + | _ -> None + else + None + | _ -> None + +let expand_map_caddadr original = + match original with + | Prim (loc, str, [ Seq _ as code ], None) -> + let len = String.length str in + if len >= 7 + && String.sub str 0 5 = "MAP_C" + && String.get str (len - 1) = 'R' then + let rec parse i acc = + if i = 4 then + Some acc + else + match String.get str i with + | 'A' -> + let acc = + Seq (loc, + [ Prim (loc, "DUP", [], None) ; + Prim (loc, "DIP", + [ Seq (loc, + [ Prim (loc, "CAR", [], None) ; + acc ], None) ], None) ; + Prim (loc, "CDR", [], None) ; + Prim (loc, "SWAP", [], None) ; + Prim (loc, "PAIR", [], None) ], None) in + parse (i - 1) acc + | 'D' -> + let acc = + Seq (loc, + [ Prim (loc, "DUP", [], None) ; + Prim (loc, "DIP", + [ Seq (loc, + [ Prim (loc, "CDR", [], None) ; + acc ], None) ], None) ; + Prim (loc, "CAR", [], None) ; + Prim (loc, "PAIR", [], None) ], None) in + parse (i - 1) acc + | _ -> None in + match String.get str (len - 2) with + | 'A' -> + let init = + Seq (loc, + [ Prim (loc, "DUP", [], None) ; + Prim (loc, "CDR", [], None) ; + Prim (loc, "SWAP", [], None) ; + Prim (loc, "CAR", [], None) ; + code ; + Prim (loc, "PAIR", [], None) ], None) in + parse (len - 3) init + | 'D' -> + let init = + Seq (loc, + [ Prim (loc, "DUP", [], None) ; + Prim (loc, "CDR", [], None) ; + code ; + Prim (loc, "SWAP", [], None) ; + Prim (loc, "CAR", [], None) ; + Prim (loc, "PAIR", [], None) ], None) in + parse (len - 3) init + | _ -> None + else + None + | _ -> None + +exception Not_a_roman + +let decimal_of_roman roman = + (* http://rosettacode.org/wiki/Roman_numerals/Decode#OCaml *) + let arabic = ref 0 in + let lastval = ref 0 in + for i = (String.length roman) - 1 downto 0 do + let n = + match roman.[i] with + | 'M' -> 1000 + | 'D' -> 500 + | 'C' -> 100 + | 'L' -> 50 + | 'X' -> 10 + | 'V' -> 5 + | 'I' -> 1 + | _ -> raise Not_a_roman + in + if Compare.Int.(n < !lastval) + then arabic := !arabic - n + else arabic := !arabic + n; + lastval := n + done; + !arabic + +let expand_dxiiivp original = + match original with + | Prim (loc, str, [ arg ], None) -> + let len = String.length str in + if len > 3 + && String.get str 0 = 'D' + && String.get str (len - 1) = 'P' then + try + let depth = decimal_of_roman (String.sub str 1 (len - 2)) in + let rec make i acc = + if i = 0 then + acc + else + make (i - 1) + (Seq (loc, [ Prim (loc, "DIP", [ acc ], None) ], None)) in + Some (make depth arg) + with Not_a_roman -> None + else None + | _ -> None + +exception Not_a_pair + +let expand_paaiair original = + match original with + | Prim (loc, str, [], None) -> + let len = String.length str in + if len > 4 + && String.get str 0 = 'P' + && String.get str (len - 1) = 'R' then + try + let rec parse i acc = + if i = 0 then + acc + else if String.get str i = 'I' + && String.get str (i - 1) = 'A' then + parse (i - 2) (Prim (loc, "PAIR", [], None) :: acc) + else if String.get str i = 'A' then + match acc with + | [] -> + raise Not_a_pair + | acc :: accs -> + parse (i - 1) + (Prim (loc, "DIP", [ Seq (loc, [ acc ], None) ], None) + :: accs) + else + raise Not_a_pair in + Some (Seq (loc, parse (len - 2) [], None)) + with Not_a_pair -> None + else + None + | _ -> None + +let expand_unpaaiair original = + match original with + | Prim (loc, str, [], None) -> + let len = String.length str in + if len >= 6 + && String.sub str 0 3 = "UNP" + && String.get str (len - 1) = 'R' then + try + let rec parse i acc = + if i = 2 then + match acc with + | [ Seq _ as acc ] -> acc + | _ -> Seq (loc, List.rev acc, None) + else if String.get str i = 'I' + && String.get str (i - 1) = 'A' then + parse (i - 2) + (Seq (loc, [ Prim (loc, "DUP", [], None) ; + Prim (loc, "CAR", [], None) ; + Prim (loc, "DIP", + [ Seq (loc, + [ Prim (loc, "CDR", [], None) ], + None) ], None) ], None) + :: acc) + else if String.get str i = 'A' then + match acc with + | [] -> + raise Not_a_pair + | (Seq _ as acc) :: accs -> + parse (i - 1) + (Prim (loc, "DIP", [ acc ], None) :: accs) + | acc :: accs -> + parse (i - 1) + (Prim (loc, "DIP", + [ Seq (loc, [ acc ], None) ], + None) :: accs) + else + raise Not_a_pair in + Some (parse (len - 2) []) + with Not_a_pair -> None + else + None + | _ -> None + +exception Not_a_dup + +let expand_duuuuup original = + match original with + | Prim (loc, str, [], None) -> + let len = String.length str in + if len > 3 + && String.get str 0 = 'D' + && String.get str 1 = 'U' + && String.get str (len - 1) = 'P' then + try + let rec parse i acc = + if i = 1 then acc + else if String.get str i = 'U' then + parse (i - 1) + (Seq (loc, [ Prim (loc, "DIP", [ acc ], None) ; + Prim (loc, "SWAP", [], None) ], None)) + else + raise Not_a_dup in + Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", [], None) ], None))) + with Not_a_dup -> None + else + None + | _ -> None + +let expand_compare original = + match original with + | Prim (loc, "CMPEQ", [], None) -> + Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; + Prim (loc, "EQ", [], None) ], None)) + | Prim (loc, "CMPNEQ", [], None) -> + Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; + Prim (loc, "NEQ", [], None) ], None)) + | Prim (loc, "CMPLT", [], None) -> + Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; + Prim (loc, "LT", [], None) ], None)) + | Prim (loc, "CMPGT", [], None) -> + Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; + Prim (loc, "GT", [], None) ], None)) + | Prim (loc, "CMPLE", [], None) -> + Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; + Prim (loc, "LE", [], None) ], None)) + | Prim (loc, "CMPGE", [], None) -> + Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; + Prim (loc, "GE", [], None) ], None)) + | Prim (loc, "IFCMPEQ", args, None) -> + Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; + Prim (loc, "EQ", [], None) ; + Prim (loc, "IF", args, None) ], None)) + | Prim (loc, "IFCMPNEQ", args, None) -> + Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; + Prim (loc, "NEQ", [], None) ; + Prim (loc, "IF", args, None) ], None)) + | Prim (loc, "IFCMPLT", args, None) -> + Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; + Prim (loc, "LT", [], None) ; + Prim (loc, "IF", args, None) ], None)) + | Prim (loc, "IFCMPGT", args, None) -> + Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; + Prim (loc, "GT", [], None) ; + Prim (loc, "IF", args, None) ], None)) + | Prim (loc, "IFCMPLE", args, None) -> + Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; + Prim (loc, "LE", [], None) ; + Prim (loc, "IF", args, None) ], None)) + | Prim (loc, "IFCMPGE", args, None) -> + Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; + Prim (loc, "GE", [], None) ; + Prim (loc, "IF", args, None) ], None)) + | Prim (loc, "IFEQ", args, None) -> + Some (Seq (loc, [ Prim (loc, "EQ", [], None) ; + Prim (loc, "IF", args, None) ], None)) + | Prim (loc, "IFNEQ", args, None) -> + Some (Seq (loc, [ Prim (loc, "NEQ", [], None) ; + Prim (loc, "IF", args, None) ], None)) + | Prim (loc, "IFLT", args, None) -> + Some (Seq (loc, [ Prim (loc, "LT", [], None) ; + Prim (loc, "IF", args, None) ], None)) + | Prim (loc, "IFGT", args, None) -> + Some (Seq (loc, [ Prim (loc, "GT", [], None) ; + Prim (loc, "IF", args, None) ], None)) + | Prim (loc, "IFLE", args, None) -> + Some (Seq (loc, [ Prim (loc, "LE", [], None) ; + Prim (loc, "IF", args, None) ], None)) + | Prim (loc, "IFGE", args, None) -> + Some (Seq (loc, [ Prim (loc, "GE", [], None) ; + Prim (loc, "IF", args, None) ], None)) + | _ -> None + +let expand original = + let try_expansions expanders = + match + List.fold_left + (fun acc f -> + match acc with + | None -> f original + | Some rewritten -> Some rewritten) + None expanders with + | None -> original + | Some rewritten -> rewritten in + try_expansions + [ expand_caddadr ; + expand_set_caddadr ; + expand_map_caddadr ; + expand_dxiiivp ; + expand_paaiair ; + expand_unpaaiair ; + expand_duuuuup ; + expand_compare ] + +open Script + +let unexpand_caddadr expanded = + let rec rsteps acc = function + | [] -> Some acc + | Prim (_, "CAR" , [], None) :: rest -> + rsteps ("A" :: acc) rest + | Prim (_, "CDR" , [], None) :: rest -> + rsteps ("D" :: acc) rest + | _ -> None in + match expanded with + | Seq (loc, (Prim (_, "CAR" , [], None) :: _ as nodes), None) + | Seq (loc, (Prim (_, "CDR" , [], None) :: _ as nodes), None) -> + begin match rsteps [] nodes with + | Some steps -> + let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in + Some (Prim (loc, name, [], None)) + | None -> None + end + | _ -> None + +let unexpand_set_caddadr expanded = + let rec steps acc = function + | Seq (loc, + [ Prim (_, "CDR", [], None) ; + Prim (_, "SWAP", [], None) ; + Prim (_, "PAIR", [], None) ], None) -> + Some (loc, "A" :: acc) + | Seq (loc, + [ Prim (_, "CAR", [], None) ; + Prim (_, "PAIR", [], None) ], None) -> + Some (loc, "D" :: acc) + | Seq (_, + [ Prim (_, "DUP", [], None) ; + Prim (_, "DIP", + [ Seq (_, + [ Prim (_, "CAR", [], None) ; + sub ], None) ], None) ; + Prim (_, "CDR", [], None) ; + Prim (_, "SWAP", [], None) ; + Prim (_, "PAIR", [], None) ], None) -> + steps ("A" :: acc) sub + | Seq (_, + [ Prim (_, "DUP", [], None) ; + Prim (_, "DIP", + [ Seq (_, + [ Prim (_, "CDR", [], None) ; + sub ], None) ], None) ; + Prim (_, "CAR", [], None) ; + Prim (_, "PAIR", [], None) ], None) -> + steps ("D" :: acc) sub + | _ -> None in + match steps [] expanded with + | Some (loc, steps) -> + let name = String.concat "" ("SET_C" :: List.rev ("R" :: steps)) in + Some (Prim (loc, name, [], None)) + | None -> None + +let unexpand_map_caddadr expanded = + let rec steps acc = function + | Seq (loc, + [ Prim (_, "DUP", [], None) ; + Prim (_, "CDR", [], None) ; + Prim (_, "SWAP", [], None) ; + Prim (_, "CAR", [], None) ; + code ; + Prim (_, "PAIR", [], None) ], None) -> + Some (loc, "A" :: acc, code) + | Seq (loc, + [ Prim (_, "DUP", [], None) ; + Prim (_, "CDR", [], None) ; + code ; + Prim (_, "SWAP", [], None) ; + Prim (_, "CAR", [], None) ; + Prim (_, "PAIR", [], None) ], None) -> + Some (loc, "D" :: acc, code) + | Seq (_, + [ Prim (_, "DUP", [], None) ; + Prim (_, "DIP", + [ Seq (_, + [ Prim (_, "CAR", [], None) ; + sub ], None) ], None) ; + Prim (_, "CDR", [], None) ; + Prim (_, "SWAP", [], None) ; + Prim (_, "PAIR", [], None) ], None) -> + steps ("A" :: acc) sub + | Seq (_, + [ Prim (_, "DUP", [], None) ; + Prim (_, "DIP", + [ Seq (_, + [ Prim (_, "CDR", [], None) ; + sub ], None) ], None) ; + Prim (_, "CAR", [], None) ; + Prim (_, "PAIR", [], None) ], None) -> + steps ("D" :: acc) sub + | _ -> None in + match steps [] expanded with + | Some (loc, steps, code) -> + let name = String.concat "" ("MAP_C" :: List.rev ("R" :: steps)) in + Some (Prim (loc, name, [ code ], None)) + | None -> None + +let roman_of_decimal decimal = + (* http://rosettacode.org/wiki/Roman_numerals/Encode#OCaml *) + let digit x y z = function + | 1 -> [ x ] + | 2 -> [ x ; x ] + | 3 -> [ x ; x ; x ] + | 4 -> [ x ; y ] + | 5 -> [ y ] + | 6 -> [ y ; x ] + | 7 -> [ y ; x ; x ] + | 8 -> [ y ; x ; x ; x ] + | 9 -> [ x ; z ] + | _ -> assert false in + let rec to_roman x = + if x = 0 then [] + else if x < 0 then + invalid_arg "Negative roman numeral" + else if x >= 1000 then + "M" :: to_roman (x - 1000) + else if x >= 100 then + digit "C" "D" "M" (x / 100) @ to_roman (x mod 100) + else if x >= 10 then + digit "X" "L" "C" (x / 10) @ to_roman (x mod 10) + else + digit "I" "V" "X" x in + String.concat "" (to_roman decimal) + +let unexpand_dxiiivp expanded = + match expanded with + | Seq (loc, + [ Prim (_, "DIP", + [ Seq (_, [ Prim (_, "DIP", [ _ ], None) ], None) as sub ], + None) ], + None) -> + let rec count acc = function + | Seq (_, [ Prim (_, "DIP", [ sub ], None) ], None) -> count (acc + 1) sub + | sub -> (acc, sub) in + let depth, sub = count 1 sub in + let name = "D" ^ roman_of_decimal depth ^ "P" in + Some (Prim (loc, name, [ sub ], None)) + | _ -> None + +let unexpand_duuuuup expanded = + let is_duuuuup_prim_name str = + let len = String.length str in + len >= 3 + && String.get str 0 = 'D' + && String.get str (len - 1) = 'P' + && begin + let all_u = ref true in + for i = 1 to len - 2 do + all_u := !all_u && String.get str i = 'U' + done ; + !all_u + end in + match expanded with + | Seq (loc, + [ Prim (_, "DIP", + [ Prim (_, sub, [], None) ], None) ; + Prim (_, "SWAP", [], None) ], None) + when is_duuuuup_prim_name sub -> + let name = "DU" ^ String.sub sub 1 (String.length sub - 1) in + Some (Prim (loc, name, [], None)) + | _ -> None + +let unexpand_paaiair expanded = + match expanded with + | Seq (_, [ Prim (_, "PAIR", [], None) ], None) -> Some expanded + | Seq (loc, (_ :: _ as nodes), None) -> + let rec destruct acc = function + | [] -> Some acc + | Prim (_, "DIP", [ Seq (_, [ sub ], None) ], None) :: rest -> + destruct ("A" :: acc) (sub :: rest) + | Prim (_, "PAIR", [], None) :: rest -> + destruct ("AI" :: acc) rest + | _ -> None in + begin match destruct [] nodes with + | None -> None + | Some seq -> + let name = String.concat "" ("P" :: List.rev ("R" :: seq)) in + Some (Prim (loc, name, [], None)) + end + | _ -> None + +let unexpand_unpaaiair expanded = + match expanded with + | Seq (loc, (_ :: _ as nodes), None) -> + let rec destruct sacc acc = function + | [] -> Some acc + | Prim (_, "DIP", [ Seq (_, [ sub ], None) ], None) :: rest + | Prim (_, "DIP", [ Seq (_, _, _) as sub ], None) :: rest -> + destruct ("A" :: sacc) acc (sub :: rest) + | Seq (_, [ Prim (_, "DUP", [], None) ; + Prim (_, "CAR", [], None) ; + Prim (_, "DIP", + [ Seq (_, + [ Prim (_, "CDR", [], None) ], None) ], + None) ], None) :: rest -> + destruct [] (List.rev ("AI" :: sacc) :: acc) rest + | _ -> None in + begin match destruct [] [ [ "R" ] ] nodes with + | None -> None + | Some seq -> + let name = String.concat "" ("UNP" :: List.flatten seq) in + Some (Prim (loc, name, [], None)) + end + | _ -> None + +let unexpand_compare expanded = + match expanded with + | Seq (loc, [ Prim (_, "COMPARE", [], None) ; + Prim (_, "EQ", [], None) ], None) -> + Some (Prim (loc, "CMPEQ", [], None)) + | Seq (loc, [ Prim (_, "COMPARE", [], None) ; + Prim (_, "NEQ", [], None) ], None) -> + Some (Prim (loc, "CMPNEQ", [], None)) + | Seq (loc, [ Prim (_, "COMPARE", [], None) ; + Prim (_, "LT", [], None) ], None) -> + Some (Prim (loc, "CMPLT", [], None)) + | Seq (loc, [ Prim (_, "COMPARE", [], None) ; + Prim (_, "GT", [], None) ], None) -> + Some (Prim (loc, "CMPGT", [], None)) + | Seq (loc, [ Prim (_, "COMPARE", [], None) ; + Prim (_, "LE", [], None) ], None) -> + Some (Prim (loc, "CMPLE", [], None)) + | Seq (loc, [ Prim (_, "COMPARE", [], None) ; + Prim (_, "GE", [], None) ], None) -> + Some (Prim (loc, "CMPGE", [], None)) + | Seq (loc, [ Prim (_, "COMPARE", [], None) ; + Prim (_, "EQ", [], None) ; + Prim (_, "IF", args, None) ], None) -> + Some (Prim (loc, "IFCMPEQ", args, None)) + | Seq (loc, [ Prim (_, "COMPARE", [], None) ; + Prim (_, "NEQ", [], None) ; + Prim (_, "IF", args, None) ], None) -> + Some (Prim (loc, "IFCMPNEQ", args, None)) + | Seq (loc, [ Prim (_, "COMPARE", [], None) ; + Prim (_, "LT", [], None) ; + Prim (_, "IF", args, None) ], None) -> + Some (Prim (loc, "IFCMPLT", args, None)) + | Seq (loc, [ Prim (_, "COMPARE", [], None) ; + Prim (_, "GT", [], None) ; + Prim (_, "IF", args, None) ], None) -> + Some (Prim (loc, "IFCMPGT", args, None)) + | Seq (loc, [ Prim (_, "COMPARE", [], None) ; + Prim (_, "LE", [], None) ; + Prim (_, "IF", args, None) ], None) -> + Some (Prim (loc, "IFCMPLE", args, None)) + | Seq (loc, [ Prim (_, "COMPARE", [], None) ; + Prim (_, "GE", [], None) ; + Prim (_, "IF", args, None) ], None) -> + Some (Prim (loc, "IFCMPGE", args, None)) + | Seq (loc, [ Prim (_, "EQ", [], None) ; + Prim (_, "IF", args, None) ], None) -> + Some (Prim (loc, "IFEQ", args, None)) + | Seq (loc, [ Prim (_, "NEQ", [], None) ; + Prim (_, "IF", args, None) ], None) -> + Some (Prim (loc, "IFNEQ", args, None)) + | Seq (loc, [ Prim (_, "LT", [], None) ; + Prim (_, "IF", args, None) ], None) -> + Some (Prim (loc, "IFLT", args, None)) + | Seq (loc, [ Prim (_, "GT", [], None) ; + Prim (_, "IF", args, None) ], None) -> + Some (Prim (loc, "IFGT", args, None)) + | Seq (loc, [ Prim (_, "LE", [], None) ; + Prim (_, "IF", args, None) ], None) -> + Some (Prim (loc, "IFLE", args, None)) + | Seq (loc, [ Prim (_, "GE", [], None) ; + Prim (_, "IF", args, None) ], None) -> + Some (Prim (loc, "IFGE", args, None)) + | _ -> None + +let unexpand original = + let try_expansions unexpanders = + match + List.fold_left + (fun acc f -> + match acc with + | None -> f original + | Some rewritten -> Some rewritten) + None unexpanders with + | None -> original + | Some rewritten -> rewritten in + try_expansions + [ unexpand_caddadr ; + unexpand_set_caddadr ; + unexpand_map_caddadr ; + unexpand_dxiiivp ; + unexpand_paaiair ; + unexpand_unpaaiair ; + unexpand_duuuuup ; + unexpand_compare ] diff --git a/src/client/embedded/alpha/michelson_macros.mli b/src/client/embedded/alpha/michelson_macros.mli new file mode 100644 index 000000000..fc5eeffea --- /dev/null +++ b/src/client/embedded/alpha/michelson_macros.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Script_located_ir + +val expand : node -> node + +val expand_caddadr : node -> node option +val expand_set_caddadr : node -> node option +val expand_map_caddadr : node -> node option +val expand_dxiiivp : node -> node option +val expand_paaiair : node -> node option +val expand_duuuuup : node -> node option +val expand_compare : node -> node option +val expand_unpaaiair : node -> node option + +open Script + +val unexpand : expr -> expr + +val unexpand_caddadr : expr -> expr option +val unexpand_set_caddadr : expr -> expr option +val unexpand_map_caddadr : expr -> expr option +val unexpand_dxiiivp : expr -> expr option +val unexpand_paaiair : expr -> expr option +val unexpand_duuuuup : expr -> expr option +val unexpand_compare : expr -> expr option +val unexpand_unpaaiair : expr -> expr option diff --git a/src/client/embedded/alpha/michelson_parser.ml b/src/client/embedded/alpha/michelson_parser.ml new file mode 100644 index 000000000..a38831391 --- /dev/null +++ b/src/client/embedded/alpha/michelson_parser.ml @@ -0,0 +1,521 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 [] ] diff --git a/src/client/embedded/alpha/michelson_parser.mli b/src/client/embedded/alpha/michelson_parser.mli new file mode 100644 index 000000000..5b972aa20 --- /dev/null +++ b/src/client/embedded/alpha/michelson_parser.mli @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 diff --git a/src/client/embedded/alpha/script_located_ir.ml b/src/client/embedded/alpha/script_located_ir.ml index d465addcd..f2f70710f 100644 --- a/src/client/embedded/alpha/script_located_ir.ml +++ b/src/client/embedded/alpha/script_located_ir.ml @@ -8,64 +8,53 @@ (**************************************************************************) type point = - { line : int ; - column : int ; - point : int } + { point : int ; + byte : int ; + line : int ; + column : int } + +let point_zero = + { point = 0 ; + byte = 0 ; + line = 0 ; + column = 0 } type location = - point * point + { start : point ; + stop : point } let location_encoding = let open Data_encoding in let point_encoding = conv - (fun { line ; column ; point } -> (line, column, point)) - (fun (line, column, point) -> { line ; column ; point }) - (obj3 + (fun { line ; column ; point ; byte } -> (line, column, point, byte)) + (fun (line, column, point, byte) -> { line ; column ; point ; byte }) + (obj4 (req "line" uint16) (req "column" uint16) - (req "point" uint16)) in - obj2 - (req "start" point_encoding) - (req "stop" point_encoding) + (req "point" uint16) + (req "byte" uint16)) in + conv + (fun { start ; stop } -> (start, stop)) + (fun (start, stop) -> { start ; stop }) + (obj2 + (req "start" point_encoding) + (req "stop" point_encoding)) type node = | Int of location * string | String of location * string - | Prim of location * string * node list - | Seq of location * node list + | Prim of location * string * node list * string option + | Seq of location * node list * string option let node_location = function | Int (loc, _) | String (loc, _) - | Prim (loc, _, _) - | Seq (loc, _) -> loc - -(*-- Located errors ---------------------------------------------------------*) - -(* Lexer error *) -exception Illegal_character of location * char -exception Illegal_escape of location * string -exception Invalid_indentation of location -exception Invalid_indentation_after_opener of location * char -exception Invalid_indentation_in_block of location * char * location -exception Newline_in_string of location -exception Unaligned_closer of location * char * char * location -exception Unclosed of location * char * location -exception Unopened of location * char -exception Unterminated_comment of location * location -exception Unterminated_string of location -exception Unterminated_string_in_comment of location * location * location - -(* Parser error *) -exception Invalid_application of location -exception Sequence_in_parens of location -exception Missing_program_field of string - -(*-- Converters between IR and Located IR -----------------------------------*) + | Prim (loc, _, _, _) + | Seq (loc, _, _) -> loc let strip_locations root = - let id = let id = ref 0 in fun () -> incr id ; !id in + let id = let id = ref (-1) in fun () -> incr id ; !id in let loc_table = ref [] in let rec strip_locations l = let id = id () in @@ -76,11 +65,13 @@ let strip_locations root = | String (loc, v) -> loc_table := (id, loc) :: !loc_table ; Script.String (id, v) - | Seq (loc, seq) -> + | Seq (loc, seq, annot) -> loc_table := (id, loc) :: !loc_table ; - Script.Seq (id, List.map strip_locations seq) - | Prim (loc, name, seq) -> + Script.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) in + Script.Prim (id, name, List.map strip_locations seq, annot) in let stripped = strip_locations root in stripped, List.rev !loc_table + +exception Missing_program_field of string diff --git a/src/proto/alpha/apply.ml b/src/proto/alpha/apply.ml index 6fb4bcee1..c7a638482 100644 --- a/src/proto/alpha/apply.ml +++ b/src/proto/alpha/apply.ml @@ -91,7 +91,7 @@ let apply_manager_operation_content Contract.get_script ctxt destination >>=? function | None -> begin match parameters with - | None | Some (Prim (_, "Unit", [])) -> + | None | Some (Prim (_, "Unit", [], _)) -> return (ctxt, origination_nonce, None) | Some _ -> fail (Bad_contract_parameter (destination, None, parameters)) end @@ -112,7 +112,7 @@ let apply_manager_operation_content | Error err -> return (ctxt, origination_nonce, Some err) in match parameters, code.arg_type with - | None, Prim (_, "unit", _) -> call_contract (Prim (0, "Unit", [])) + | None, Prim (_, "unit", _, _) -> call_contract (Prim (0, "Unit", [], None)) | Some parameters, arg_type -> begin Script_ir_translator.typecheck_data ctxt (parameters, arg_type) >>= function | Ok () -> call_contract parameters diff --git a/src/proto/alpha/script_ir_translator.ml b/src/proto/alpha/script_ir_translator.ml index 278197b07..97841cb75 100644 --- a/src/proto/alpha/script_ir_translator.ml +++ b/src/proto/alpha/script_ir_translator.ml @@ -54,10 +54,10 @@ type error += Duplicate_set_values of Script.location * Script.expr (* ---- Error helpers -------------------------------------------------------*) let location = function - | Prim (loc, _, _) + | Prim (loc, _, _, _) | Int (loc, _) | String (loc, _) - | Seq (loc, _) -> loc + | Seq (loc, _, _) -> loc let kind = function | Int _ -> Int_kind @@ -90,8 +90,8 @@ let unexpected expr exp_kinds exp_ns exp_prims = match expr with | Int (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind) | String (loc, _ ) -> Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind) - | Seq (loc, _ ) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind) - | Prim (loc, name, _) -> + | Seq (loc, _, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind) + | Prim (loc, name, _, _) -> match namespace name, exp_ns with | None, _ -> Invalid_case (loc, name) @@ -241,60 +241,60 @@ let ty_of_comparable_ty let unparse_comparable_ty : type a. a comparable_ty -> Script.expr = function - | Nat_key -> Prim (-1, "nat", []) - | Int_key -> Prim (-1, "int", []) - | String_key -> Prim (-1, "string", []) - | Tez_key -> Prim (-1, "tez", []) - | Bool_key -> Prim (-1, "bool", []) - | Key_key -> Prim (-1, "key", []) - | Timestamp_key -> Prim (-1, "timestamp", []) + | Int_key -> Prim (-1, "int", [], None) + | Nat_key -> Prim (-1, "nat", [], None) + | String_key -> Prim (-1, "string", [], None) + | Tez_key -> Prim (-1, "tez", [], None) + | Bool_key -> Prim (-1, "bool", [], None) + | Key_key -> Prim (-1, "key", [], None) + | Timestamp_key -> Prim (-1, "timestamp", [], None) let rec unparse_ty : type a. a ty -> Script.expr = function - | Unit_t -> Prim (-1, "unit", []) - | Nat_t -> Prim (-1, "nat", []) - | Int_t -> Prim (-1, "int", []) - | String_t -> Prim (-1, "string", []) - | Tez_t -> Prim (-1, "tez", []) - | Bool_t -> Prim (-1, "bool", []) - | Key_t -> Prim (-1, "key", []) - | Timestamp_t -> Prim (-1, "timestamp", []) - | Signature_t -> Prim (-1, "signature", []) + | Unit_t -> Prim (-1, "unit", [], None) + | Int_t -> Prim (-1, "int", [], None) + | Nat_t -> Prim (-1, "nat", [], None) + | String_t -> Prim (-1, "string", [], None) + | Tez_t -> Prim (-1, "tez", [], None) + | Bool_t -> Prim (-1, "bool", [], None) + | Key_t -> Prim (-1, "key", [], None) + | Timestamp_t -> Prim (-1, "timestamp", [], None) + | Signature_t -> Prim (-1, "signature", [], None) | Contract_t (utl, utr) -> let tl = unparse_ty utl in let tr = unparse_ty utr in - Prim (-1, "contract", [ tl; tr ]) + Prim (-1, "contract", [ tl; tr ], None) | Pair_t (utl, utr) -> let tl = unparse_ty utl in let tr = unparse_ty utr in - Prim (-1, "pair", [ tl; tr ]) + Prim (-1, "pair", [ tl; tr ], None) | Union_t (utl, utr) -> let tl = unparse_ty utl in let tr = unparse_ty utr in - Prim (-1, "or", [ tl; tr ]) + Prim (-1, "or", [ tl; tr ], None) | Lambda_t (uta, utr) -> let ta = unparse_ty uta in let tr = unparse_ty utr in - Prim (-1, "lambda", [ ta; tr ]) + Prim (-1, "lambda", [ ta; tr ], None) | Option_t ut -> let t = unparse_ty ut in - Prim (-1, "option", [ t ]) + Prim (-1, "option", [ t ], None) | List_t ut -> let t = unparse_ty ut in - Prim (-1, "list", [ t ]) + Prim (-1, "list", [ t ], None) | Set_t ut -> let t = unparse_comparable_ty ut in - Prim (-1, "set", [ t ]) + Prim (-1, "set", [ t ], None) | Map_t (uta, utr) -> let ta = unparse_comparable_ty uta in let tr = unparse_ty utr in - Prim (-1, "map", [ ta; tr ]) + Prim (-1, "map", [ ta; tr ], None) let rec unparse_data : type a. a ty -> a -> Script.expr = fun ty a -> match ty, a with | Unit_t, () -> - Prim (-1, "Unit", []) + Prim (-1, "Unit", [], None) | Int_t, v -> Int (-1, Script_int.to_string v) | Nat_t, v -> @@ -302,9 +302,9 @@ let rec unparse_data | String_t, s -> String (-1, s) | Bool_t, true -> - Prim (-1, "True", []) + Prim (-1, "True", [], None) | Bool_t, false -> - Prim (-1, "False", []) + Prim (-1, "False", [], None) | Timestamp_t, t -> String (-1, Timestamp.to_notation t) | Contract_t _, (_, _, c) -> @@ -321,21 +321,21 @@ let rec unparse_data | Pair_t (tl, tr), (l, r) -> let l = unparse_data tl l in let r = unparse_data tr r in - Prim (-1, "Pair", [ l; r ]) + Prim (-1, "Pair", [ l; r ], None) | Union_t (tl, _), L l -> let l = unparse_data tl l in - Prim (-1, "Left", [ l ]) + Prim (-1, "Left", [ l ], None) | Union_t (_, tr), R r -> let r = unparse_data tr r in - Prim (-1, "Right", [ r ]) + Prim (-1, "Right", [ r ], None) | Option_t t, Some v -> let v = unparse_data t v in - Prim (-1, "Some", [ v ]) + Prim (-1, "Some", [ v ], None) | Option_t _, None -> - Prim (-1, "None", []) + Prim (-1, "None", [], None) | List_t t, items -> let items = List.map (unparse_data t) items in - Prim (-1, "List", items) + Prim (-1, "List", items, None) | Set_t t, set -> let t = ty_of_comparable_ty t in let items = @@ -343,17 +343,18 @@ let rec unparse_data (fun item acc -> unparse_data t item :: acc ) set [] in - Prim (-1, "Set", List.rev items) + Prim (-1, "Set", List.rev items, None) | Map_t (kt, vt), map -> let kt = ty_of_comparable_ty kt in let items = map_fold (fun k v acc -> Prim (-1, "Item", [ unparse_data kt k; - unparse_data vt v ]) + unparse_data vt v ], + None) :: acc) map [] in - Prim (-1, "Map", List.rev items) + Prim (-1, "Map", List.rev items, None) | Lambda_t _, Lam (_, original_code) -> original_code @@ -480,20 +481,20 @@ type ex_ty = Ex_ty : 'a ty -> ex_ty type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty let rec parse_comparable_ty : Script.expr -> ex_comparable_ty tzresult = function - | Prim (_, "int", []) -> ok (Ex_comparable_ty Int_key) - | Prim (_, "nat", []) -> ok (Ex_comparable_ty Nat_key) - | Prim (_, "string", []) -> ok (Ex_comparable_ty String_key) - | Prim (_, "tez", []) -> ok (Ex_comparable_ty Tez_key) - | Prim (_, "bool", []) -> ok (Ex_comparable_ty Bool_key) - | Prim (_, "key", []) -> ok (Ex_comparable_ty Key_key) - | Prim (_, "timestamp", []) -> ok (Ex_comparable_ty Timestamp_key) + | Prim (_, "int", [], _) -> ok (Ex_comparable_ty Int_key) + | Prim (_, "nat", [], _) -> ok (Ex_comparable_ty Nat_key) + | Prim (_, "string", [], _) -> ok (Ex_comparable_ty String_key) + | Prim (_, "tez", [], _) -> ok (Ex_comparable_ty Tez_key) + | Prim (_, "bool", [], _) -> ok (Ex_comparable_ty Bool_key) + | Prim (_, "key", [], _) -> ok (Ex_comparable_ty Key_key) + | Prim (_, "timestamp", [], _) -> ok (Ex_comparable_ty Timestamp_key) | Prim (loc, ("int" | "nat" | "string" | "tez" | "bool" - | "key" | "timestamp" as prim), l) -> + | "key" | "timestamp" as prim), l, _) -> error (Invalid_arity (loc, prim, 0, List.length l)) | Prim (loc, ("pair" | "or" | "set" | "map" | "list" | "option" | "lambda" - | "unit" | "signature" | "contract"), _) as expr -> + | "unit" | "signature" | "contract"), _, _) as expr -> parse_ty expr >>? fun (Ex_ty ty) -> error (Comparable_type_expected (loc, ty)) | expr -> @@ -503,41 +504,41 @@ let rec parse_comparable_ty : Script.expr -> ex_comparable_ty tzresult = functio "key" ; "timestamp" ] and parse_ty : Script.expr -> ex_ty tzresult = function - | Prim (_, "unit", []) -> ok (Ex_ty Unit_t) - | Prim (_, "int", []) -> ok (Ex_ty Int_t) - | Prim (_, "nat", []) -> ok (Ex_ty Nat_t) - | Prim (_, "string", []) -> ok (Ex_ty String_t) - | Prim (_, "tez", []) -> ok (Ex_ty Tez_t) - | Prim (_, "bool", []) -> ok (Ex_ty Bool_t) - | Prim (_, "key", []) -> ok (Ex_ty Key_t) - | Prim (_, "timestamp", []) -> ok (Ex_ty Timestamp_t) - | Prim (_, "signature", []) -> ok (Ex_ty Signature_t) - | Prim (_, "contract", [ utl; utr ]) -> + | Prim (_, "unit", [], _) -> ok (Ex_ty Unit_t) + | Prim (_, "int", [], _) -> ok (Ex_ty (Int_t)) + | Prim (_, "nat", [], _) -> ok (Ex_ty (Nat_t)) + | Prim (_, "string", [], _) -> ok (Ex_ty String_t) + | Prim (_, "tez", [], _) -> ok (Ex_ty Tez_t) + | Prim (_, "bool", [], _) -> ok (Ex_ty Bool_t) + | Prim (_, "key", [], _) -> ok (Ex_ty Key_t) + | Prim (_, "timestamp", [], _) -> ok (Ex_ty Timestamp_t) + | Prim (_, "signature", [], _) -> ok (Ex_ty Signature_t) + | Prim (_, "contract", [ utl; utr ], _) -> parse_ty utl >>? fun (Ex_ty tl) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Contract_t (tl, tr))) - | Prim (_, "pair", [ utl; utr ]) -> + | Prim (_, "pair", [ utl; utr ], _) -> parse_ty utl >>? fun (Ex_ty tl) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Pair_t (tl, tr))) - | Prim (_, "or", [ utl; utr ]) -> + | Prim (_, "or", [ utl; utr ], _) -> parse_ty utl >>? fun (Ex_ty tl) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Union_t (tl, tr))) - | Prim (_, "lambda", [ uta; utr ]) -> + | Prim (_, "lambda", [ uta; utr ], _) -> parse_ty uta >>? fun (Ex_ty ta) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Lambda_t (ta, tr))) - | Prim (_, "option", [ ut ]) -> + | Prim (_, "option", [ ut ], _) -> parse_ty ut >>? fun (Ex_ty t) -> ok (Ex_ty (Option_t t)) - | Prim (_, "list", [ ut ]) -> + | Prim (_, "list", [ ut ], _) -> parse_ty ut >>? fun (Ex_ty t) -> ok (Ex_ty (List_t t)) - | Prim (_, "set", [ ut ]) -> + | Prim (_, "set", [ ut ], _) -> parse_comparable_ty ut >>? fun (Ex_comparable_ty t) -> ok (Ex_ty (Set_t t)) - | Prim (_, "map", [ uta; utr ]) -> + | Prim (_, "map", [ uta; utr ], _) -> parse_comparable_ty uta >>? fun (Ex_comparable_ty ta) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Map_t (ta, tr))) @@ -546,7 +547,7 @@ and parse_ty : Script.expr -> ex_ty tzresult = function | "unit" | "signature" | "contract" | "int" | "nat" | "string" | "tez" | "bool" - | "key" | "timestamp" as prim), l) -> + | "key" | "timestamp" as prim), l, _) -> error (Invalid_arity (loc, prim, 0, List.length l)) | expr -> error @@ unexpected expr [] Type_namespace @@ -586,15 +587,15 @@ let rec parse_data trace (error ()) body in match ty, script_data with (* Unit *) - | Unit_t, Prim (_, "Unit", []) -> return () - | Unit_t, Prim (loc, "Unit", l) -> + | Unit_t, Prim (_, "Unit", [], _) -> return () + | Unit_t, Prim (loc, "Unit", l, _) -> traced (fail (Invalid_arity (loc, "Unit", 0, List.length l))) | Unit_t, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Unit" ])) (* Booleans *) - | Bool_t, Prim (_, "True", []) -> return true - | Bool_t, Prim (_, "False", []) -> return false - | Bool_t, Prim (loc, ("True" | "False" as c), l) -> + | Bool_t, Prim (_, "True", [], _) -> return true + | Bool_t, Prim (_, "False", [], _) -> return false + | Bool_t, Prim (loc, ("True" | "False" as c), l, _) -> traced (fail (Invalid_arity (loc, c, 0, List.length l))) | Bool_t, expr -> traced (fail (unexpected expr [] Constant_namespace [ "True" ; "False" ])) @@ -672,27 +673,27 @@ let rec parse_data | Contract_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Pairs *) - | Pair_t (ta, tb), Prim (_, "Pair", [ va; vb ]) -> + | Pair_t (ta, tb), Prim (_, "Pair", [ va; vb ], _) -> traced @@ parse_data ?type_logger ctxt ta va >>=? fun va -> parse_data ?type_logger ctxt tb vb >>=? fun vb -> return (va, vb) - | Pair_t _, Prim (loc, "Pair", l) -> + | Pair_t _, Prim (loc, "Pair", l, _) -> fail @@ Invalid_arity (loc, "Pair", 2, List.length l) | Pair_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Pair" ])) (* Unions *) - | Union_t (tl, _), Prim (_, "Left", [ v ]) -> + | Union_t (tl, _), Prim (_, "Left", [ v ], _) -> traced @@ parse_data ?type_logger ctxt tl v >>=? fun v -> return (L v) - | Union_t _, Prim (loc, "Left", l) -> + | Union_t _, Prim (loc, "Left", l, _) -> fail @@ Invalid_arity (loc, "Left", 1, List.length l) - | Union_t (_, tr), Prim (_, "Right", [ v ]) -> + | Union_t (_, tr), Prim (_, "Right", [ v ], _) -> traced @@ parse_data ?type_logger ctxt tr v >>=? fun v -> return (R v) - | Union_t _, Prim (loc, "Right", l) -> + | Union_t _, Prim (loc, "Right", l, _) -> fail @@ Invalid_arity (loc, "Right", 1, List.length l) | Union_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Left" ; "Right" ])) @@ -703,20 +704,20 @@ let rec parse_data | Lambda_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Options *) - | Option_t t, Prim (_, "Some", [ v ]) -> + | Option_t t, Prim (_, "Some", [ v ], _) -> traced @@ parse_data ?type_logger ctxt t v >>=? fun v -> return (Some v) - | Option_t _, Prim (loc, "Some", l) -> + | Option_t _, Prim (loc, "Some", l, _) -> fail @@ Invalid_arity (loc, "Some", 1, List.length l) - | Option_t _, Prim (_, "None", []) -> + | Option_t _, Prim (_, "None", [], _) -> return None - | Option_t _, Prim (loc, "None", l) -> + | Option_t _, Prim (loc, "None", l, _) -> fail @@ Invalid_arity (loc, "None", 0, List.length l) | Option_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Some" ; "None" ])) (* Lists *) - | List_t t, Prim (_, "List", vs) -> + | List_t t, Prim (_, "List", vs, _) -> traced @@ fold_right_s (fun v rest -> @@ -726,7 +727,7 @@ let rec parse_data | List_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "List" ])) (* Sets *) - | Set_t t, (Prim (loc, "Set", vs) as expr) -> + | Set_t t, (Prim (loc, "Set", vs, _) as expr) -> fold_left_s (fun (last_value, set) v -> parse_comparable_data ?type_logger ctxt t v >>=? fun v -> @@ -745,10 +746,10 @@ let rec parse_data | Set_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Set" ])) (* Maps *) - | Map_t (tk, tv), (Prim (loc, "Map", vs) as expr) -> + | Map_t (tk, tv), (Prim (loc, "Map", vs, _) as expr) -> (fold_left_s (fun (last_value, map) -> function - | Prim (_, "Item", [ k; v ]) -> + | Prim (_, "Item", [ k; v ], _) -> parse_comparable_data ?type_logger ctxt tk k >>=? fun k -> parse_data ?type_logger ctxt tv v >>=? fun v -> begin match last_value with @@ -762,9 +763,9 @@ let rec parse_data | None -> return () end >>=? fun () -> return (Some k, map_update k (Some v) map) - | Prim (loc, "Item", l) -> + | Prim (loc, "Item", l, _) -> fail @@ Invalid_arity (loc, "Item", 2, List.length l) - | Prim (loc, name, _) -> + | Prim (loc, name, _, _) -> fail @@ Invalid_primitive (loc, [ "Item" ], name) | Int _ | String _ | Seq _ -> fail (error ())) @@ -809,150 +810,150 @@ and parse_instr Lwt.return check in let check_item_ty exp got loc n = check_item (ty_eq exp got) loc n in - let typed loc (instr, aft) = + let typed loc annot (instr, aft) = begin match type_logger with | Some log -> log (loc, (unparse_stack stack_ty, unparse_stack aft)) | None -> () end ; - Typed { loc ; instr ; bef = stack_ty ; aft } in + Typed { loc ; instr ; bef = stack_ty ; aft ; annot } in match script_instr, stack_ty with (* stack ops *) - | Prim (loc, "DROP", []), + | Prim (loc, "DROP", [], annot), Item_t (_, rest) -> - return (typed loc (Drop, rest)) - | Prim (loc, "DUP", []), + return (typed loc annot (Drop, rest)) + | Prim (loc, "DUP", [], annot), Item_t (v, rest) -> - return (typed loc (Dup, Item_t (v, Item_t (v, rest)))) - | Prim (loc, "SWAP", []), + return (typed loc annot (Dup, Item_t (v, Item_t (v, rest)))) + | Prim (loc, "SWAP", [], annot), Item_t (v, Item_t (w, rest)) -> - return (typed loc (Swap, Item_t (w, Item_t (v, rest)))) - | Prim (loc, "PUSH", [ t ; d ]), + return (typed loc annot (Swap, Item_t (w, Item_t (v, rest)))) + | Prim (loc, "PUSH", [ t ; d ], annot), stack -> (Lwt.return (parse_ty t)) >>=? fun (Ex_ty t) -> parse_data ?type_logger ctxt t d >>=? fun v -> - return (typed loc (Const v, Item_t (t, stack))) - | Prim (loc, "UNIT", []), + return (typed loc annot (Const v, Item_t (t, stack))) + | Prim (loc, "UNIT", [], annot), stack -> - return (typed loc (Const (), Item_t (Unit_t, stack))) + return (typed loc annot (Const (), Item_t (Unit_t, stack))) (* options *) - | Prim (loc, "SOME", []), + | Prim (loc, "SOME", [], annot), Item_t (t, rest) -> - return (typed loc (Cons_some, Item_t (Option_t t, rest))) - | Prim (loc, "NONE", [ t ]), + return (typed loc annot (Cons_some, Item_t (Option_t t, rest))) + | Prim (loc, "NONE", [ t ], annot), stack -> (Lwt.return (parse_ty t)) >>=? fun (Ex_ty t) -> - return (typed loc (Cons_none t, Item_t (Option_t t, stack))) - | Prim (loc, "IF_NONE", [ bt ; bf ]), + return (typed loc annot (Cons_none t, Item_t (Option_t t, stack))) + | Prim (loc, "IF_NONE", [ bt ; bf ], annot), (Item_t (Option_t t, rest) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> parse_instr ?storage_type ?type_logger ctxt bt rest >>=? fun btr -> parse_instr ?storage_type ?type_logger ctxt bf (Item_t (t, rest)) >>=? fun bfr -> let branch ibt ibf = - { loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft } in + { loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft ; annot } in merge_branches loc btr bfr { branch } (* pairs *) - | Prim (loc, "PAIR", []), + | Prim (loc, "PAIR", [], annot), Item_t (a, Item_t (b, rest)) -> - return (typed loc (Cons_pair, Item_t (Pair_t(a, b), rest))) - | Prim (loc, "CAR", []), + return (typed loc annot (Cons_pair, Item_t (Pair_t(a, b), rest))) + | Prim (loc, "CAR", [], annot), Item_t (Pair_t (a, _), rest) -> - return (typed loc (Car, Item_t (a, rest))) - | Prim (loc, "CDR", []), + return (typed loc annot (Car, Item_t (a, rest))) + | Prim (loc, "CDR", [], annot), Item_t (Pair_t (_, b), rest) -> - return (typed loc (Cdr, Item_t (b, rest))) + return (typed loc annot (Cdr, Item_t (b, rest))) (* unions *) - | Prim (loc, "LEFT", [ tr ]), + | Prim (loc, "LEFT", [ tr ], annot), Item_t (tl, rest) -> (Lwt.return (parse_ty tr)) >>=? fun (Ex_ty tr) -> - return (typed loc (Left, Item_t (Union_t (tl, tr), rest))) - | Prim (loc, "RIGHT", [ tl ]), + return (typed loc annot (Left, Item_t (Union_t (tl, tr), rest))) + | Prim (loc, "RIGHT", [ tl ], annot), Item_t (tr, rest) -> (Lwt.return (parse_ty tl)) >>=? fun (Ex_ty tl) -> - return (typed loc (Right, Item_t (Union_t (tl, tr), rest))) - | Prim (loc, "IF_LEFT", [ bt ; bf ]), + return (typed loc annot (Right, Item_t (Union_t (tl, tr), rest))) + | Prim (loc, "IF_LEFT", [ bt ; bf ], annot), (Item_t (Union_t (tl, tr), rest) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> parse_instr ?storage_type ?type_logger ctxt bt (Item_t (tl, rest)) >>=? fun btr -> parse_instr ?storage_type ?type_logger ctxt bf (Item_t (tr, rest)) >>=? fun bfr -> let branch ibt ibf = - { loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft } in + { loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft ; annot } in merge_branches loc btr bfr { branch } (* lists *) - | Prim (loc, "NIL", [ t ]), + | Prim (loc, "NIL", [ t ], annot), stack -> (Lwt.return (parse_ty t)) >>=? fun (Ex_ty t) -> - return (typed loc (Nil, Item_t (List_t t, stack))) - | Prim (loc, "CONS", []), + return (typed loc annot (Nil, Item_t (List_t t, stack))) + | Prim (loc, "CONS", [], annot), Item_t (tv, Item_t (List_t t, rest)) -> check_item_ty tv t loc "CONS" 1 2 >>=? fun (Eq _) -> - return (typed loc (Cons_list, Item_t (List_t t, rest))) - | Prim (loc, "IF_CONS", [ bt ; bf ]), + return (typed loc annot (Cons_list, Item_t (List_t t, rest))) + | Prim (loc, "IF_CONS", [ bt ; bf ], annot), (Item_t (List_t t, rest) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> parse_instr ?storage_type ?type_logger ctxt bt (Item_t (t, Item_t (List_t t, rest))) >>=? fun btr -> parse_instr ?storage_type ?type_logger ctxt bf rest >>=? fun bfr -> let branch ibt ibf = - { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft } in + { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft ; annot } in merge_branches loc btr bfr { branch } - | Prim (loc, "MAP", []), + | Prim (loc, "MAP", [], annot), Item_t (Lambda_t (param, ret), Item_t (List_t elt, rest)) -> check_item_ty elt param loc "MAP" 2 2 >>=? fun (Eq _) -> - return (typed loc (List_map, Item_t (List_t ret, rest))) - | Prim (loc, "REDUCE", []), + return (typed loc annot (List_map, Item_t (List_t ret, rest))) + | Prim (loc, "REDUCE", [], annot), Item_t (Lambda_t (Pair_t (pelt, pr), r), Item_t (List_t elt, Item_t (init, rest))) -> check_item_ty r pr loc "REDUCE" 1 3 >>=? fun (Eq _) -> check_item_ty elt pelt loc "REDUCE" 2 3 >>=? fun (Eq _) -> check_item_ty init r loc "REDUCE" 3 3 >>=? fun (Eq _) -> - return (typed loc (List_reduce, Item_t (r, rest))) + return (typed loc annot (List_reduce, Item_t (r, rest))) (* sets *) - | Prim (loc, "EMPTY_SET", [ t ]), + | Prim (loc, "EMPTY_SET", [ t ], annot), rest -> (Lwt.return (parse_comparable_ty t)) >>=? fun (Ex_comparable_ty t) -> - return (typed loc (Empty_set t, Item_t (Set_t t, rest))) - | Prim (loc, "MAP", []), + return (typed loc annot (Empty_set t, Item_t (Set_t t, rest))) + | Prim (loc, "MAP", [], annot), Item_t (Lambda_t (param, ret), Item_t (Set_t elt, rest)) -> let elt = ty_of_comparable_ty elt in (Lwt.return (comparable_ty_of_ty loc ret)) >>=? fun ret -> check_item_ty elt param loc "MAP" 1 2 >>=? fun (Eq _) -> - return (typed loc (Set_map ret, Item_t (Set_t ret, rest))) - | Prim (loc, "REDUCE", []), + return (typed loc annot (Set_map ret, Item_t (Set_t ret, rest))) + | Prim (loc, "REDUCE", [], annot), Item_t (Lambda_t (Pair_t (pelt, pr), r), Item_t (Set_t elt, Item_t (init, rest))) -> let elt = ty_of_comparable_ty elt in check_item_ty r pr loc "REDUCE" 1 3 >>=? fun (Eq _) -> check_item_ty elt pelt loc "REDUCE" 2 3 >>=? fun (Eq _) -> check_item_ty init r loc "REDUCE" 3 3 >>=? fun (Eq _) -> - return (typed loc (Set_reduce, Item_t (r, rest))) - | Prim (loc, "MEM", []), + return (typed loc annot (Set_reduce, Item_t (r, rest))) + | Prim (loc, "MEM", [], annot), Item_t (v, Item_t (Set_t elt, rest)) -> let elt = ty_of_comparable_ty elt in check_item_ty elt v loc "MEM" 1 2 >>=? fun (Eq _) -> - return (typed loc (Set_mem, Item_t (Bool_t, rest))) - | Prim (loc, "UPDATE", []), + return (typed loc annot (Set_mem, Item_t (Bool_t, rest))) + | Prim (loc, "UPDATE", [], annot), Item_t (v, Item_t (Bool_t, Item_t (Set_t elt, rest))) -> let ty = ty_of_comparable_ty elt in check_item_ty ty v loc "UPDATE" 1 3 >>=? fun (Eq _) -> - return (typed loc (Set_update, Item_t (Set_t elt, rest))) - | Prim (loc, "SIZE", []), + return (typed loc annot (Set_update, Item_t (Set_t elt, rest))) + | Prim (loc, "SIZE", [], annot), Item_t (Set_t _, rest) -> - return (typed loc (Set_size, Item_t (Nat_t, rest))) + return (typed loc annot (Set_size, Item_t (Nat_t, rest))) (* maps *) - | Prim (loc, "EMPTY_MAP", [ tk ; tv ]), + | Prim (loc, "EMPTY_MAP", [ tk ; tv ], annot), stack -> (Lwt.return (parse_comparable_ty tk)) >>=? fun (Ex_comparable_ty tk) -> (Lwt.return (parse_ty tv)) >>=? fun (Ex_ty tv) -> - return (typed loc (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack))) - | Prim (loc, "MAP", []), + return (typed loc annot (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack))) + | Prim (loc, "MAP", [], annot), Item_t (Lambda_t (Pair_t (pk, pv), ret), Item_t (Map_t (ck, v), rest)) -> let k = ty_of_comparable_ty ck in check_item_ty pk k loc "MAP" 1 2 >>=? fun (Eq _) -> check_item_ty pv v loc "MAP" 1 2 >>=? fun (Eq _) -> - return (typed loc (Map_map, Item_t (Map_t (ck, ret), rest))) - | Prim (loc, "REDUCE", []), + return (typed loc annot (Map_map, Item_t (Map_t (ck, ret), rest))) + | Prim (loc, "REDUCE", [], annot), Item_t (Lambda_t (Pair_t (Pair_t (pk, pv), pr), r), Item_t (Map_t (ck, v), Item_t (init, rest))) -> let k = ty_of_comparable_ty ck in @@ -960,58 +961,71 @@ and parse_instr check_item_ty pv v loc "REDUCE" 2 3 >>=? fun (Eq _) -> check_item_ty r pr loc "REDUCE" 1 3 >>=? fun (Eq _) -> check_item_ty init r loc "REDUCE" 3 3 >>=? fun (Eq _) -> - return (typed loc (Map_reduce, Item_t (r, rest))) - | Prim (loc, "MEM", []), + return (typed loc annot (Map_reduce, Item_t (r, rest))) + | Prim (loc, "MEM", [], annot), Item_t (vk, Item_t (Map_t (ck, _), rest)) -> let k = ty_of_comparable_ty ck in check_item_ty vk k loc "MEM" 1 2 >>=? fun (Eq _) -> - return (typed loc (Map_mem, Item_t (Bool_t, rest))) - | Prim (loc, "GET", []), + return (typed loc annot (Map_mem, Item_t (Bool_t, rest))) + | Prim (loc, "GET", [], annot), Item_t (vk, Item_t (Map_t (ck, elt), rest)) -> let k = ty_of_comparable_ty ck in check_item_ty vk k loc "GET" 1 2 >>=? fun (Eq _) -> - return (typed loc (Map_get, Item_t (Option_t elt, rest))) - | Prim (loc, "UPDATE", []), + return (typed loc annot (Map_get, Item_t (Option_t elt, rest))) + | Prim (loc, "UPDATE", [], annot), Item_t (vk, Item_t (Option_t vv, Item_t (Map_t (ck, v), rest))) -> let k = ty_of_comparable_ty ck in check_item_ty vk k loc "UPDATE" 1 3 >>=? fun (Eq _) -> check_item_ty vv v loc "UPDATE" 2 3 >>=? fun (Eq _) -> - return (typed loc (Map_update, Item_t (Map_t (ck, v), rest))) - | Prim (loc, "SIZE", []), + return (typed loc annot (Map_update, Item_t (Map_t (ck, v), rest))) + | Prim (loc, "SIZE", [], annot), Item_t (Map_t (_, _), rest) -> - return (typed loc (Map_size, Item_t (Nat_t, rest))) + return (typed loc annot (Map_size, Item_t (Nat_t, rest))) (* control *) - | Seq (loc, []), + | Seq (loc, [], annot), stack -> - return (typed loc (Nop, stack)) - | Seq (_, [ single ]), + return (typed loc annot (Nop, stack)) + | Seq (_, [ single ], None), stack -> parse_instr ?storage_type ?type_logger ctxt single stack - | Seq (loc, hd :: tl), + | Seq (loc, [ single ], (Some _ as annot)), + stack -> + parse_instr ?storage_type ?type_logger ctxt single stack >>=? begin function + | Typed ({ aft } as instr) -> + let nop = { bef = aft ; loc = loc ; aft ; annot = None ; instr = Nop } in + return (typed loc annot (Seq (instr, nop), aft)) + | Failed { descr } -> + let descr aft = + let nop = { bef = aft ; loc = loc ; aft ; annot = None ; instr = Nop } in + let descr = descr aft in + { descr with instr = Seq (descr, nop) ; annot } in + return (Failed { descr }) + end + | Seq (loc, hd :: tl, annot), stack -> parse_instr ?storage_type ?type_logger ctxt hd stack >>=? begin function | Failed _ -> fail (Fail_not_in_tail_position loc) | Typed ({ aft = middle } as ihd) -> - parse_instr ?storage_type ?type_logger ctxt (Seq (loc, tl)) middle >>=? function + parse_instr ?storage_type ?type_logger ctxt (Seq (loc, tl, annot)) middle >>=? function | Failed { descr } -> let descr ret = { loc ; instr = Seq (ihd, descr ret) ; - bef = stack ; aft = ret } in + bef = stack ; aft = ret ; annot = None } in return (Failed { descr }) | Typed itl -> - return (typed loc (Seq (ihd, itl), itl.aft)) + return (typed loc annot (Seq (ihd, itl), itl.aft)) end - | Prim (loc, "IF", [ bt ; bf ]), + | Prim (loc, "IF", [ bt ; bf ], annot), (Item_t (Bool_t, rest) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> parse_instr ?storage_type ?type_logger ctxt bt rest >>=? fun btr -> parse_instr ?storage_type ?type_logger ctxt bf rest >>=? fun bfr -> let branch ibt ibf = - { loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft } in + { loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft ; annot } in merge_branches loc btr bfr { branch } - | Prim (loc, "LOOP", [ body ]), + | Prim (loc, "LOOP", [ body ], annot), (Item_t (Bool_t, rest) as stack) -> check_kind [ Seq_kind ] body >>=? fun () -> parse_instr ?storage_type ?type_logger ctxt body rest >>=? begin function @@ -1019,212 +1033,212 @@ and parse_instr trace (Unmatched_branches (loc, ibody.aft, stack)) (Lwt.return (stack_ty_eq 1 ibody.aft stack)) >>=? fun (Eq _) -> - return (typed loc (Loop ibody, rest)) + return (typed loc annot (Loop ibody, rest)) | Failed { descr } -> let ibody = descr (Item_t (Bool_t, rest)) in - return (typed loc (Loop ibody, rest)) + return (typed loc annot (Loop ibody, rest)) end - | Prim (loc, "LAMBDA", [ arg ; ret ; code ]), + | Prim (loc, "LAMBDA", [ arg ; ret ; code ], annot), stack -> (Lwt.return (parse_ty arg)) >>=? fun (Ex_ty arg) -> (Lwt.return (parse_ty ret)) >>=? fun (Ex_ty ret) -> check_kind [ Seq_kind ] code >>=? fun () -> parse_lambda ?type_logger ctxt arg ret code >>=? fun lambda -> - return (typed loc (Lambda lambda, Item_t (Lambda_t (arg, ret), stack))) - | Prim (loc, "EXEC", []), + return (typed loc annot (Lambda lambda, Item_t (Lambda_t (arg, ret), stack))) + | Prim (loc, "EXEC", [], annot), Item_t (arg, Item_t (Lambda_t (param, ret), rest)) -> check_item_ty arg param loc "EXEC" 1 2 >>=? fun (Eq _) -> - return (typed loc (Exec, Item_t (ret, rest))) - | Prim (loc, "DIP", [ code ]), + return (typed loc annot (Exec, Item_t (ret, rest))) + | Prim (loc, "DIP", [ code ], annot), Item_t (v, rest) -> check_kind [ Seq_kind ] code >>=? fun () -> parse_instr ?type_logger ctxt code rest >>=? begin function | Typed descr -> - return (typed loc (Dip descr, Item_t (v, descr.aft))) + return (typed loc annot (Dip descr, Item_t (v, descr.aft))) | Failed _ -> fail (Fail_not_in_tail_position loc) end - | Prim (loc, "FAIL", []), + | Prim (loc, "FAIL", [], annot), bef -> - let descr aft = { loc ; instr = Fail ; bef ; aft } in + let descr aft = { loc ; instr = Fail ; bef ; aft ; annot } in return (Failed { descr }) (* timestamp operations *) - | Prim (loc, "ADD", []), + | Prim (loc, "ADD", [], annot), Item_t (Timestamp_t, Item_t (Nat_t, rest)) -> - return (typed loc (Add_timestamp_to_seconds, Item_t (Timestamp_t, rest))) - | Prim (loc, "ADD", []), + return (typed loc annot (Add_timestamp_to_seconds, Item_t (Timestamp_t, rest))) + | Prim (loc, "ADD", [], annot), Item_t (Nat_t, Item_t (Timestamp_t, rest)) -> - return (typed loc (Add_seconds_to_timestamp, Item_t (Timestamp_t, rest))) + return (typed loc annot (Add_seconds_to_timestamp, Item_t (Timestamp_t, rest))) (* string operations *) - | Prim (loc, "CONCAT", []), + | Prim (loc, "CONCAT", [], annot), Item_t (String_t, Item_t (String_t, rest)) -> - return (typed loc (Concat, Item_t (String_t, rest))) + return (typed loc annot (Concat, Item_t (String_t, rest))) (* currency operations *) - | Prim (loc, "ADD", []), + | Prim (loc, "ADD", [], annot), Item_t (Tez_t, Item_t (Tez_t, rest)) -> - return (typed loc (Add_tez, Item_t (Tez_t, rest))) - | Prim (loc, "SUB", []), + return (typed loc annot (Add_tez, Item_t (Tez_t, rest))) + | Prim (loc, "SUB", [], annot), Item_t (Tez_t, Item_t (Tez_t, rest)) -> - return (typed loc (Sub_tez, Item_t (Tez_t, rest))) - | Prim (loc, "MUL", []), + return (typed loc annot (Sub_tez, Item_t (Tez_t, rest))) + | Prim (loc, "MUL", [], annot), Item_t (Tez_t, Item_t (Nat_t, rest)) -> - return (typed loc (Mul_teznat, Item_t (Tez_t, rest))) - | Prim (loc, "MUL", []), + return (typed loc annot (Mul_teznat, Item_t (Tez_t, rest))) + | Prim (loc, "MUL", [], annot), Item_t (Nat_t, Item_t (Tez_t, rest)) -> - return (typed loc (Mul_nattez, Item_t (Tez_t, rest))) + return (typed loc annot (Mul_nattez, Item_t (Tez_t, rest))) (* boolean operations *) - | Prim (loc, "OR", []), + | Prim (loc, "OR", [], annot), Item_t (Bool_t, Item_t (Bool_t, rest)) -> - return (typed loc (Or, Item_t (Bool_t, rest))) - | Prim (loc, "AND", []), + return (typed loc annot (Or, Item_t (Bool_t, rest))) + | Prim (loc, "AND", [], annot), Item_t (Bool_t, Item_t (Bool_t, rest)) -> - return (typed loc (And, Item_t (Bool_t, rest))) - | Prim (loc, "XOR", []), + return (typed loc annot (And, Item_t (Bool_t, rest))) + | Prim (loc, "XOR", [], annot), Item_t (Bool_t, Item_t (Bool_t, rest)) -> - return (typed loc (Xor, Item_t (Bool_t, rest))) - | Prim (loc, "NOT", []), + return (typed loc annot (Xor, Item_t (Bool_t, rest))) + | Prim (loc, "NOT", [], annot), Item_t (Bool_t, rest) -> - return (typed loc (Not, Item_t (Bool_t, rest))) + return (typed loc annot (Not, Item_t (Bool_t, rest))) (* integer operations *) - | Prim (loc, "ABS", []), + | Prim (loc, "ABS", [], annot), Item_t (Int_t, rest) -> - return (typed loc (Abs_int, Item_t (Nat_t, rest))) - | Prim (loc, "INT", []), + return (typed loc annot (Abs_int, Item_t (Nat_t, rest))) + | Prim (loc, "INT", [], annot), Item_t (Nat_t, rest) -> - return (typed loc (Int_nat, Item_t (Int_t, rest))) - | Prim (loc, "NEG", []), + return (typed loc annot (Int_nat, Item_t (Int_t, rest))) + | Prim (loc, "NEG", [], annot), Item_t (Int_t, rest) -> - return (typed loc (Neg_int, Item_t (Int_t, rest))) - | Prim (loc, "NEG", []), + return (typed loc annot (Neg_int, Item_t (Int_t, rest))) + | Prim (loc, "NEG", [], annot), Item_t (Nat_t, rest) -> - return (typed loc (Neg_nat, Item_t (Int_t, rest))) - | Prim (loc, "ADD", []), + return (typed loc annot (Neg_nat, Item_t (Int_t, rest))) + | Prim (loc, "ADD", [], annot), Item_t (Int_t, Item_t (Int_t, rest)) -> - return (typed loc (Add_intint, Item_t (Int_t, rest))) - | Prim (loc, "ADD", []), + return (typed loc annot (Add_intint, Item_t (Int_t, rest))) + | Prim (loc, "ADD", [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> - return (typed loc (Add_intnat, Item_t (Int_t, rest))) - | Prim (loc, "ADD", []), + return (typed loc annot (Add_intnat, Item_t (Int_t, rest))) + | Prim (loc, "ADD", [], annot), Item_t (Nat_t, Item_t (Int_t, rest)) -> - return (typed loc (Add_natint, Item_t (Int_t, rest))) - | Prim (loc, "ADD", []), + return (typed loc annot (Add_natint, Item_t (Int_t, rest))) + | Prim (loc, "ADD", [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> - return (typed loc (Add_natnat, Item_t (Nat_t, rest))) - | Prim (loc, "SUB", []), + return (typed loc annot (Add_natnat, Item_t (Nat_t, rest))) + | Prim (loc, "SUB", [], annot), Item_t (Int_t, Item_t (Int_t, rest)) -> - return (typed loc (Sub_int, Item_t (Int_t, rest))) - | Prim (loc, "SUB", []), + return (typed loc annot (Sub_int, Item_t (Int_t, rest))) + | Prim (loc, "SUB", [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> - return (typed loc (Sub_int, Item_t (Int_t, rest))) - | Prim (loc, "SUB", []), + return (typed loc annot (Sub_int, Item_t (Int_t, rest))) + | Prim (loc, "SUB", [], annot), Item_t (Nat_t, Item_t (Int_t, rest)) -> - return (typed loc (Sub_int, Item_t (Int_t, rest))) - | Prim (loc, "SUB", []), + return (typed loc annot (Sub_int, Item_t (Int_t, rest))) + | Prim (loc, "SUB", [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> - return (typed loc (Sub_int, Item_t (Int_t, rest))) - | Prim (loc, "MUL", []), + return (typed loc annot (Sub_int, Item_t (Int_t, rest))) + | Prim (loc, "MUL", [], annot), Item_t (Int_t, Item_t (Int_t, rest)) -> - return (typed loc (Mul_intint, Item_t (Int_t, rest))) - | Prim (loc, "MUL", []), + return (typed loc annot (Mul_intint, Item_t (Int_t, rest))) + | Prim (loc, "MUL", [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> - return (typed loc (Mul_intnat, Item_t (Int_t, rest))) - | Prim (loc, "MUL", []), + return (typed loc annot (Mul_intnat, Item_t (Int_t, rest))) + | Prim (loc, "MUL", [], annot), Item_t (Nat_t, Item_t (Int_t, rest)) -> - return (typed loc (Mul_natint, Item_t (Int_t, rest))) - | Prim (loc, "MUL", []), + return (typed loc annot (Mul_natint, Item_t (Int_t, rest))) + | Prim (loc, "MUL", [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> - return (typed loc (Mul_natnat, Item_t (Nat_t, rest))) - | Prim (loc, "EDIV", []), + return (typed loc annot (Mul_natnat, Item_t (Nat_t, rest))) + | Prim (loc, "EDIV", [], annot), Item_t (Tez_t, Item_t (Nat_t, rest)) -> - return (typed loc (Ediv_teznat, + return (typed loc annot (Ediv_teznat, Item_t (Option_t (Pair_t (Tez_t,Tez_t)), rest))) - | Prim (loc, "EDIV", []), + | Prim (loc, "EDIV", [], annot), Item_t (Tez_t, Item_t (Tez_t, rest)) -> - return (typed loc (Ediv_tez, + return (typed loc annot (Ediv_tez, Item_t (Option_t (Pair_t (Nat_t,Tez_t)), rest))) - | Prim (loc, "EDIV", []), + | Prim (loc, "EDIV", [], annot), Item_t (Int_t, Item_t (Int_t, rest)) -> - return (typed loc (Ediv_intint, + return (typed loc annot (Ediv_intint, Item_t (Option_t (Pair_t (Int_t,Nat_t)), rest))) - | Prim (loc, "EDIV", []), + | Prim (loc, "EDIV", [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> - return (typed loc (Ediv_intnat, + return (typed loc annot (Ediv_intnat, Item_t (Option_t (Pair_t (Int_t,Nat_t)), rest))) - | Prim (loc, "EDIV", []), + | Prim (loc, "EDIV", [], annot), Item_t (Nat_t, Item_t (Int_t, rest)) -> - return (typed loc (Ediv_natint, + return (typed loc annot (Ediv_natint, Item_t (Option_t (Pair_t (Int_t,Nat_t)), rest))) - | Prim (loc, "EDIV", []), + | Prim (loc, "EDIV", [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> - return (typed loc (Ediv_natnat, + return (typed loc annot (Ediv_natnat, Item_t (Option_t (Pair_t (Nat_t,Nat_t)), rest))) - | Prim (loc, "LSL", []), + | Prim (loc, "LSL", [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> - return (typed loc (Lsl_nat, Item_t (Nat_t, rest))) - | Prim (loc, "LSR", []), + return (typed loc annot (Lsl_nat, Item_t (Nat_t, rest))) + | Prim (loc, "LSR", [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> - return (typed loc (Lsr_nat, Item_t (Nat_t, rest))) - | Prim (loc, "OR", []), + return (typed loc annot (Lsr_nat, Item_t (Nat_t, rest))) + | Prim (loc, "OR", [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> - return (typed loc (Or_nat, Item_t (Nat_t, rest))) - | Prim (loc, "AND", []), + return (typed loc annot (Or_nat, Item_t (Nat_t, rest))) + | Prim (loc, "AND", [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> - return (typed loc (And_nat, Item_t (Nat_t, rest))) - | Prim (loc, "XOR", []), + return (typed loc annot (And_nat, Item_t (Nat_t, rest))) + | Prim (loc, "XOR", [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> - return (typed loc (Xor_nat, Item_t (Nat_t, rest))) - | Prim (loc, "NOT", []), + return (typed loc annot (Xor_nat, Item_t (Nat_t, rest))) + | Prim (loc, "NOT", [], annot), Item_t (Int_t, rest) -> - return (typed loc (Not_int, Item_t (Int_t, rest))) - | Prim (loc, "NOT", []), + return (typed loc annot (Not_int, Item_t (Int_t, rest))) + | Prim (loc, "NOT", [], annot), Item_t (Nat_t, rest) -> - return (typed loc (Not_nat, Item_t (Int_t, rest))) + return (typed loc annot (Not_nat, Item_t (Int_t, rest))) (* comparison *) - | Prim (loc, "COMPARE", []), + | Prim (loc, "COMPARE", [], annot), Item_t (Int_t, Item_t (Int_t, rest)) -> - return (typed loc (Compare Int_key, Item_t (Int_t, rest))) - | Prim (loc, "COMPARE", []), + return (typed loc annot (Compare Int_key, Item_t (Int_t, rest))) + | Prim (loc, "COMPARE", [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> - return (typed loc (Compare Nat_key, Item_t (Int_t, rest))) - | Prim (loc, "COMPARE", []), + return (typed loc annot (Compare Nat_key, Item_t (Int_t, rest))) + | Prim (loc, "COMPARE", [], annot), Item_t (Bool_t, Item_t (Bool_t, rest)) -> - return (typed loc (Compare Bool_key, Item_t (Int_t, rest))) - | Prim (loc, "COMPARE", []), + return (typed loc annot (Compare Bool_key, Item_t (Int_t, rest))) + | Prim (loc, "COMPARE", [], annot), Item_t (String_t, Item_t (String_t, rest)) -> - return (typed loc (Compare String_key, Item_t (Int_t, rest))) - | Prim (loc, "COMPARE", []), + return (typed loc annot (Compare String_key, Item_t (Int_t, rest))) + | Prim (loc, "COMPARE", [], annot), Item_t (Tez_t, Item_t (Tez_t, rest)) -> - return (typed loc (Compare Tez_key, Item_t (Int_t, rest))) - | Prim (loc, "COMPARE", []), + return (typed loc annot (Compare Tez_key, Item_t (Int_t, rest))) + | Prim (loc, "COMPARE", [], annot), Item_t (Key_t, Item_t (Key_t, rest)) -> - return (typed loc (Compare Key_key, Item_t (Int_t, rest))) - | Prim (loc, "COMPARE", []), + return (typed loc annot (Compare Key_key, Item_t (Int_t, rest))) + | Prim (loc, "COMPARE", [], annot), Item_t (Timestamp_t, Item_t (Timestamp_t, rest)) -> - return (typed loc (Compare Timestamp_key, Item_t (Int_t, rest))) + return (typed loc annot (Compare Timestamp_key, Item_t (Int_t, rest))) (* comparators *) - | Prim (loc, "EQ", []), + | Prim (loc, "EQ", [], annot), Item_t (Int_t, rest) -> - return (typed loc (Eq, Item_t (Bool_t, rest))) - | Prim (loc, "NEQ", []), + return (typed loc annot (Eq, Item_t (Bool_t, rest))) + | Prim (loc, "NEQ", [], annot), Item_t (Int_t, rest) -> - return (typed loc (Neq, Item_t (Bool_t, rest))) - | Prim (loc, "LT", []), + return (typed loc annot (Neq, Item_t (Bool_t, rest))) + | Prim (loc, "LT", [], annot), Item_t (Int_t, rest) -> - return (typed loc (Lt, Item_t (Bool_t, rest))) - | Prim (loc, "GT", []), + return (typed loc annot (Lt, Item_t (Bool_t, rest))) + | Prim (loc, "GT", [], annot), Item_t (Int_t, rest) -> - return (typed loc (Gt, Item_t (Bool_t, rest))) - | Prim (loc, "LE", []), + return (typed loc annot (Gt, Item_t (Bool_t, rest))) + | Prim (loc, "LE", [], annot), Item_t (Int_t, rest) -> - return (typed loc (Le, Item_t (Bool_t, rest))) - | Prim (loc, "GE", []), + return (typed loc annot (Le, Item_t (Bool_t, rest))) + | Prim (loc, "GE", [], annot), Item_t (Int_t, rest) -> - return (typed loc (Ge, Item_t (Bool_t, rest))) + return (typed loc annot (Ge, Item_t (Bool_t, rest))) (* protocol *) - | Prim (loc, "MANAGER", []), + | Prim (loc, "MANAGER", [], annot), Item_t (Contract_t _, rest) -> - return (typed loc (Manager, Item_t (Key_t, rest))) - | Prim (loc, "TRANSFER_TOKENS", []), + return (typed loc annot (Manager, Item_t (Key_t, rest))) + | Prim (loc, "TRANSFER_TOKENS", [], annot), Item_t (p, Item_t (Tez_t, Item_t (Contract_t (cp, cr), Item_t @@ -1233,24 +1247,24 @@ and parse_instr begin match storage_type with | Some storage_type -> check_item_ty storage storage_type loc "TRANSFER_TOKENS" 3 4 >>=? fun (Eq _) -> - return (typed loc (Transfer_tokens storage, + return (typed loc annot (Transfer_tokens storage, Item_t (cr, Item_t (storage, Empty_t)))) | None -> fail (Transfer_in_lambda loc) end - | Prim (loc, "CREATE_ACCOUNT", []), + | Prim (loc, "CREATE_ACCOUNT", [], annot), Item_t (Key_t, Item_t (Option_t Key_t, Item_t (Bool_t, Item_t (Tez_t, rest)))) -> - return (typed loc (Create_account, + return (typed loc annot (Create_account, Item_t (Contract_t (Unit_t, Unit_t), rest))) - | Prim (loc, "DEFAULT_ACCOUNT", []), + | Prim (loc, "DEFAULT_ACCOUNT", [], annot), Item_t (Key_t, rest) -> return - (typed loc (Default_account, Item_t (Contract_t (Unit_t, Unit_t), rest))) - | Prim (loc, "CREATE_CONTRACT", []), + (typed loc annot (Default_account, Item_t (Contract_t (Unit_t, Unit_t), rest))) + | Prim (loc, "CREATE_CONTRACT", [], annot), Item_t (Key_t, Item_t (Option_t Key_t, Item_t @@ -1262,31 +1276,31 @@ and parse_instr (ginit, rest))))))) -> check_item_ty gp gr loc "CREATE_CONTRACT" 5 7 >>=? fun (Eq _) -> check_item_ty ginit gp loc "CREATE_CONTRACT" 6 7 >>=? fun (Eq _) -> - return (typed loc (Create_contract (gp, p, r), + return (typed loc annot (Create_contract (gp, p, r), Item_t (Contract_t (p, r), rest))) - | Prim (loc, "NOW", []), + | Prim (loc, "NOW", [], annot), stack -> - return (typed loc (Now, Item_t (Timestamp_t, stack))) - | Prim (loc, "AMOUNT", []), + return (typed loc annot (Now, Item_t (Timestamp_t, stack))) + | Prim (loc, "AMOUNT", [], annot), stack -> - return (typed loc (Amount, Item_t (Tez_t, stack))) - | Prim (loc, "BALANCE", []), + return (typed loc annot (Amount, Item_t (Tez_t, stack))) + | Prim (loc, "BALANCE", [], annot), stack -> - return (typed loc (Balance, Item_t (Tez_t, stack))) - | Prim (loc, "CHECK_SIGNATURE", []), + return (typed loc annot (Balance, Item_t (Tez_t, stack))) + | Prim (loc, "CHECK_SIGNATURE", [], annot), Item_t (Key_t, Item_t (Pair_t (Signature_t, String_t), rest)) -> - return (typed loc (Check_signature, Item_t (Bool_t, rest))) - | Prim (loc, "H", []), + return (typed loc annot (Check_signature, Item_t (Bool_t, rest))) + | Prim (loc, "H", [], annot), Item_t (t, rest) -> - return (typed loc (H t, Item_t (String_t, rest))) - | Prim (loc, "STEPS_TO_QUOTA", []), + return (typed loc annot (H t, Item_t (String_t, rest))) + | Prim (loc, "STEPS_TO_QUOTA", [], annot), stack -> - return (typed loc (Steps_to_quota, Item_t (Nat_t, stack))) - | Prim (loc, "SOURCE", [ ta; tb ]), + return (typed loc annot (Steps_to_quota, Item_t (Nat_t, stack))) + | Prim (loc, "SOURCE", [ ta; tb ], annot), stack -> (Lwt.return (parse_ty ta)) >>=? fun (Ex_ty ta) -> (Lwt.return (parse_ty tb)) >>=? fun (Ex_ty tb) -> - return (typed loc (Source (ta, tb), Item_t (Contract_t (ta, tb), stack))) + return (typed loc annot (Source (ta, tb), Item_t (Contract_t (ta, tb), stack))) (* Primitive parsing errors *) | Prim (loc, ("DROP" | "DUP" | "SWAP" | "SOME" | "UNIT" | "PAIR" | "CAR" | "CDR" | "CONS" @@ -1302,55 +1316,56 @@ and parse_instr | "CREATE_CONTRACT" | "NOW" | "DEFAULT_ACCOUNT" | "AMOUNT" | "BALANCE" | "CHECK_SIGNATURE" | "H" | "STEPS_TO_QUOTA" - as name), (_ :: _ as l)), _ -> + as name), (_ :: _ as l), _), _ -> fail (Invalid_arity (loc, name, 0, List.length l)) | Prim (loc, ("NONE" | "LEFT" | "RIGHT" | "NIL" | "EMPTY_SET" | "DIP" | "LOOP" as name), ([] - | _ :: _ :: _ as l)), _ -> + | _ :: _ :: _ as l), _), _ -> fail (Invalid_arity (loc, name, 1, List.length l)) | Prim (loc, ("PUSH" | "IF_NONE" | "IF_LEFT" | "IF_CONS" | "EMPTY_MAP" | "IF" | "SOURCE" as name), ([] | [ _ ] - | _ :: _ :: _ :: _ as l)), _ -> + | _ :: _ :: _ :: _ as l), _), _ -> fail (Invalid_arity (loc, name, 2, List.length l)) | Prim (loc, "LAMBDA", ([] | [ _ ] | [ _ ; _ ] - | _ :: _ :: _ :: _ :: _ as l)), _ -> + | _ :: _ :: _ :: _ :: _ as l), _), _ -> fail (Invalid_arity (loc, "LAMBDA", 3, List.length l)) (* Stack errors *) | Prim (loc, ("ADD" | "SUB" | "MUL" | "EDIV" | "AND" | "OR" | "XOR" | "LSL" | "LSR" - | "CONCAT" | "COMPARE" as name), []), + | "CONCAT" | "COMPARE" as name), [], _), Item_t (ta, Item_t (tb, _)) -> fail (Undefined_binop (loc, name, ta, tb)) | Prim (loc, ("NEG" | "ABS" | "NOT" - | "EQ" | "NEQ" | "LT" | "GT" | "LE" | "GE" as name), []), + | "EQ" | "NEQ" | "LT" | "GT" | "LE" | "GE" as name), + [], _), Item_t (t, _) -> fail (Undefined_unop (loc, name, t)) - | Prim (loc, ("REDUCE" | "UPDATE" as name), []), + | Prim (loc, ("REDUCE" | "UPDATE" as name), [], _), stack -> fail (Bad_stack (loc, name, 3, stack)) - | Prim (loc, "CREATE_CONTRACT", []), + | Prim (loc, "CREATE_CONTRACT", [], _), stack -> fail (Bad_stack (loc, "CREATE_CONTRACT", 7, stack)) - | Prim (loc, "CREATE_ACCOUNT", []), + | Prim (loc, "CREATE_ACCOUNT", [], _), stack -> fail (Bad_stack (loc, "CREATE_ACCOUNT", 4, stack)) - | Prim (loc, "TRANSFER_TOKENS", []), + | Prim (loc, "TRANSFER_TOKENS", [], _), stack -> fail (Bad_stack (loc, "TRANSFER_TOKENS", 3, stack)) | Prim (loc, ("DROP" | "DUP" | "CAR" | "CDR" | "SOME" | "H" | "DIP" | "IF_NONE" | "LEFT" | "RIGHT" | "IF_LEFT" | "IF" | "LOOP" | "IF_CONS" | "MANAGER" | "DEFAULT_ACCOUNT" | "NEG" | "ABS" | "INT" | "NOT" - | "EQ" | "NEQ" | "LT" | "GT" | "LE" | "GE" as name), _), + | "EQ" | "NEQ" | "LT" | "GT" | "LE" | "GE" as name), _, _), stack -> fail (Bad_stack (loc, name, 1, stack)) | Prim (loc, ("SWAP" | "PAIR" | "CONS" | "MAP" | "GET" | "MEM" | "EXEC" | "CHECK_SIGNATURE" | "ADD" | "SUB" | "MUL" | "EDIV" | "AND" | "OR" | "XOR" - | "LSL" | "LSR" | "CONCAT" as name), _), + | "LSL" | "LSR" | "CONCAT" as name), _, _), stack -> fail (Bad_stack (loc, name, 2, stack)) (* Generic parsing errors *) diff --git a/src/proto/alpha/script_repr.ml b/src/proto/alpha/script_repr.ml index e42e2436b..88d65db85 100644 --- a/src/proto/alpha/script_repr.ml +++ b/src/proto/alpha/script_repr.ml @@ -30,8 +30,8 @@ let location_encoding = type expr = (* TODO: turn the location into an alpha ? *) | Int of location * string | String of location * string - | Prim of location * string * expr list - | Seq of location * expr list + | Prim of location * string * expr list * string option + | Seq of location * expr list * string option let expr_encoding = let open Data_encoding in @@ -43,15 +43,15 @@ let expr_encoding = let json = union [ case string - (function (v, []) -> Some v | _ -> None) - (fun v -> (v, [])) ; - case (assoc (list expr_encoding)) - (fun (v, args) -> Some [ (v, args) ]) + (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) ] -> (v, args) + | [ (v, (args, annot)) ] -> (v, args, annot) | _ -> Json.cannot_destruct "invalid script expression") ] in let binary = - obj2 (req "prim" string) (req "args" (list expr_encoding)) in + 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 @@ -67,31 +67,31 @@ let expr_encoding = (fun v -> String (-1, v)) ; case ~tag:2 (prim_encoding expr_encoding) (function - | Prim (_, v, args) -> Some (v, args) + | Prim (_, v, args, annot) -> Some (v, args, annot) | _ -> None) - (function (prim, args) -> Prim (-1, prim, args)) ; + (function (prim, args, annot) -> Prim (-1, prim, args, annot)) ; case ~tag:3 (seq_encoding expr_encoding) - (function Seq (_, v) -> Some v | _ -> None) - (fun args -> Seq (-1, args)) ]) + (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) -> + | 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), ni) - | Seq (_, args) -> + (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), ni) in + (Seq (i, List.rev nargs, annot), ni) in fst (update_locations 1 ir) let expr_encoding = diff --git a/src/proto/alpha/script_repr.mli b/src/proto/alpha/script_repr.mli index b4626bd88..6060b7792 100644 --- a/src/proto/alpha/script_repr.mli +++ b/src/proto/alpha/script_repr.mli @@ -24,8 +24,8 @@ type location = type expr = | Int of location * string | String of location * string - | Prim of location * string * expr list - | Seq of location * expr list + | Prim of location * string * expr list * string option + | Seq of location * expr list * string option type code = { code : expr ; diff --git a/src/proto/alpha/script_typed_ir.ml b/src/proto/alpha/script_typed_ir.ml index 0306bc518..83d4c180c 100644 --- a/src/proto/alpha/script_typed_ir.ml +++ b/src/proto/alpha/script_typed_ir.ml @@ -312,4 +312,5 @@ and ('bef, 'aft) descr = { loc : Script.location ; bef : 'bef stack_ty ; aft : 'aft stack_ty ; - instr : ('bef, 'aft) instr } + instr : ('bef, 'aft) instr ; + annot : string option } diff --git a/src/proto/alpha/tezos_context.mli b/src/proto/alpha/tezos_context.mli index 564755678..a98f1552e 100644 --- a/src/proto/alpha/tezos_context.mli +++ b/src/proto/alpha/tezos_context.mli @@ -116,8 +116,8 @@ module Script : sig type expr = | Int of location * string | String of location * string - | Prim of location * string * expr list - | Seq of location * expr list + | Prim of location * string * expr list * string option + | Seq of location * expr list * string option type code = { code: expr ; diff --git a/test/contracts/compare.tz b/test/contracts/compare.tz index e68faf9a5..ed661ec87 100644 --- a/test/contracts/compare.tz +++ b/test/contracts/compare.tz @@ -5,6 +5,6 @@ code {CAR; DUP; DUP; DUP; DUP; DIIIIIP {NIL bool}; DIIIIP {DUP; CAR; DIP {CDR}; COMPARE; LE; CONS}; DIIIP {DUP; CAR; DIP {CDR}; COMPARE; GE; CONS}; DIIP{DUP; CAR; DIP {CDR}; COMPARE; LT; CONS}; - DIP {DUP; CAR; DIP {CDR}; COMPARE; GT; CONS} + DIP {DUP; CAR; DIP {CDR}; COMPARE; GT; CONS}; DUP; CAR; DIP {CDR}; COMPARE; EQ; CONS; UNIT; SWAP; PAIR}; diff --git a/test/contracts/create_contract.tz b/test/contracts/create_contract.tz index 0dd677d6b..ebc3552a6 100644 --- a/test/contracts/create_contract.tz +++ b/test/contracts/create_contract.tz @@ -1,11 +1,13 @@ parameter key; storage string; return unit; -code {CAR; DIP{UNIT; LAMBDA (pair string unit) - (pair string unit) - {CAR; UNIT; SWAP; PAIR}; - PUSH tez "100.00"; PUSH bool False; - PUSH bool False; NONE key}; - CREATE_CONTRACT; DIP{PUSH string ""}; PUSH tez "0.00"; - PUSH string "abcdefg"; TRANSFER_TOKENS; - DIP{DROP}; UNIT; PAIR}; +code { CAR; + DIP { UNIT; + LAMBDA + (pair string unit) (pair string unit) + { CAR; UNIT; SWAP; PAIR }; + PUSH tez "100.00"; PUSH bool False; + PUSH bool False; NONE key }; + CREATE_CONTRACT; DIP { PUSH string "" }; PUSH tez "0.00"; + PUSH string "abcdefg"; TRANSFER_TOKENS; + DIP { DROP }; UNIT; PAIR } diff --git a/test/contracts/hardlimit.tz b/test/contracts/hardlimit.tz index 86cf0caf5..b9122789a 100644 --- a/test/contracts/hardlimit.tz +++ b/test/contracts/hardlimit.tz @@ -1,7 +1,7 @@ -parameter unit +parameter unit ; code { # This contract stops accepting transactions after N incoming transactions CDR ; DUP ; PUSH int 0 ; CMPLT; IF {PUSH int -1 ; ADD} {FAIL}; - UNIT; PAIR} -return unit + UNIT; PAIR} ; +return unit ; storage int diff --git a/test/test_utils.sh b/test/test_utils.sh index 9cbb319ce..d4f569f31 100755 --- a/test/test_utils.sh +++ b/test/test_utils.sh @@ -60,8 +60,8 @@ start_sandboxed_node() { data_dir="$(mktemp -d -t tezos_node.XXXXXXXXXX)" register_dir "$data_dir" - ${TZNODE} identity generate 0 --data-dir "${data_dir}" |& sed 's/^/## /' 1>&2 - ${TZNODE} config init --data-dir="${data_dir}" --connections=2 --expected-pow=0.0 |& sed 's/^/## /' 1>&2 + ${TZNODE} identity generate 0 --data-dir "${data_dir}" 2>&1| sed 's/^/## /' 1>&2 + ${TZNODE} config init --data-dir="${data_dir}" --connections=2 --expected-pow=0.0 2>&1| sed 's/^/## /' 1>&2 ${TZNODE} run --data-dir "${data_dir}" ${CUSTOM_PARAM} "$@" $default_args > "$data_dir"/LOG 2>&1 & node_pid="$!" CLEANUP_PROCESSES+=($node_pid)