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

Michelson: allow multiple annotations

Browse Source
This commit is contained in:
Benjamin Canou 2018-05-17 19:37:25 +02:00
parent a51c912722
commit 3140f6e51d
20 changed files with 661 additions and 688 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
src/lib_micheline/micheline.ml
View File

@ -10,8 +10,8 @@
type ('l, 'p) node =
| Int of 'l * Z.t
| String of 'l * string
| Prim of 'l * 'p * ('l, 'p) node list * string option
| Seq of 'l * ('l, 'p) node list * string option
| Prim of 'l * 'p * ('l, 'p) node list * string list
| Seq of 'l * ('l, 'p) node list
type canonical_location = int
@ -32,14 +32,14 @@ let canonical_location_encoding =
let location = function
| Int (loc, _) -> loc
| String (loc, _) -> loc
| Seq (loc, _, _) -> loc
| Seq (loc, _) -> loc
| Prim (loc, _, _, _) -> loc
let annotation = function
| Int (_, _) -> None
| String (_, _) -> None
| Seq (_, _, annot) -> annot
| Prim (_, _, _, annot) -> annot
let annotations = function
| Int (_, _) -> []
| String (_, _) -> []
| Seq (_, _) -> []
| Prim (_, _, _, annots) -> annots
let root (Canonical expr) = expr
@ -53,10 +53,10 @@ let strip_locations root =
Int (id, v)
| String (_, v) ->
String (id, v)
| Seq (_, seq, annot) ->
Seq (id, List.map strip_locations seq, annot)
| Prim (_, name, seq, annot) ->
Prim (id, name, List.map strip_locations seq, annot) in
| Seq (_, seq) ->
Seq (id, List.map strip_locations seq)
| Prim (_, name, seq, annots) ->
Prim (id, name, List.map strip_locations seq, annots) in
Canonical (strip_locations root)
let extract_locations root =
@ -71,12 +71,12 @@ let extract_locations root =
| String (loc, v) ->
loc_table := (id, loc) :: !loc_table ;
String (id, v)
| Seq (loc, seq, annot) ->
| Seq (loc, seq) ->
loc_table := (id, loc) :: !loc_table ;
Seq (id, List.map strip_locations seq, annot)
| Prim (loc, name, seq, annot) ->
Seq (id, List.map strip_locations seq)
| Prim (loc, name, seq, annots) ->
loc_table := (id, loc) :: !loc_table ;
Prim (id, name, List.map strip_locations seq, annot) in
Prim (id, name, List.map strip_locations seq, annots) in
let stripped = strip_locations root in
Canonical stripped, List.rev !loc_table
@ -87,19 +87,19 @@ let inject_locations lookup (Canonical root) =
Int (lookup loc, v)
| String (loc, v) ->
String (lookup loc, v)
| Seq (loc, seq, annot) ->
Seq (lookup loc, List.map inject_locations seq, annot)
| Prim (loc, name, seq, annot) ->
Prim (lookup loc, name, List.map inject_locations seq, annot) in
| Seq (loc, seq) ->
Seq (lookup loc, List.map inject_locations seq)
| Prim (loc, name, seq, annots) ->
Prim (lookup loc, name, List.map inject_locations seq, annots) in
inject_locations root
let map f (Canonical expr) =
let rec map_node f = function
| Int _ | String _ as node -> node
| Seq (loc, seq, annot) ->
Seq (loc, List.map (map_node f) seq, annot)
| Prim (loc, name, seq, annot) ->
Prim (loc, f name, List.map (map_node f) seq, annot) in
| Seq (loc, seq) ->
Seq (loc, List.map (map_node f) seq)
| Prim (loc, name, seq, annots) ->
Prim (loc, f name, List.map (map_node f) seq, annots) in
Canonical (map_node f expr)
let rec map_node fl fp = function
@ -107,10 +107,10 @@ let rec map_node fl fp = function
Int (fl loc, v)
| String (loc, v) ->
String (fl loc, v)
| Seq (loc, seq, annot) ->
Seq (fl loc, List.map (map_node fl fp) seq, annot)
| Prim (loc, name, seq, annot) ->
Prim (fl loc, fp name, List.map (map_node fl fp) seq, annot)
| Seq (loc, seq) ->
Seq (fl loc, List.map (map_node fl fp) seq)
| Prim (loc, name, seq, annots) ->
Prim (fl loc, fp name, List.map (map_node fl fp) seq, annots)
let canonical_encoding ~variant prim_encoding =
let open Data_encoding in
@ -131,18 +131,18 @@ let canonical_encoding ~variant prim_encoding =
let seq_encoding tag expr_encoding =
case tag (list expr_encoding)
~title:"Sequence"
(function Seq (_, v, _annot) -> Some v | _ -> None)
(fun args -> Seq (0, args, None)) in
(function Seq (_, v) -> Some v | _ -> None)
(fun args -> Seq (0, args)) in
let byte_string = Bounded.string 255 in
let application_encoding tag expr_encoding =
case tag
~title:"Generic prim (any number of args with or without annot)"
(obj3 (req "prim" prim_encoding)
(req "args" (list expr_encoding))
(opt "annot" byte_string))
(function Prim (_, prim, args, annot) -> Some (prim, args, annot)
(dft "args" (list expr_encoding) [])
(dft "annots" (list byte_string) []))
(function Prim (_, prim, args, annots) -> Some (prim, args, annots)
| _ -> None)
(fun (prim, args, annot) -> Prim (0, prim, args, annot)) in
(fun (prim, args, annots) -> Prim (0, prim, args, annots)) in
let node_encoding = mu ("micheline." ^ variant ^ ".expression") (fun expr_encoding ->
splitted
~json:(union ~tag_size:`Uint8
@ -158,37 +158,37 @@ let canonical_encoding ~variant prim_encoding =
case (Tag 3)
~title:"Prim (no args, annot)"
(obj1 (req "prim" prim_encoding))
(function Prim (_, v, [], None) -> Some v
(function Prim (_, v, [], []) -> Some v
| _ -> None)
(fun v -> Prim (0, v, [], None)) ;
(* No args, with annot *)
(fun v -> Prim (0, v, [], [])) ;
(* No args, with annots *)
case (Tag 4)
~title:"Prim (no args + annot)"
(obj2 (req "prim" prim_encoding)
(req "annot" byte_string))
(req "annots" (list byte_string)))
(function
| Prim (_, v, [], Some annot) -> Some (v, annot)
| Prim (_, v, [], annots) -> Some (v, annots)
| _ -> None)
(function (prim, annot) -> Prim (0, prim, [], Some annot)) ;
(function (prim, annots) -> Prim (0, prim, [], annots)) ;
(* Single arg, no annot *)
case (Tag 5)
~title:"Prim (1 arg, no annot)"
(obj2 (req "prim" prim_encoding)
(req "arg" expr_encoding))
(function
| Prim (_, v, [ arg ], None) -> Some (v, arg)
| Prim (_, v, [ arg ], []) -> Some (v, arg)
| _ -> None)
(function (prim, arg) -> Prim (0, prim, [ arg ], None)) ;
(function (prim, arg) -> Prim (0, prim, [ arg ], [])) ;
(* Single arg, with annot *)
case (Tag 6)
~title:"Prim (1 arg + annot)"
(obj3 (req "prim" prim_encoding)
(req "arg" expr_encoding)
(req "annot" byte_string))
(req "annots" (list byte_string)))
(function
| Prim (_, prim, [ arg ], Some annot) -> Some (prim, arg, annot)
| Prim (_, prim, [ arg ], annots) -> Some (prim, arg, annots)
| _ -> None)
(fun (prim, arg, annot) -> Prim (0, prim, [ arg ], Some annot)) ;
(fun (prim, arg, annots) -> Prim (0, prim, [ arg ], annots)) ;
(* Two args, no annot *)
case (Tag 7)
~title:"Prim (2 args, no annot)"
@ -196,20 +196,20 @@ let canonical_encoding ~variant prim_encoding =
(req "arg1" expr_encoding)
(req "arg2" expr_encoding))
(function
| Prim (_, prim, [ arg1 ; arg2 ], None) -> Some (prim, arg1, arg2)
| Prim (_, prim, [ arg1 ; arg2 ], []) -> Some (prim, arg1, arg2)
| _ -> None)
(fun (prim, arg1, arg2) -> Prim (0, prim, [ arg1 ; arg2 ], None)) ;
(* Two args, with annot *)
(fun (prim, arg1, arg2) -> Prim (0, prim, [ arg1 ; arg2 ], [])) ;
(* Two args, with annots *)
case (Tag 8)
~title:"Prim (2 args + annot)"
(obj4 (req "prim" prim_encoding)
(req "arg1" expr_encoding)
(req "arg2" expr_encoding)
(req "annot" byte_string))
(req "annots" (list byte_string)))
(function
| Prim (_, prim, [ arg1 ; arg2 ], Some annot) -> Some (prim, arg1, arg2, annot)
| Prim (_, prim, [ arg1 ; arg2 ], annots) -> Some (prim, arg1, arg2, annots)
| _ -> None)
(fun (prim, arg1, arg2, annot) -> Prim (0, prim, [ arg1 ; arg2 ], Some annot)) ;
(fun (prim, arg1, arg2, annots) -> Prim (0, prim, [ arg1 ; arg2 ], annots)) ;
(* General case *)
application_encoding (Tag 9) expr_encoding ]))
in

8
src/lib_micheline/micheline.mli
View File

@ -13,8 +13,8 @@
type ('l, 'p) node =
| Int of 'l * Z.t
| String of 'l * string
| Prim of 'l * 'p * ('l, 'p) node list * string option
| Seq of 'l * ('l, 'p) node list * string option
| Prim of 'l * 'p * ('l, 'p) node list * string list
| Seq of 'l * ('l, 'p) node list
(** Encoding for expressions, as their {!canonical} encoding.
Locations are stored in a side table.
@ -33,8 +33,8 @@ val erased_encoding : variant:string ->
(** Extract the location of the node. *)
val location : ('l, 'p) node -> 'l
(** Extract the annotation of the node. *)
val annotation : ('l, 'p) node -> string option
(** Extract the annotations of the node. *)
val annotations : ('l, 'p) node -> string list
(** Expression form using canonical integer numbering as
locations. The root has number zero, and each node adds one in the

71
src/lib_micheline/micheline_parser.ml
View File

@ -152,7 +152,7 @@ let tokenize source =
| `Uchar c, start ->
begin match uchar_to_char c with
| Some ('a'..'z' | 'A'..'Z') -> ident acc start (fun s _ -> Ident s)
| Some '@' ->
| Some ('@' | ':' | '$' | '&' | '%' | '!' | '?') ->
ident acc start
(fun str stop ->
if String.length str > max_annot_length
@ -366,7 +366,7 @@ let min_point : node list -> point = function
| Int ({ start }, _) :: _
| String ({ start }, _) :: _
| Prim ({ start }, _, _, _) :: _
| Seq ({ start }, _, _) :: _ -> start
| Seq ({ start }, _) :: _ -> start
(* End of a sequence of consecutive primitives *)
let rec max_point : node list -> point = function
@ -375,7 +375,7 @@ let rec max_point : node list -> point = function
| Int ({ stop }, _) :: []
| String ({ stop }, _) :: []
| Prim ({ stop }, _, _, _) :: []
| Seq ({ stop }, _, _) :: [] -> stop
| Seq ({ stop }, _) :: [] -> stop
(* An item in the parser's state stack.
Not every value of type [mode list] is a valid parsing context.
@ -388,9 +388,9 @@ let rec max_point : node list -> point = function
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
| Sequence of token * node list
| Unwrapped of location * string * node list * string list
| Wrapped of token * string * node list * string list
(* Enter a new parsing state. *)
let push_mode mode stack =
@ -413,8 +413,8 @@ let fill_mode result = function
Expression (Some result) :: []
| Toplevel exprs :: [] ->
Toplevel (result :: exprs) :: []
| Sequence (token, exprs, annot) :: rest ->
Sequence (token, result :: exprs, annot) :: rest
| Sequence (token, exprs) :: rest ->
Sequence (token, result :: exprs) :: rest
| Wrapped (token, name, exprs, annot) :: rest ->
Wrapped (token, name, result :: exprs, annot) :: rest
| Unwrapped (start, name, exprs, annot) :: rest ->
@ -426,6 +426,12 @@ type error += Extra of token
type error += Misaligned of node
type error += Empty
let rec annots = function
| { token = Annot annot } :: rest ->
let annots, rest = annots rest in
annot :: annots, rest
| rest -> [], rest
let rec parse ?(check = true) errors tokens stack =
(* Two steps:
- 1. parse without checking indentation [parse]
@ -451,8 +457,8 @@ let rec parse ?(check = true) errors tokens stack =
| Expression None :: _, [] ->
let errors = Empty :: errors in
let ghost = { start = point_zero ; stop = point_zero} in
[ Seq (ghost, [], None) ], List.rev errors
| Toplevel [ Seq (_, exprs, _) as expr ] :: [],
[ Seq (ghost, []) ], List.rev errors
| Toplevel [ Seq (_, exprs) as expr ] :: [],
[] ->
let errors = if check then do_check ~toplevel: false errors expr else errors in
exprs, List.rev errors
@ -460,7 +466,7 @@ let rec parse ?(check = true) errors tokens stack =
[] ->
let exprs = List.rev exprs in
let loc = { start = min_point exprs ; stop = max_point exprs } in
let expr = Seq (loc, exprs, None) in
let expr = Seq (loc, exprs) in
let errors = if check then do_check ~toplevel: true errors expr else errors in
exprs, List.rev errors
(* Ignore comments *)
@ -517,19 +523,20 @@ let rec parse ?(check = true) errors tokens stack =
let fake = { token with token = Close_paren } in
let tokens = (* insert *) fake :: tokens in
parse ~check errors tokens stack
| (Sequence (token, _, _) :: _ | Unwrapped _ :: Sequence (token, _, _) :: _), [] ->
| (Sequence (token, _) :: _ | Unwrapped _ :: Sequence (token, _) :: _), [] ->
let errors = Unclosed token :: errors in
let fake = { token with token = Close_brace } in
let tokens = (* insert *) fake :: tokens in
parse ~check errors tokens stack
(* Valid states *)
| (Toplevel _ | Sequence (_, _, _)) :: _ ,
{ token = Ident name ; loc } :: { token = Annot annot } :: rest ->
let mode = Unwrapped (loc, name, [], Some annot) in
| (Toplevel _ | Sequence (_, _)) :: _ ,
{ token = Ident name ; loc } :: ({ token = Annot _ } :: _ as rest) ->
let annots, rest = annots rest in
let mode = Unwrapped (loc, name, [], annots) in
parse ~check errors rest (push_mode mode stack)
| (Expression None | Toplevel _ | Sequence (_, _, _)) :: _ ,
| (Expression None | Toplevel _ | Sequence (_, _)) :: _ ,
{ token = Ident name ; loc } :: rest ->
let mode = Unwrapped (loc, name, [], None) in
let mode = Unwrapped (loc, name, [], []) in
parse ~check errors rest (push_mode mode stack)
| (Unwrapped _ | Wrapped _) :: _,
{ token = Int value ; loc } :: rest
@ -545,10 +552,10 @@ let rec parse ?(check = true) errors tokens stack =
let expr : node = String (loc, contents) in
let errors = if check then do_check ~toplevel: false errors expr else errors in
parse ~check errors rest (fill_mode expr stack)
| Sequence ({ loc = { start } }, exprs, annot) :: _ ,
| Sequence ({ loc = { start } }, exprs) :: _ ,
{ token = Close_brace ; loc = { stop } } :: rest ->
let exprs = List.rev exprs in
let expr = Micheline.Seq ({ start ; stop }, exprs, annot) in
let expr = Micheline.Seq ({ start ; stop }, exprs) in
let errors = if check then do_check ~toplevel: false errors expr else errors in
parse ~check errors rest (fill_mode expr (pop_mode stack))
| (Sequence _ | Toplevel _) :: _ ,
@ -568,34 +575,31 @@ let rec parse ?(check = true) errors tokens stack =
let errors = if check then do_check ~toplevel: false errors expr else errors in
parse ~check errors 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
({ token = Open_paren } as token) :: { token = Ident name } :: ({ token = Annot _ } :: _ as rest) ->
let annots, rest = annots rest in
let mode = Wrapped (token, name, [], annots) in
parse ~check errors rest (push_mode mode stack)
| (Wrapped _ | Unwrapped _) :: _ ,
({ token = Open_paren } as token) :: { token = Ident name } :: rest ->
let mode = Wrapped (token, name, [], None) in
let mode = Wrapped (token, name, [], []) in
parse ~check errors rest (push_mode mode stack)
| (Wrapped _ | Unwrapped _) :: _ ,
{ token = Ident name ; loc } :: rest ->
let expr = Micheline.Prim (loc, name, [], None) in
let expr = Micheline.Prim (loc, name, [], []) in
let errors = if check then do_check ~toplevel: false errors expr else errors in
parse ~check errors rest (fill_mode expr stack)
| (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _ | Expression None) :: _ ,
({ token = Open_brace } as token) :: { token = Annot annot } :: rest ->
let mode = Sequence (token, [], Some annot) in
parse ~check errors rest (push_mode mode stack)
| (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _ | Expression None) :: _ ,
({ token = Open_brace } as token) :: rest ->
let mode = Sequence (token, [], None) in
let mode = Sequence (token, []) in
parse ~check errors rest (push_mode mode stack)
(* indentation checker *)
and do_check ?(toplevel = false) errors = function
| Seq ({ start ; stop }, [], _) as expr ->
| Seq ({ start ; stop }, []) as expr ->
if start.column >= stop.column then
Misaligned expr :: errors
else errors
| Prim ({ start ; stop }, _, first :: rest, _)
| Seq ({ start ; stop }, first :: rest, _) as expr ->
| Seq ({ start ; stop }, first :: rest) as expr ->
let { column = first_column ; line = first_line } =
min_point [ first ] in
if start.column >= stop.column then
@ -623,11 +627,12 @@ and do_check ?(toplevel = false) errors = function
let parse_expression ?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
| ({ token = Open_paren } as token) :: { token = Ident name } :: { token = Annot _ } :: rest ->
let annots, rest = annots rest in
let mode = Wrapped (token, name, [], annots) in
parse ?check [] rest [ mode ; Expression None ]
| ({ token = Open_paren } as token) :: { token = Ident name } :: rest ->
let mode = Wrapped (token, name, [], None) in
let mode = Wrapped (token, name, [], []) in
parse ?check [] rest [ mode ; Expression None ]
| _ ->
parse ?check [] tokens [ Expression None ] in

34
src/lib_micheline/micheline_printer.ml
View File

@ -42,9 +42,9 @@ let preformat root =
(false, 0)
| { comment = Some text } ->
(String.contains text '\n', String.length text + 1) in
let preformat_annot = function
| None -> 0
| Some annot -> String.length annot + 2 in
let preformat_annots = function
| [] -> 0
| annots -> String.length (String.concat " " annots) + 2 in
let rec preformat_expr = function
| Int (loc, value) ->
let cml, csz = preformat_loc loc in
@ -52,9 +52,9 @@ let preformat root =
| String (loc, value) ->
let cml, csz = preformat_loc loc in
String ((cml, String.length value + csz, loc), value)
| Prim (loc, name, items, annot) ->
| Prim (loc, name, items, annots) ->
let cml, csz = preformat_loc loc in
let asz = preformat_annot annot in
let asz = preformat_annots annots in
let items = List.map preformat_expr items in
let ml, sz =
List.fold_left
@ -63,26 +63,25 @@ let preformat root =
(tml || ml, tsz + 1 + sz))
(cml, String.length name + csz + asz)
items in
Prim ((ml, sz, loc), name, items, annot)
| Seq (loc, items, annot) ->
Prim ((ml, sz, loc), name, items, annots)
| Seq (loc, items) ->
let cml, csz = preformat_loc loc in
let asz = preformat_annot annot in
let items = List.map preformat_expr items in
let ml, sz =
List.fold_left
(fun (tml, tsz) e ->
let (ml, sz, _) = location e in
(tml || ml, tsz + 3 + sz))
(cml, 4 + csz + asz)
(cml, 4 + csz)
items in
Seq ((ml, sz, loc), items, annot) in
Seq ((ml, sz, loc), items) in
preformat_expr root
let rec print_expr_unwrapped ppf = function
| Prim ((ml, s, { comment }), name, args, annot) ->
let name = match annot with
| None -> name
| Some annot -> Format.asprintf "%s %s" name annot in
| [] -> name
| annots -> Format.asprintf "%s @[<h>%a@]" name (Format.pp_print_list Format.pp_print_string) annots in
if not ml && s < 80 then begin
if args = [] then
Format.fprintf ppf "%s" name
@ -114,18 +113,13 @@ let rec print_expr_unwrapped ppf = function
| None -> print_string ppf value
| Some comment -> Format.fprintf ppf "%a@ %a" print_string value print_comment comment
end
| Seq ((_, _, { comment = None }), [], None) ->
| Seq ((_, _, { comment = None }), []) ->
Format.fprintf ppf "{}"
| Seq ((ml, s, { comment }), items, annot) ->
| Seq ((ml, s, { comment }), items) ->
if not ml && s < 80 then
Format.fprintf ppf "{ @[<h 0>"
else
Format.fprintf ppf "{ @[<v 0>" ;
begin match annot, comment, items with
| None, _, _ -> ()
| Some annot, None, [] -> Format.fprintf ppf "%s" annot
| Some annot, _, _ -> Format.fprintf ppf "%s@ " annot
end ;
begin match comment, items with
| None, _ -> ()
| Some comment, [] -> Format.fprintf ppf "%a" print_comment comment
@ -139,7 +133,7 @@ let rec print_expr_unwrapped ppf = function
and print_expr ppf = function
| Prim (_, _, _ :: _, _)
| Prim (_, _, [], Some _) as expr ->
| Prim (_, _, [], _ :: _) as expr ->
Format.fprintf ppf "(%a)" print_expr_unwrapped expr
| expr -> print_expr_unwrapped ppf expr

6
src/lib_protocol_environment/sigs/v1/micheline.mli
View File

@ -10,8 +10,8 @@
type ('l, 'p) node =
| Int of 'l * Z.t
| String of 'l * string
| Prim of 'l * 'p * ('l, 'p) node list * string option
| Seq of 'l * ('l, 'p) node list * string option
| Prim of 'l * 'p * ('l, 'p) node list * string list
| Seq of 'l * ('l, 'p) node list
type 'p canonical
type canonical_location = int
@ -23,7 +23,7 @@ val erased_encoding : variant:string -> 'l -> 'p Data_encoding.encoding -> ('l,
val table_encoding : variant:string -> 'l Data_encoding.encoding -> 'p Data_encoding.encoding -> ('l, 'p) node Data_encoding.encoding
val location : ('l, 'p) node -> 'l
val annotation : ('l, 'p) node -> string option
val annotations : ('l, 'p) node -> string list
val strip_locations : (_, 'p) node -> 'p canonical
val extract_locations : ('l, 'p) node -> 'p canonical * (canonical_location * 'l) list

265
src/proto_alpha/lib_baking/test/test_michelson_parser.ml
View File

@ -115,80 +115,72 @@ let assert_expands original expanded =
ok ()
| errors -> Error errors
let left_branch = Seq(zero_loc, [ Prim(zero_loc, "SWAP", [], None) ], None)
let right_branch = Seq(zero_loc, [ ], None)
let left_branch = Seq(zero_loc, [ Prim(zero_loc, "SWAP", [], []) ])
let right_branch = Seq(zero_loc, [])
let test_expansion () =
assert_expands (Prim (zero_loc, "CAAR", [], None))
assert_expands (Prim (zero_loc, "CAAR", [], []))
(Seq (zero_loc,
[(Prim (zero_loc, "CAR", [], None));
(Prim (zero_loc, "CAR", [], None)) ],
None)) >>? fun () ->
assert_expands (Prim (zero_loc, "CAAR", [], Some "annot"))
[(Prim (zero_loc, "CAR", [], []));
(Prim (zero_loc, "CAR", [], [])) ])) >>? fun () ->
assert_expands (Prim (zero_loc, "CAAR", [], [ "annot" ]))
(Seq (zero_loc,
[(Prim (zero_loc, "CAR", [], None));
(Prim (zero_loc, "CAR", [], Some "annot")) ],
None)) >>? fun () ->
let car = Prim (zero_loc, "CAR", [], Some "annot") in
[(Prim (zero_loc, "CAR", [], []));
(Prim (zero_loc, "CAR", [], [ "annot" ])) ])) >>? fun () ->
let car = Prim (zero_loc, "CAR", [], [ "annot" ]) in
assert_expands car car >>? fun () ->
let arg = [ Seq (zero_loc, [ car ], None) ] in
let arg = [ Seq (zero_loc, [ car ]) ] in
assert_expands
(Prim (zero_loc, "DIP", arg, Some "new_annot"))
(Prim (zero_loc, "DIP", arg, Some "new_annot")) >>? fun () ->
(Prim (zero_loc, "DIP", arg, [ "new_annot" ]))
(Prim (zero_loc, "DIP", arg, [ "new_annot" ])) >>? fun () ->
assert_expands
(Prim (zero_loc, "DIIP", arg, None))
(Prim (zero_loc, "DIIP", arg, []))
(Seq (zero_loc,
[ Prim (zero_loc, "DIP",
[ (Seq (zero_loc,
[ Prim (zero_loc, "DIP", arg, None) ],
None)) ],
None) ],
None)) >>? fun () ->
[ Prim (zero_loc, "DIP", arg, []) ])) ],
[]) ])) >>? fun () ->
assert_expands
(Prim (zero_loc, "DIIIP", arg, None))
(Prim (zero_loc, "DIIIP", arg, []))
(Seq (zero_loc,
[ Prim (zero_loc, "DIP",
[ (Seq (zero_loc,
[ Prim (zero_loc,
"DIP",
[ (Seq (zero_loc,
[ Prim (zero_loc, "DIP", arg, None) ],
None)) ],
None) ],
None)) ],
None) ],
None)) >>? fun () ->
[ Prim (zero_loc, "DIP", arg, []) ])) ],
[]) ])) ],
[]) ])) >>? fun () ->
assert_expands
(Prim (zero_loc, "DUUP", [], None))
(Prim (zero_loc, "DUUP", [], []))
(Seq (zero_loc,
[ Prim (zero_loc, "DIP", [ Seq (zero_loc, [ Prim (zero_loc, "DUP", [], None) ], None) ], None) ;
Prim (zero_loc, "SWAP", [], None) ], None)) >>? fun () ->
[ Prim (zero_loc, "DIP", [ Seq (zero_loc, [ Prim (zero_loc, "DUP", [], []) ]) ], []) ;
Prim (zero_loc, "SWAP", [], []) ])) >>? fun () ->
assert_expands
(Prim (zero_loc, "DUUUP", [], None))
(Prim (zero_loc, "DUUUP", [], []))
(Seq (zero_loc,
[ Prim (zero_loc, "DIP",
[ Seq (zero_loc, [
Prim (zero_loc, "DIP", [
Seq (zero_loc, [ Prim (zero_loc, "DUP", [], None) ], None)],
None);
Prim (zero_loc, "SWAP", [], None) ],
None) ],
None) ;
Prim (zero_loc, "SWAP", [], None) ], None)) >>? fun () ->
Seq (zero_loc, [ Prim (zero_loc, "DUP", [], []) ])],
[]);
Prim (zero_loc, "SWAP", [], []) ]) ],
[]) ;
Prim (zero_loc, "SWAP", [], []) ])) >>? fun () ->
let assert_compare_macro prim_name compare_name =
assert_expands
(Prim (zero_loc, prim_name, [], None))
(Prim (zero_loc, prim_name, [], []))
(Seq (zero_loc,
[ Prim (zero_loc, "COMPARE", [], None) ;
Prim (zero_loc, compare_name, [], None) ], None)) in
[ Prim (zero_loc, "COMPARE", [], []) ;
Prim (zero_loc, compare_name, [], []) ])) in
let assert_compare_if_macro prim_name compare_name =
assert_expands
(Prim (zero_loc, prim_name,
[ left_branch ; right_branch ],
None))
(Seq (zero_loc, [ Prim(zero_loc, "COMPARE", [], None);
Prim(zero_loc, compare_name, [], None);
Prim (zero_loc, "IF", [ left_branch ; right_branch ], None) ], None)) in
[]))
(Seq (zero_loc, [ Prim(zero_loc, "COMPARE", [], []);
Prim(zero_loc, compare_name, [], []);
Prim (zero_loc, "IF", [ left_branch ; right_branch ], []) ])) in
assert_compare_macro "CMPEQ" "EQ" >>? fun () ->
assert_compare_macro "CMPNEQ" "NEQ" >>? fun () ->
assert_compare_macro "CMPLT" "LT" >>? fun () ->
@ -201,50 +193,41 @@ let test_expansion () =
assert_compare_if_macro "IFCMPLE" "LE" >>? fun () ->
assert_compare_if_macro "IFCMPGT" "GT" >>? fun () ->
assert_compare_if_macro "IFCMPGE" "GE" >>? fun () ->
assert_expands (Prim (zero_loc, "ASSERT_LEFT", [], None))
assert_expands (Prim (zero_loc, "ASSERT_LEFT", [], []))
(Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT",
[ Seq (zero_loc, [ ], None) ;
Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], None) ], None) ],
None) ], None)) >>? fun () ->
assert_expands (Prim (zero_loc, "ASSERT_RIGHT", [], None))
[ Seq (zero_loc, []) ;
Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], []) ]) ],
[]) ])) >>? fun () ->
assert_expands (Prim (zero_loc, "ASSERT_RIGHT", [], []))
(Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT",
[ Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], None) ], None) ;
Seq (zero_loc, [ ], None) ],
None) ], None)) >>? fun () ->
assert_expands (Prim (zero_loc, "IF_RIGHT", [ left_branch ; right_branch ], None))
(Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT", [ right_branch ; left_branch ], None) ], None)) >>? fun () ->
assert_expands (Prim (zero_loc, "IF_SOME", [ left_branch ; right_branch ], None))
(Seq (zero_loc, [ Prim (zero_loc, "IF_NONE", [ right_branch ; left_branch ], None) ], None)) >>? fun () ->
[ Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], []) ]) ;
Seq (zero_loc, []) ],
[]) ])) >>? fun () ->
assert_expands (Prim (zero_loc, "IF_RIGHT", [ left_branch ; right_branch ], []))
(Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT", [ right_branch ; left_branch ], []) ])) >>? fun () ->
assert_expands (Prim (zero_loc, "IF_SOME", [ left_branch ; right_branch ], []))
(Seq (zero_loc, [ Prim (zero_loc, "IF_NONE", [ right_branch ; left_branch ], []) ])) >>? fun () ->
assert_expands
(Prim (zero_loc, "PAIR", [], None))
(Prim (zero_loc, "PAIR", [], None)) >>? fun () ->
(Prim (zero_loc, "PAIR", [], []))
(Prim (zero_loc, "PAIR", [], [])) >>? fun () ->
assert_expands
(Prim (zero_loc, "PAAIR", [], None))
(Prim (zero_loc, "PAAIR", [], []))
(Seq (zero_loc,
[Prim
(zero_loc,
"DIP",
[Seq (zero_loc, [Prim
(zero_loc, "PAIR", [], None)],
None)],
None)],
None)) >>? fun () ->
[Seq (zero_loc, [Prim (zero_loc, "PAIR", [], [])])],
[])])) >>? fun () ->
assert_expands
(Prim (zero_loc, "PAAIAIR", [], None))
(Prim (zero_loc, "PAAIAIR", [], []))
(Seq (zero_loc, [Prim
(zero_loc,
"DIP",
[Seq
(zero_loc,
[Prim
(zero_loc,
"PAIR", [], None)],
None)],
None);
Prim
(zero_loc,
"PAIR", [], None)],
None))
[Prim (zero_loc, "PAIR", [], [])])],
[]);
Prim (zero_loc, "PAIR", [], [])]))
let assert_unexpansion_consistent original =
let { Michelson_v1_parser.expanded }, errors =
@ -259,30 +242,30 @@ let assert_unexpansion_consistent original =
ok ()
let test_unexpansion_consistency () =
assert_unexpansion_consistent (Prim (zero_loc, "PAAAIAIR", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "PAAAIAIR", [], [])) >>? fun () ->
assert_unexpansion_consistent
(Prim (zero_loc, "DIIIP", [ Seq (zero_loc, [ Prim (zero_loc, "DROP", [], None) ], None) ], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "SET_CAR", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "SET_CDR", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUP", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUUP", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUUUP", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUUUUP", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUUUUUP", [], None)) >>? fun () ->
(Prim (zero_loc, "DIIIP", [ Seq (zero_loc, [ Prim (zero_loc, "DROP", [], []) ]) ], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "SET_CAR", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "SET_CDR", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUP", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUUP", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUUUP", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUUUUP", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUUUUUP", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_EQ", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_NEQ", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LT", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LE", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_GT", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_GE", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_NONE", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_SOME", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LEFT", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_RIGHT", [], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_EQ", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_NEQ", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LT", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LE", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_GT", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_GE", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_NONE", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_SOME", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LEFT", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_RIGHT", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "IF_RIGHT", [ left_branch ; right_branch], None)) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "IF_SOME", [ left_branch ; right_branch], None))
assert_unexpansion_consistent (Prim (zero_loc, "IF_RIGHT", [ left_branch ; right_branch], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "IF_SOME", [ left_branch ; right_branch], []))
let test_lexing () =
let open Micheline_parser in
@ -329,96 +312,96 @@ let test_parsing () =
ok () in
assert_parses "PUSH int 100"
[ (Prim ((), "PUSH", [ Prim ((), "int", [], None) ;
Int ((), Z.of_int 100) ], None)) ] >>? fun () ->
[ (Prim ((), "PUSH", [ Prim ((), "int", [], []) ;
Int ((), Z.of_int 100) ], [])) ] >>? fun () ->
assert_parses "DROP" [ (Prim ((), "DROP", [], None)) ] >>? fun () ->
assert_parses "DROP" [ (Prim ((), "DROP", [], [])) ] >>? fun () ->
assert_parses "DIP{DROP}"
[ Prim ((), "DIP", [ Seq((), [ Prim ((), "DROP", [], None) ], None) ], None) ] >>? fun () ->
[ Prim ((), "DIP", [ Seq((), [ Prim ((), "DROP", [], []) ]) ], []) ] >>? fun () ->
assert_parses "LAMBDA int int {}"
[ Prim ((), "LAMBDA", [ Prim ((), "int", [], None) ;
Prim ((), "int", [], None) ;
Seq ((), [ ], None) ], None) ] >>? fun () ->
[ Prim ((), "LAMBDA", [ Prim ((), "int", [], []) ;
Prim ((), "int", [], []) ;
Seq ((), []) ], []) ] >>? fun () ->
assert_parses "LAMBDA @name int int {}"
[ Prim ((), "LAMBDA", [ Prim ((), "int", [], None) ;
Prim ((), "int", [], None) ;
Seq ((), [ ], None) ], Some "@name") ] >>? fun () ->
[ Prim ((), "LAMBDA", [ Prim ((), "int", [], []) ;
Prim ((), "int", [], []) ;
Seq ((), []) ], [ "@name" ]) ] >>? fun () ->
assert_parses "NIL @annot string; # comment\n"
[ Prim ((), "NIL", [ Prim ((), "string", [], None) ], Some "@annot") ] >>? fun () ->
[ Prim ((), "NIL", [ Prim ((), "string", [], []) ], [ "@annot" ]) ] >>? fun () ->
assert_parses "PUSH (pair bool string) (Pair False \"abc\")"
[ Prim ((), "PUSH", [ Prim ((), "pair",
[ Prim ((), "bool", [], None) ;
Prim ((), "string", [], None) ], None) ;
[ Prim ((), "bool", [], []) ;
Prim ((), "string", [], []) ], []) ;
Prim ((), "Pair",
[ Prim ((), "False", [], None) ;
String ((), "abc")], None) ], None) ] >>? fun () ->
[ Prim ((), "False", [], []) ;
String ((), "abc")], []) ], []) ] >>? fun () ->
assert_parses "PUSH (list nat) (List 1 2 3)"
[ Prim ((), "PUSH", [ Prim ((), "list",
[ Prim ((), "nat", [], None) ], None) ;
[ Prim ((), "nat", [], []) ], []) ;
Prim ((), "List",
[ Int((), Z.of_int 1);
Int ((), Z.of_int 2);
Int ((), Z.of_int 3)],
None) ], None) ] >>? fun () ->
[]) ], []) ] >>? fun () ->
assert_parses "PUSH (lambda nat nat) {}"
[ Prim ((), "PUSH", [ Prim ((), "lambda",
[ Prim ((), "nat", [], None);
Prim ((), "nat", [], None)], None) ;
Seq((), [], None)],
None) ] >>? fun () ->
[ Prim ((), "nat", [], []);
Prim ((), "nat", [], [])], []) ;
Seq((), [])],
[]) ] >>? fun () ->
assert_parses "PUSH key \"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx\""
[ Prim ((), "PUSH", [ Prim ((), "key", [], None) ;
[ Prim ((), "PUSH", [ Prim ((), "key", [], []) ;
String ((),"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") ],
None) ] >>? fun () ->
[]) ] >>? fun () ->
assert_parses "PUSH (map int bool) (Map (Item 100 False))"
[ Prim ((), "PUSH", [ Prim ((), "map",
[ Prim((), "int", [], None);
Prim((), "bool", [], None)], None) ;
[ Prim((), "int", [], []);
Prim((), "bool", [], [])], []) ;
Prim ((), "Map",
[Prim ((), "Item",
[Int ((), Z.of_int 100);
Prim ((), "False", [], None)], None)], None) ],
None) ] >>? fun () ->
Prim ((), "False", [], [])], [])], []) ],
[]) ] >>? fun () ->
assert_parses
"parameter int; \
return int; \
storage unit; \
code {}"
[ Prim ((), "parameter", [ Prim((), "int", [], None) ], None);
Prim ((), "return", [ Prim((), "int", [], None) ], None);
Prim ((), "storage", [ Prim((), "unit", [], None) ], None);
Prim ((), "code", [ Seq((), [], None) ], None)] >>? fun () ->
[ Prim ((), "parameter", [ Prim((), "int", [], []) ], []);
Prim ((), "return", [ Prim((), "int", [], []) ], []);
Prim ((), "storage", [ Prim((), "unit", [], []) ], []);
Prim ((), "code", [ Seq((), []) ], [])] >>? fun () ->
assert_parses
"parameter int; \
storage unit; \
return int; \
code {CAR; PUSH int 1; ADD; UNIT; SWAP; PAIR};"
[ Prim ((), "parameter", [ Prim((), "int", [], None) ], None);
Prim ((), "storage", [ Prim((), "unit", [], None) ], None);
Prim ((), "return", [ Prim((), "int", [], None) ], None);
Prim ((), "code", [ Seq((), [ Prim ((), "CAR", [], None) ;
Prim ((), "PUSH", [ Prim((), "int", [], None) ;
Int ((), Z.of_int 1)], None) ;
Prim ((), "ADD", [], None) ;
Prim ((), "UNIT", [], None) ;
Prim ((), "SWAP", [], None) ;
Prim ((), "PAIR", [], None)], None) ], None)] >>? fun () ->
[ Prim ((), "parameter", [ Prim((), "int", [], []) ], []);
Prim ((), "storage", [ Prim((), "unit", [], []) ], []);
Prim ((), "return", [ Prim((), "int", [], []) ], []);
Prim ((), "code", [ Seq((), [ Prim ((), "CAR", [], []) ;
Prim ((), "PUSH", [ Prim((), "int", [], []) ;
Int ((), Z.of_int 1)], []) ;
Prim ((), "ADD", [], []) ;
Prim ((), "UNIT", [], []) ;
Prim ((), "SWAP", [], []) ;
Prim ((), "PAIR", [], [])]) ], [])] >>? fun () ->
assert_parses
"code {DUP @test; DROP}"
[ Prim ((), "code", [Seq ((), [ Prim ((), "DUP", [], Some "@test");
Prim ((), "DROP", [], None)], None)], None) ] >>? fun () ->
[ Prim ((), "code", [Seq ((), [ Prim ((), "DUP", [], [ "@test" ]);
Prim ((), "DROP", [], [])])], []) ] >>? fun () ->
assert_parses
"IF {CAR} {CDR}"
[ Prim ((), "IF", [ Seq ((), [ Prim ((), "CAR", [], None) ], None);
Seq ((), [ Prim ((), "CDR", [], None) ], None) ], None) ] >>? fun () ->
[ Prim ((), "IF", [ Seq ((), [ Prim ((), "CAR", [], []) ]);
Seq ((), [ Prim ((), "CDR", [], []) ]) ], []) ] >>? fun () ->
assert_parses
"IF_NONE {FAIL} {}"
[ Prim ((), "IF_NONE", [ Seq ((), [ Prim ((), "FAIL", [], None) ], None);
Seq ((), [ ], None) ], None) ]
[ Prim ((), "IF_NONE", [ Seq ((), [ Prim ((), "FAIL", [], []) ]);
Seq ((), []) ], []) ]
let tests = [
"lexing", (fun _ -> Lwt.return (test_lexing ())) ;

15
src/proto_alpha/lib_client/michelson_v1_emacs.ml
View File

@ -13,17 +13,16 @@ open Micheline
let print_expr ppf expr =
let print_annot ppf = function
| None -> ()
| Some annot -> Format.fprintf ppf " %s" annot in
| [] -> ()
| annots -> Format.fprintf ppf " %s" (String.concat " " annots) in
let rec print_expr ppf = function
| Int (_, value) -> Format.fprintf ppf "%s" (Z.to_string value)
| String (_, value) -> Micheline_printer.print_string ppf value
| Seq (_, items, annot) ->
Format.fprintf ppf "(seq%a %a)"
print_annot annot
| Seq (_, items) ->
Format.fprintf ppf "(seq %a)"
(Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
items
| Prim (_, name, [], None) ->
| Prim (_, name, [], []) ->
Format.fprintf ppf "%s" name
| Prim (_, name, items, annot) ->
Format.fprintf ppf "(%s%a%s%a)"
@ -39,12 +38,12 @@ open Script_tc_errors
let print_type_map ppf (parsed, type_map) =
let rec print_expr_types ppf = function
| Seq (loc, [], _)
| Seq (loc, [])
| Prim (loc, _, [], _)
| Int (loc, _)
| String (loc, _) ->
print_item ppf loc
| Seq (loc, items, _)
| Seq (loc, items)
| Prim (loc, _, items, _) ->
print_item ppf loc ;
List.iter (print_expr_types ppf) items

31
src/proto_alpha/lib_client/michelson_v1_error_reporter.ml
View File

@ -148,7 +148,7 @@ let report_errors ~details ~show_source ?parsed ppf errs =
| Some s -> Format.fprintf ppf "%s " s)
name
print_source (parsed, hilights)
print_ty (None, ty) ;
print_ty ([], ty) ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace (parsed_locations parsed) rest
| Alpha_environment.Ecoproto_error (Ill_formed_type (_, expr, loc)) :: rest ->
@ -325,21 +325,21 @@ let report_errors ~details ~show_source ?parsed ppf errs =
@[<hov 2>and@ %a.@]@]"
print_loc loc
(Michelson_v1_primitives.string_of_prim name)
print_ty (None, tya)
print_ty (None, tyb)
print_ty ([], tya)
print_ty ([], tyb)
| Undefined_unop (loc, name, ty) ->
Format.fprintf ppf
"@[<hov 0>@[<hov 2>%aoperator %s is undefined on@ %a@]@]"
print_loc loc
(Michelson_v1_primitives.string_of_prim name)
print_ty (None, ty)
print_ty ([], ty)
| Bad_return (loc, got, exp) ->
Format.fprintf ppf
"@[<v 2>%awrong stack type at end of body:@,\
- @[<v 0>expected return stack type:@ %a,@]@,\
- @[<v 0>actual stack type:@ %a.@]@]"
print_loc loc
(fun ppf -> print_stack_ty ppf) (Item_t (exp, Empty_t, None))
(fun ppf -> print_stack_ty ppf) (Item_t (exp, Empty_t, []))
(fun ppf -> print_stack_ty ppf) got
| Bad_stack (loc, name, depth, sty) ->
Format.fprintf ppf
@ -358,17 +358,18 @@ let report_errors ~details ~show_source ?parsed ppf errs =
| Inconsistent_annotations (annot1, annot2) ->
Format.fprintf ppf
"@[<v 2>The two annotations do not match:@,\
- @[<hov>%s@]@,\
- @[<hov>%s@]"
annot1 annot2
- @[<v>%a@]@,\
- @[<v>%a@]@]"
(Format.pp_print_list Format.pp_print_string) annot1
(Format.pp_print_list Format.pp_print_string) annot2
| Inconsistent_type_annotations (loc, ty1, ty2) ->
Format.fprintf ppf
"@[<v 2>%athe two types contain incompatible annotations:@,\
- @[<hov>%a@]@,\
- @[<hov>%a@]"
- @[<hov>%a@]@]"
print_loc loc
print_ty (None, ty1)
print_ty (None, ty2)
print_ty ([], ty1)
print_ty ([], ty2)
| Unexpected_annotation loc ->
Format.fprintf ppf
"@[<v 2>%aunexpected annotation."
@ -395,7 +396,7 @@ let report_errors ~details ~show_source ?parsed ppf errs =
@[<hov 2>is invalid for type@ %a.@]@]"
print_loc loc
print_expr got
print_ty (None, exp)
print_ty ([], exp)
| Invalid_contract (loc, contract) ->
Format.fprintf ppf
"%ainvalid contract %a."
@ -404,13 +405,13 @@ let report_errors ~details ~show_source ?parsed ppf errs =
Format.fprintf ppf "%acomparable type expected."
print_loc loc ;
Format.fprintf ppf "@[<hov 0>@[<hov 2>Type@ %a@]@ is not comparable.@]"
print_ty (None, ty)
print_ty ([], ty)
| Inconsistent_types (tya, tyb) ->
Format.fprintf ppf
"@[<hov 0>@[<hov 2>Type@ %a@]@ \
@[<hov 2>is not compatible with type@ %a.@]@]"
print_ty (None, tya)
print_ty (None, tyb)
print_ty ([], tya)
print_ty ([], tyb)
| Reject loc ->
Format.fprintf ppf "%ascript reached FAIL instruction"
print_loc loc

563
src/proto_alpha/lib_client/michelson_v1_macros.ml
View File

@ -32,16 +32,16 @@ let expand_caddadr original =
| [] -> ok ()
| _ :: _ -> error (Invalid_arity (str, List.length args, 0))
end >>? fun () ->
let rec parse i ?annot acc =
let rec parse i annot acc =
if i = 0 then
Seq (loc, acc, None)
Seq (loc, acc)
else
let annot = if i = (String.length str - 2) then annot else None in
let annot = if i = (String.length str - 2) then annot else [] in
match String.get str i with
| 'A' -> parse (i - 1) (Prim (loc, "CAR", [], annot) :: acc)
| 'D' -> parse (i - 1) (Prim (loc, "CDR", [], annot) :: acc)
| 'A' -> parse (i - 1) [] (Prim (loc, "CAR", [], annot) :: acc)
| 'D' -> parse (i - 1) [] (Prim (loc, "CDR", [], annot) :: acc)
| _ -> assert false in
ok (Some (parse (len - 2) ?annot []))
ok (Some (parse (len - 2) annot []))
else
ok None
| _ -> ok None
@ -67,45 +67,45 @@ let expand_set_caddadr original =
| 'A' ->
let acc =
Seq (loc,
[ Prim (loc, "DUP", [], None) ;
[ Prim (loc, "DUP", [], []) ;
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
[ Prim (loc, "CAR", [], []) ;
acc ]) ], []) ;
Prim (loc, "CDR", [], []) ;
Prim (loc, "SWAP", [], []) ;
Prim (loc, "PAIR", [], []) ]) in
parse (i - 1) acc
| 'D' ->
let acc =
Seq (loc,
[ Prim (loc, "DUP", [], None) ;
[ Prim (loc, "DUP", [], []) ;
Prim (loc, "DIP",
[ Seq (loc,
[ Prim (loc, "CDR", [], None) ;
acc ], None) ], None) ;
Prim (loc, "CAR", [], None) ;
Prim (loc, "PAIR", [], None) ], None) in
[ Prim (loc, "CDR", [], []) ;
acc ]) ], []) ;
Prim (loc, "CAR", [], []) ;
Prim (loc, "PAIR", [], []) ]) in
parse (i - 1) acc
| _ -> assert false in
match String.get str (len - 2) with
| 'A' ->
let init =
Seq (loc,
[ Prim (loc, "CDR", [], None) ;
[ Prim (loc, "CDR", [], []) ;
Prim (loc, "SWAP", [], annot) ;
Prim (loc, "PAIR", [], None) ], None) in
Prim (loc, "PAIR", [], []) ]) in
ok (Some (parse (len - 3) init))
| 'D' ->
let init =
Seq (loc,
(Prim (loc, "CAR", [], None)) ::
(let pair = Prim (loc, "PAIR", [], None) in
(Prim (loc, "CAR", [], [])) ::
(let pair = Prim (loc, "PAIR", [], []) in
match annot with
| None -> [ pair ]
| Some _ -> [ Prim (loc, "SWAP", [], annot) ;
Prim (loc, "SWAP", [], None) ;
pair]), None) in
| [] -> [ pair ]
| _ -> [ Prim (loc, "SWAP", [], annot) ;
Prim (loc, "SWAP", [], []) ;
pair])) in
ok (Some (parse (len - 3) init))
| _ -> assert false
else
@ -122,8 +122,8 @@ let expand_map_caddadr original =
&& check_letters str 5 (len - 2)
(function 'A' | 'D' -> true | _ -> false) then
begin match annot with
| Some _ -> (error (Unexpected_macro_annotation str))
| None -> ok ()
| _ :: _ -> (error (Unexpected_macro_annotation str))
| [] -> ok ()
end >>? fun () ->
begin match args with
| [ Seq _ as code ] -> ok code
@ -138,47 +138,47 @@ let expand_map_caddadr original =
| 'A' ->
let acc =
Seq (loc,
[ Prim (loc, "DUP", [], None) ;
[ Prim (loc, "DUP", [], []) ;
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
[ Prim (loc, "CAR", [], []) ;
acc ]) ], []) ;
Prim (loc, "CDR", [], []) ;
Prim (loc, "SWAP", [], []) ;
Prim (loc, "PAIR", [], []) ]) in
parse (i - 1) acc
| 'D' ->
let acc =
Seq (loc,
[ Prim (loc, "DUP", [], None) ;
[ Prim (loc, "DUP", [], []) ;
Prim (loc, "DIP",
[ Seq (loc,
[ Prim (loc, "CDR", [], None) ;
acc ], None) ], None) ;
Prim (loc, "CAR", [], None) ;
Prim (loc, "PAIR", [], None) ], None) in
[ Prim (loc, "CDR", [], []) ;
acc ]) ], []) ;
Prim (loc, "CAR", [], []) ;
Prim (loc, "PAIR", [], []) ]) in
parse (i - 1) acc
| _ -> assert false in
match String.get str (len - 2) with
| 'A' ->
let init =
Seq (loc,
[ Prim (loc, "DUP", [], None) ;
Prim (loc, "CDR", [], None) ;
[ Prim (loc, "DUP", [], []) ;
Prim (loc, "CDR", [], []) ;
Prim (loc, "DIP",
[ Seq (loc, [ Prim (loc, "CAR", [], None) ; code ], None) ], None) ;
Prim (loc, "SWAP", [], None) ;
Prim (loc, "PAIR", [], None) ], None) in
[ Seq (loc, [ Prim (loc, "CAR", [], []) ; code ]) ], []) ;
Prim (loc, "SWAP", [], []) ;
Prim (loc, "PAIR", [], []) ]) in
ok (Some (parse (len - 3) init))
| 'D' ->
let init =
Seq (loc,
[ Prim (loc, "DUP", [], None) ;
Prim (loc, "CDR", [], None) ;
[ Prim (loc, "DUP", [], []) ;
Prim (loc, "CDR", [], []) ;
code ;
Prim (loc, "SWAP", [], None) ;
Prim (loc, "CAR", [], None) ;
Prim (loc, "PAIR", [], None) ], None) in
Prim (loc, "SWAP", [], []) ;
Prim (loc, "CAR", [], []) ;
Prim (loc, "PAIR", [], []) ]) in
ok (Some (parse (len - 3) init))
| _ -> assert false
else
@ -224,9 +224,9 @@ let expand_dxiiivp original =
acc
else
make (i - 1)
(Seq (loc, [ Prim (loc, "DIP", [ acc ], annot) ], None)) in
(Seq (loc, [ Prim (loc, "DIP", [ acc ], annot) ])) in
match args with
| [ Seq (_, _, _) as arg ] -> ok @@ Some (make depth arg)
| [ Seq (_, _) as arg ] -> ok @@ Some (make depth arg)
| [ _ ] -> error (Sequence_expected str)
| [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))
with Not_a_roman -> ok None
@ -250,14 +250,14 @@ let expand_paaiair original =
acc
else if String.get str i = 'I'
&& String.get str (i - 1) = 'A' then
parse (i - 2) (Prim (loc, "PAIR", [], if i = (len - 2) then annot else None) :: acc)
parse (i - 2) (Prim (loc, "PAIR", [], if i = (len - 2) then annot else []) :: acc)
else if String.get str i = 'A' then
match acc with
| [] ->
raise_notrace Not_a_pair
| acc :: accs ->
parse (i - 1)
(Prim (loc, "DIP", [ Seq (loc, [ acc ], None) ], None)
(Prim (loc, "DIP", [ Seq (loc, [ acc ]) ], [])
:: accs)
else
raise_notrace Not_a_pair in
@ -266,7 +266,7 @@ let expand_paaiair original =
| [] -> ok ()
| _ :: _ -> error (Invalid_arity (str, List.length args, 0))
end >>? fun () ->
ok (Some (Seq (loc, expanded, None)))
ok (Some (Seq (loc, expanded)))
with Not_a_pair -> ok None
else
ok None
@ -274,7 +274,7 @@ let expand_paaiair original =
let expand_unpaaiair original =
match original with
| Prim (loc, str, args, None) ->
| Prim (loc, str, args, []) ->
let len = String.length str in
if len >= 6
&& String.sub str 0 3 = "UNP"
@ -286,16 +286,15 @@ let expand_unpaaiair original =
if i = 2 then
match acc with
| [ Seq _ as acc ] -> acc
| _ -> Seq (loc, List.rev acc, None)
| _ -> Seq (loc, List.rev acc)
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) ;
(Seq (loc, [ Prim (loc, "DUP", [], []) ;
Prim (loc, "CAR", [], []) ;
Prim (loc, "DIP",
[ Seq (loc,
[ Prim (loc, "CDR", [], None) ],
None) ], None) ], None)
[ Prim (loc, "CDR", [], []) ]) ], []) ])
:: acc)
else if String.get str i = 'A' then
match acc with
@ -303,12 +302,12 @@ let expand_unpaaiair original =
raise_notrace Not_a_pair
| (Seq _ as acc) :: accs ->
parse (i - 1)
(Prim (loc, "DIP", [ acc ], None) :: accs)
(Prim (loc, "DIP", [ acc ], []) :: accs)
| acc :: accs ->
parse (i - 1)
(Prim (loc, "DIP",
[ Seq (loc, [ acc ], None) ],
None) :: accs)
[ Seq (loc, [ acc ]) ],
[]) :: accs)
else
raise_notrace Not_a_pair in
let expanded = parse (len - 2) [] in
@ -341,11 +340,11 @@ let expand_duuuuup original =
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))
(Seq (loc, [ Prim (loc, "DIP", [ acc ], []) ;
Prim (loc, "SWAP", [], []) ]))
else
raise_notrace Not_a_dup in
ok (Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", [], annot) ], None))))
ok (Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", [], annot) ]))))
with Not_a_dup -> ok None
else
ok None
@ -354,88 +353,88 @@ let expand_duuuuup original =
let expand_compare original =
let cmp loc is =
let is =
List.map (fun i -> Prim (loc, i, [], None)) is in
ok (Some (Seq (loc, is, None))) in
List.map (fun i -> Prim (loc, i, [], [])) is in
ok (Some (Seq (loc, is))) in
let ifcmp loc is l r =
let is =
List.map (fun i -> Prim (loc, i, [], None)) is @
[ Prim (loc, "IF", [ l ; r ], None) ] in
ok (Some (Seq (loc, is, None))) in
List.map (fun i -> Prim (loc, i, [], [])) is @
[ Prim (loc, "IF", [ l ; r ], []) ] in
ok (Some (Seq (loc, is))) in
match original with
| Prim (loc, "CMPEQ", [], None) ->
| Prim (loc, "CMPEQ", [], []) ->
cmp loc [ "COMPARE" ; "EQ" ]
| Prim (loc, "CMPNEQ", [], None) ->
| Prim (loc, "CMPNEQ", [], []) ->
cmp loc [ "COMPARE" ; "NEQ" ]
| Prim (loc, "CMPLT", [], None) ->
| Prim (loc, "CMPLT", [], []) ->
cmp loc [ "COMPARE" ; "LT" ]
| Prim (loc, "CMPGT", [], None) ->
| Prim (loc, "CMPGT", [], []) ->
cmp loc [ "COMPARE" ; "GT" ]
| Prim (loc, "CMPLE", [], None) ->
| Prim (loc, "CMPLE", [], []) ->
cmp loc [ "COMPARE" ; "LE" ]
| Prim (loc, "CMPGE", [], None) ->
| Prim (loc, "CMPGE", [], []) ->
cmp loc [ "COMPARE" ; "GE" ]
| Prim (_, ("CMPEQ" | "CMPNEQ" | "CMPLT"
| "CMPGT" | "CMPLE" | "CMPGE" as str), args, None) ->
| "CMPGT" | "CMPLE" | "CMPGE" as str), args, []) ->
error (Invalid_arity (str, List.length args, 0))
| Prim (loc, "IFCMPEQ", [ l ; r ], None) ->
| Prim (loc, "IFCMPEQ", [ l ; r ], []) ->
ifcmp loc [ "COMPARE" ; "EQ" ] l r
| Prim (loc, "IFCMPNEQ", [ l ; r ], None) ->
| Prim (loc, "IFCMPNEQ", [ l ; r ], []) ->
ifcmp loc [ "COMPARE" ; "NEQ" ] l r
| Prim (loc, "IFCMPLT", [ l ; r ], None) ->
| Prim (loc, "IFCMPLT", [ l ; r ], []) ->
ifcmp loc [ "COMPARE" ; "LT" ] l r
| Prim (loc, "IFCMPGT", [ l ; r ], None) ->
| Prim (loc, "IFCMPGT", [ l ; r ], []) ->
ifcmp loc [ "COMPARE" ; "GT" ] l r
| Prim (loc, "IFCMPLE", [ l ; r ], None) ->
| Prim (loc, "IFCMPLE", [ l ; r ], []) ->
ifcmp loc [ "COMPARE" ; "LE" ] l r
| Prim (loc, "IFCMPGE", [ l ; r ], None) ->
| Prim (loc, "IFCMPGE", [ l ; r ], []) ->
ifcmp loc [ "COMPARE" ; "GE" ] l r
| Prim (loc, "IFEQ", [ l ; r ], None) ->
| Prim (loc, "IFEQ", [ l ; r ], []) ->
ifcmp loc [ "EQ" ] l r
| Prim (loc, "IFNEQ", [ l ; r ], None) ->
| Prim (loc, "IFNEQ", [ l ; r ], []) ->
ifcmp loc [ "NEQ" ] l r
| Prim (loc, "IFLT", [ l ; r ], None) ->
| Prim (loc, "IFLT", [ l ; r ], []) ->
ifcmp loc [ "LT" ] l r
| Prim (loc, "IFGT", [ l ; r ], None) ->
| Prim (loc, "IFGT", [ l ; r ], []) ->
ifcmp loc [ "GT" ] l r
| Prim (loc, "IFLE", [ l ; r ], None) ->
| Prim (loc, "IFLE", [ l ; r ], []) ->
ifcmp loc [ "LE" ] l r
| Prim (loc, "IFGE", [ l ; r ], None) ->
| Prim (loc, "IFGE", [ l ; r ], []) ->
ifcmp loc [ "GE" ] l r
| Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT"
| "IFCMPGT" | "IFCMPLE" | "IFCMPGE"
| "IFEQ" | "IFNEQ" | "IFLT"
| "IFGT" | "IFLE" | "IFGE" as str), args, None) ->
| "IFGT" | "IFLE" | "IFGE" as str), args, []) ->
error (Invalid_arity (str, List.length args, 2))
| Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT"
| "IFCMPGT" | "IFCMPLE" | "IFCMPGE"
| "IFEQ" | "IFNEQ" | "IFLT"
| "IFGT" | "IFLE" | "IFGE"
| "CMPEQ" | "CMPNEQ" | "CMPLT"
| "CMPGT" | "CMPLE" | "CMPGE" as str), [], Some _) ->
| "CMPGT" | "CMPLE" | "CMPGE" as str), [], _ :: _) ->
error (Unexpected_macro_annotation str)
| _ -> ok None
let expand_asserts original =
let fail_false loc =
[ Seq(loc, [], None) ; Seq(loc, [ Prim (loc, "FAIL", [], None) ], None) ] in
[ Seq(loc, []) ; Seq(loc, [ Prim (loc, "FAIL", [], []) ]) ] in
let fail_true loc =
[ Seq(loc, [ Prim (loc, "FAIL", [], None) ], None) ; Seq(loc, [], None) ] in
[ Seq(loc, [ Prim (loc, "FAIL", [], []) ]) ; Seq(loc, []) ] in
match original with
| Prim (loc, "ASSERT", [], None) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF", fail_false loc, None) ], None))
| Prim (loc, "ASSERT_NONE", [], None) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_false loc, None) ], None))
| Prim (loc, "ASSERT_SOME", [], None) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_true loc, None) ], None))
| Prim (loc, "ASSERT_LEFT", [], None) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_false loc, None) ], None))
| Prim (loc, "ASSERT_RIGHT", [], None) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_true loc, None) ], None))
| Prim (loc, "ASSERT", [], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF", fail_false loc, []) ]))
| Prim (loc, "ASSERT_NONE", [], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_false loc, []) ]))
| Prim (loc, "ASSERT_SOME", [], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_true loc, []) ]))
| Prim (loc, "ASSERT_LEFT", [], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_false loc, []) ]))
| Prim (loc, "ASSERT_RIGHT", [], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_true loc, []) ]))
| Prim (_, ("ASSERT" | "ASSERT_NONE" | "ASSERT_SOME"
| "ASSERT_LEFT" | "ASSERT_RIGHT" as str), args, None) ->
| "ASSERT_LEFT" | "ASSERT_RIGHT" as str), args, []) ->
error (Invalid_arity (str, List.length args, 0))
| Prim (_, ("ASSERT" | "ASSERT_NONE" | "ASSERT_SOME"
| "ASSERT_LEFT" | "ASSERT_RIGHT" as str), [], Some _) ->
| "ASSERT_LEFT" | "ASSERT_RIGHT" as str), [], _ :: _) ->
error (Unexpected_macro_annotation str)
| Prim (loc, s, args, annot)
when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") ->
@ -444,42 +443,42 @@ let expand_asserts original =
| _ :: _ -> error (Invalid_arity (s, List.length args, 0))
end >>? fun () ->
begin match annot with
| Some _ -> (error (Unexpected_macro_annotation s))
| None -> ok () end >>? fun () ->
| _ :: _ -> (error (Unexpected_macro_annotation s))
| [] -> ok () end >>? fun () ->
begin
let remaining = String.(sub s 7 ((length s) - 7)) in
let remaining_prim = Prim(loc, remaining, [], None) in
let remaining_prim = Prim (loc, remaining, [], []) in
match remaining with
| "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" ->
ok @@ Some (Seq (loc, [ remaining_prim ;
Prim (loc, "IF", fail_false loc, None) ], None))
Prim (loc, "IF", fail_false loc, []) ]))
| _ ->
begin
expand_compare remaining_prim >|? function
| None -> None
| Some seq ->
Some (Seq (loc, [ seq ;
Prim (loc, "IF", fail_false loc, None) ], None))
Prim (loc, "IF", fail_false loc, []) ]))
end
end
| _ -> ok None
let expand_if_some = function
| Prim (loc, "IF_SOME", [ right ; left ], None) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", [ left ; right ], None) ], None))
| Prim (_, "IF_SOME", args, None) ->
| Prim (loc, "IF_SOME", [ right ; left ], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", [ left ; right ], []) ]))
| Prim (_, "IF_SOME", args, []) ->
error (Invalid_arity ("IF_SOME", List.length args, 2))
| Prim (_, "IF_SOME", [], Some _) ->
| Prim (_, "IF_SOME", [], _ :: _) ->
error (Unexpected_macro_annotation "IF_SOME")
| _ -> ok @@ None
let expand_if_right = function
| Prim (loc, "IF_RIGHT", [ right ; left ], None) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", [ left ; right ], None) ], None))
| Prim (_, "IF_RIGHT", args, None) ->
| Prim (loc, "IF_RIGHT", [ right ; left ], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", [ left ; right ], []) ]))
| Prim (_, "IF_RIGHT", args, []) ->
error (Invalid_arity ("IF_RIGHT", List.length args, 2))
| Prim (_, "IF_RIGHT", [], Some _) ->
| Prim (_, "IF_RIGHT", [], _ :: _) ->
error (Unexpected_macro_annotation "IF_RIGHT")
| _ -> ok @@ None
@ -517,9 +516,9 @@ let expand_rec expr =
| Ok expanded ->
begin
match expanded with
| Seq (loc, items, annot) ->
| Seq (loc, items) ->
let items, errors = error_map expand_rec items in
(Seq (loc, items, annot), errors)
(Seq (loc, items), errors)
| Prim (loc, name, args, annot) ->
let args, errors = error_map expand_rec args in
(Prim (loc, name, args, annot), errors)
@ -530,18 +529,18 @@ let expand_rec expr =
let unexpand_caddadr expanded =
let rec rsteps acc = function
| [] -> Some acc
| Prim (_, "CAR" , [], None) :: rest ->
| Prim (_, "CAR" , [], []) :: rest ->
rsteps ("A" :: acc) rest
| Prim (_, "CDR" , [], None) :: rest ->
| Prim (_, "CDR" , [], []) :: 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) ->
| Seq (loc, (Prim (_, "CAR" , [], []) :: _ as nodes))
| Seq (loc, (Prim (_, "CDR" , [], []) :: _ as nodes)) ->
begin match rsteps [] nodes with
| Some steps ->
let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in
Some (Prim (loc, name, [], None))
Some (Prim (loc, name, [], []))
| None -> None
end
| _ -> None
@ -549,82 +548,82 @@ let unexpand_caddadr expanded =
let unexpand_set_caddadr expanded =
let rec steps acc = function
| Seq (loc,
[ Prim (_, "CDR", [], None) ;
Prim (_, "SWAP", [], None) ;
Prim (_, "PAIR", [], None) ], None) ->
[ Prim (_, "CDR", [], []) ;
Prim (_, "SWAP", [], []) ;
Prim (_, "PAIR", [], []) ]) ->
Some (loc, "A" :: acc)
| Seq (loc,
[ Prim (_, "CAR", [], None) ;
Prim (_, "PAIR", [], None) ], None) ->
[ Prim (_, "CAR", [], []) ;
Prim (_, "PAIR", [], []) ]) ->
Some (loc, "D" :: acc)
| Seq (_,
[ Prim (_, "DUP", [], None) ;
[ Prim (_, "DUP", [], []) ;
Prim (_, "DIP",
[ Seq (_,
[ Prim (_, "CAR", [], None) ;
sub ], None) ], None) ;
Prim (_, "CDR", [], None) ;
Prim (_, "SWAP", [], None) ;
Prim (_, "PAIR", [], None) ], None) ->
[ Prim (_, "CAR", [], []) ;
sub ]) ], []) ;
Prim (_, "CDR", [], []) ;
Prim (_, "SWAP", [], []) ;
Prim (_, "PAIR", [], []) ]) ->
steps ("A" :: acc) sub
| Seq (_,
[ Prim (_, "DUP", [], None) ;
[ Prim (_, "DUP", [], []) ;
Prim (_, "DIP",
[ Seq (_,
[ Prim (_, "CDR", [], None) ;
sub ], None) ], None) ;
Prim (_, "CAR", [], None) ;
Prim (_, "PAIR", [], None) ], None) ->
[ Prim (_, "CDR", [], []) ;
sub ]) ], []) ;
Prim (_, "CAR", [], []) ;
Prim (_, "PAIR", [], []) ]) ->
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))
Some (Prim (loc, name, [], []))
| 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) ;
[ Prim (_, "DUP", [], []) ;
Prim (_, "CDR", [], []) ;
Prim (_, "SWAP", [], []) ;
Prim (_, "CAR", [], []) ;
code ;
Prim (_, "PAIR", [], None) ], None) ->
Prim (_, "PAIR", [], []) ]) ->
Some (loc, "A" :: acc, code)
| Seq (loc,
[ Prim (_, "DUP", [], None) ;
Prim (_, "CDR", [], None) ;
[ Prim (_, "DUP", [], []) ;
Prim (_, "CDR", [], []) ;
code ;
Prim (_, "SWAP", [], None) ;
Prim (_, "CAR", [], None) ;
Prim (_, "PAIR", [], None) ], None) ->
Prim (_, "SWAP", [], []) ;
Prim (_, "CAR", [], []) ;
Prim (_, "PAIR", [], []) ]) ->
Some (loc, "D" :: acc, code)
| Seq (_,
[ Prim (_, "DUP", [], None) ;
[ Prim (_, "DUP", [], []) ;
Prim (_, "DIP",
[ Seq (_,
[ Prim (_, "CAR", [], None) ;
sub ], None) ], None) ;
Prim (_, "CDR", [], None) ;
Prim (_, "SWAP", [], None) ;
Prim (_, "PAIR", [], None) ], None) ->
[ Prim (_, "CAR", [], []) ;
sub ]) ], []) ;
Prim (_, "CDR", [], []) ;
Prim (_, "SWAP", [], []) ;
Prim (_, "PAIR", [], []) ]) ->
steps ("A" :: acc) sub
| Seq (_,
[ Prim (_, "DUP", [], None) ;
[ Prim (_, "DUP", [], []) ;
Prim (_, "DIP",
[ Seq (_,
[ Prim (_, "CDR", [], None) ;
sub ], None) ], None) ;
Prim (_, "CAR", [], None) ;
Prim (_, "PAIR", [], None) ], None) ->
[ Prim (_, "CDR", [], []) ;
sub ]) ], []) ;
Prim (_, "CAR", [], []) ;
Prim (_, "PAIR", [], []) ]) ->
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))
Some (Prim (loc, name, [ code ], []))
| None -> None
let roman_of_decimal decimal =
@ -658,23 +657,22 @@ let unexpand_dxiiivp expanded =
match expanded with
| Seq (loc,
[ Prim (_, "DIP",
[ Seq (_, [ Prim (_, "DIP", [ _ ], None) ], None) as sub ],
None) ],
None) ->
[ Seq (_, [ Prim (_, "DIP", [ _ ], []) ]) as sub ],
[]) ]) ->
let rec count acc = function
| Seq (_, [ Prim (_, "DIP", [ sub ], None) ], None) -> count (acc + 1) sub
| Seq (_, [ Prim (_, "DIP", [ sub ], []) ]) -> 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))
Some (Prim (loc, name, [ sub ], []))
| _ -> None
let unexpand_duuuuup expanded =
let rec help expanded =
match expanded with
| Seq (loc, [ Prim (_, "DUP", [], None) ], None) -> Some (loc, 1)
| Seq (_, [ Prim (_, "DIP", [expanded'], None);
Prim (_, "SWAP", [], None) ], None) ->
| Seq (loc, [ Prim (_, "DUP", [], []) ]) -> Some (loc, 1)
| Seq (_, [ Prim (_, "DIP", [expanded'], []);
Prim (_, "SWAP", [], []) ]) ->
begin
match help expanded' with
| None -> None
@ -686,158 +684,157 @@ let unexpand_duuuuup expanded =
| n -> "U" ^ (dupn (n - 1)) in
match help expanded with
| None -> None
| Some (loc, n) -> Some (Prim (loc, "D" ^ (dupn n), [], None))
| Some (loc, n) -> Some (Prim (loc, "D" ^ (dupn n), [], []))
let unexpand_paaiair expanded =
match expanded with
| Seq (_, [ Prim (_, "PAIR", [], None) ], None) -> Some expanded
| Seq (loc, (_ :: _ as nodes), None) ->
| Seq (_, [ Prim (_, "PAIR", [], []) ]) -> Some expanded
| Seq (loc, (_ :: _ as nodes)) ->
let rec destruct acc = function
| [] -> Some acc
| Prim (_, "DIP", [ Seq (_, [ sub ], None) ], None) :: rest ->
| Prim (_, "DIP", [ Seq (_, [ sub ]) ], []) :: rest ->
destruct ("A" :: acc) (sub :: rest)
| Prim (_, "PAIR", [], None) :: rest ->
| Prim (_, "PAIR", [], []) :: 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))
Some (Prim (loc, name, [], []))
end
| _ -> None
let unexpand_unpaaiair expanded =
match expanded with
| Seq (loc, (_ :: _ as nodes), None) ->
| Seq (loc, (_ :: _ as nodes)) ->
let rec destruct sacc acc = function
| [] -> Some acc
| Prim (_, "DIP", [ Seq (_, [ sub ], None) ], None) :: rest
| Prim (_, "DIP", [ Seq (_, _, _) as sub ], None) :: rest ->
| Prim (_, "DIP", [ Seq (_, [ sub ]) ], []) :: rest
| Prim (_, "DIP", [ Seq (_, _) as sub ], []) :: rest ->
destruct ("A" :: sacc) acc (sub :: rest)
| Seq (_, [ Prim (_, "DUP", [], None) ;
Prim (_, "CAR", [], None) ;
| Seq (_, [ Prim (_, "DUP", [], []) ;
Prim (_, "CAR", [], []) ;
Prim (_, "DIP",
[ Seq (_,
[ Prim (_, "CDR", [], None) ], None) ],
None) ], None) :: rest ->
[ Seq (_, [ Prim (_, "CDR", [], []) ]) ],
[]) ]) :: 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))
Some (Prim (loc, name, [], []))
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))
| Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "EQ", [], []) ]) ->
Some (Prim (loc, "CMPEQ", [], []))
| Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "NEQ", [], []) ]) ->
Some (Prim (loc, "CMPNEQ", [], []))
| Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "LT", [], []) ]) ->
Some (Prim (loc, "CMPLT", [], []))
| Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "GT", [], []) ]) ->
Some (Prim (loc, "CMPGT", [], []))
| Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "LE", [], []) ]) ->
Some (Prim (loc, "CMPLE", [], []))
| Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "GE", [], []) ]) ->
Some (Prim (loc, "CMPGE", [], []))
| Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "EQ", [], []) ;
Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFCMPEQ", args, []))
| Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "NEQ", [], []) ;
Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFCMPNEQ", args, []))
| Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "LT", [], []) ;
Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFCMPLT", args, []))
| Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "GT", [], []) ;
Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFCMPGT", args, []))
| Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "LE", [], []) ;
Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFCMPLE", args, []))
| Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "GE", [], []) ;
Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFCMPGE", args, []))
| Seq (loc, [ Prim (_, "EQ", [], []) ;
Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFEQ", args, []))
| Seq (loc, [ Prim (_, "NEQ", [], []) ;
Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFNEQ", args, []))
| Seq (loc, [ Prim (_, "LT", [], []) ;
Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFLT", args, []))
| Seq (loc, [ Prim (_, "GT", [], []) ;
Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFGT", args, []))
| Seq (loc, [ Prim (_, "LE", [], []) ;
Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFLE", args, []))
| Seq (loc, [ Prim (_, "GE", [], []) ;
Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFGE", args, []))
| _ -> None
let unexpand_asserts expanded =
match expanded with
| Seq (loc, [ Prim (_, "IF", [ Seq (_, [ ], None) ;
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ],
None) ], None) ->
Some (Prim (loc, "ASSERT", [], None))
| Seq (loc, [ Seq (_, [ Prim(_, "COMPARE", [], None) ; Prim(_, comparison, [], None) ], None) ;
Prim (_, "IF", [ Seq (_, [ ], None) ;
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ],
None) ], None) ->
Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], None))
| Seq (loc, [ Prim (_, comparison, [], None) ;
Prim (_, "IF", [ Seq (_, [ ], None) ;
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ],
None) ], None) ->
Some (Prim (loc, "ASSERT_" ^ comparison, [], None))
| Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ ], None) ;
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ],
None) ], None) ->
Some (Prim (loc, "ASSERT_NONE", [], None))
| Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Prim(_, "FAIL", [], None) ], None) ;
Seq (_, [ ], None)],
None) ], None) ->
Some (Prim (loc, "ASSERT_SOME", [], None))
| Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ ], None) ;
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ],
None) ], None) ->
Some (Prim (loc, "ASSERT_LEFT", [], None))
| Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Prim(_, "FAIL", [], None) ], None) ;
Seq (_, [ ], None) ],
None) ], None) ->
Some (Prim (loc, "ASSERT_RIGHT", [], None))
| Seq (loc, [ Prim (_, "IF", [ Seq (_, []) ;
Seq (_, [ Prim(_, "FAIL", [], []) ]) ],
[]) ]) ->
Some (Prim (loc, "ASSERT", [], []))
| Seq (loc, [ Seq (_, [ Prim(_, "COMPARE", [], []) ; Prim (_, comparison, [], []) ]) ;
Prim (_, "IF", [ Seq (_, []) ;
Seq (_, [ Prim (_, "FAIL", [], []) ]) ],
[]) ]) ->
Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], []))
| Seq (loc, [ Prim (_, comparison, [], []) ;
Prim (_, "IF", [ Seq (_, []) ;
Seq (_, [ Prim (_, "FAIL", [], []) ]) ],
[]) ]) ->
Some (Prim (loc, "ASSERT_" ^ comparison, [], []))
| Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, []) ;
Seq (_, [ Prim (_, "FAIL", [], []) ]) ],
[]) ]) ->
Some (Prim (loc, "ASSERT_NONE", [], []))
| Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Prim (_, "FAIL", [], []) ]) ;
Seq (_, [])],
[]) ]) ->
Some (Prim (loc, "ASSERT_SOME", [], []))
| Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, []) ;
Seq (_, [ Prim (_, "FAIL", [], []) ]) ],
[]) ]) ->
Some (Prim (loc, "ASSERT_LEFT", [], []))
| Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Prim (_, "FAIL", [], []) ]) ;
Seq (_, []) ],
[]) ]) ->
Some (Prim (loc, "ASSERT_RIGHT", [], []))
| _ -> None
let unexpand_if_some = function
| Seq (loc, [ Prim (_, "IF_NONE", [ left ; right ], None) ], None) ->
Some (Prim (loc, "IF_SOME", [ right ; left ], None))
| Seq (loc, [ Prim (_, "IF_NONE", [ left ; right ], []) ]) ->
Some (Prim (loc, "IF_SOME", [ right ; left ], []))
| _ -> None
let unexpand_if_right = function
| Seq (loc, [ Prim (_, "IF_LEFT", [ left ; right ], None) ], None) ->
Some (Prim (loc, "IF_RIGHT", [ right ; left ], None))
| Seq (loc, [ Prim (_, "IF_LEFT", [ left ; right ], []) ]) ->
Some (Prim (loc, "IF_RIGHT", [ right ; left ], []))
| _ -> None
let unexpand original =
@ -866,8 +863,8 @@ let unexpand original =
let rec unexpand_rec expr =
match unexpand expr with
| Seq (loc, items, annot) ->
Seq (loc, List.map unexpand_rec items, annot)
| Seq (loc, items) ->
Seq (loc, List.map unexpand_rec items)
| Prim (loc, name, args, annot) ->
Prim (loc, name, List.map unexpand_rec args, annot)
| Int _ | String _ as atom -> atom

4
src/proto_alpha/lib_client/michelson_v1_parser.ml
View File

@ -54,7 +54,7 @@ let expand_all source ast errors =
errors @ expansion_errors
| Error errs ->
{ source ; unexpanded ;
expanded = Micheline.strip_locations (Seq ((), [], None)) ;
expanded = Micheline.strip_locations (Seq ((), [])) ;
expansion_table ; unexpansion_table },
errors @ expansion_errors @ errs
@ -63,7 +63,7 @@ let parse_toplevel ?check source =
let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in
let ast =
let start = min_point asts and stop = max_point asts in
Seq ({ start ; stop }, asts, None) in
Seq ({ start ; stop }, asts) in
expand_all source ast (lexing_errors @ parsing_errors)
let parse_expression ?check source =

8
src/proto_alpha/lib_client/michelson_v1_printer.ml
View File

@ -37,8 +37,8 @@ let print_stack ppf = function
let inject_types type_map parsed =
let rec inject_expr = function
| Seq (loc, items, annot) ->
Seq (inject_loc `before loc, List.map inject_expr items, annot)
| Seq (loc, items) ->
Seq (inject_loc `before loc, List.map inject_expr items)
| Prim (loc, name, items, annot) ->
Prim (inject_loc `after loc, name, List.map inject_expr items, annot)
| Int (loc, value) ->
@ -69,8 +69,8 @@ let unparse ?type_map parse expanded =
|> Michelson_v1_primitives.strings_of_prims
|> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in
let rec inject_expr = function
| Seq (loc, items, annot) ->
Seq (inject_loc `before loc, List.map inject_expr items, annot)
| Seq (loc, items) ->
Seq (inject_loc `before loc, List.map inject_expr items)
| Prim (loc, name, items, annot) ->
Prim (inject_loc `after loc, name, List.map inject_expr items, annot)
| Int (loc, value) ->

2
src/proto_alpha/lib_protocol/src/apply.ml
View File

@ -373,7 +373,7 @@ let apply_manager_operation_content :
begin match parameters with
| None ->
(* Forge a [Unit] parameter that will be checked by [execute]. *)
let unit = Micheline.strip_locations (Prim (0, Script.D_Unit, [], None)) in
let unit = Micheline.strip_locations (Prim (0, Script.D_Unit, [], [])) in
return (ctxt, unit)
| Some parameters ->
Lwt.return (Script.force_decode parameters) >>=? fun arg ->

8
src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml
View File

@ -369,14 +369,14 @@ let prims_of_strings expr =
ok (arg :: args))
(ok []) args >>? fun args ->
ok (Prim (0, prim, List.rev args, annot))
| Seq (_, args, annot) ->
| Seq (_, args) ->
List.fold_left
(fun acc arg ->
acc >>? fun args ->
convert arg >>? fun arg ->
ok (arg :: args))
(ok []) args >>? fun args ->
ok (Seq (0, List.rev args, annot)) in
ok (Seq (0, List.rev args)) in
convert (root expr) >>? fun expr ->
ok (strip_locations expr)
@ -387,9 +387,9 @@ let strings_of_prims expr =
let prim = string_of_prim prim in
let args = List.map convert args in
Prim (0, prim, args, annot)
| Seq (_, args, annot) ->
| Seq (_, args) ->
let args = List.map convert args in
Seq (0, args, annot) in
Seq (0, args) in
strip_locations (convert (root expr))
let prim_encoding =

6
src/proto_alpha/lib_protocol/src/script_interpreter.ml
View File

@ -634,9 +634,9 @@ let rec interp
Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt ->
let code =
Micheline.strip_locations
(Seq (0, [ Prim (0, K_parameter, [ unparse_ty None param_type ], None) ;
Prim (0, K_storage, [ unparse_ty None storage_type ], None) ;
Prim (0, K_code, [ Micheline.root code ], None) ], None)) in
(Seq (0, [ Prim (0, K_parameter, [ unparse_ty [] param_type ], []) ;
Prim (0, K_storage, [ unparse_ty [] storage_type ], []) ;
Prim (0, K_code, [ Micheline.root code ], []) ])) in
unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) ->
let storage = Micheline.strip_locations storage in
Contract.spend_from_script ctxt self credit >>=? fun ctxt ->

200
src/proto_alpha/lib_protocol/src/script_ir_translator.ml
View File

@ -29,12 +29,12 @@ let add_dip ty annot prev =
| Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot), prev)
| Dip (stack, _) -> Dip (Item_t (ty, stack, annot), prev)
let default_param_annot = Some "@parameter"
let default_storage_annot = Some "@storage"
let default_arg_annot = Some "@arg"
let default_param_annot = [ "@parameter" ]
let default_storage_annot = [ "@storage" ]
let default_arg_annot = [ "@arg" ]
let default_annot ~default = function
| None -> default
| [] -> default
| annot -> annot
(* ---- Type size accounting ------------------------------------------------*)
@ -216,7 +216,7 @@ let location = function
| Prim (loc, _, _, _)
| Int (loc, _)
| String (loc, _)
| Seq (loc, _, _) -> loc
| Seq (loc, _) -> loc
let kind = function
| Int _ -> Int_kind
@ -335,7 +335,7 @@ 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)
| Seq (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind)
| Prim (loc, name, _, _) ->
match namespace name, exp_ns with
| Type_namespace, Type_namespace
@ -505,14 +505,14 @@ let ty_of_comparable_ty
let unparse_comparable_ty
: type a. a comparable_ty -> Script.node = function
| Int_key -> Prim (-1, T_int, [], None)
| Nat_key -> Prim (-1, T_nat, [], None)
| String_key -> Prim (-1, T_string, [], None)
| Mutez_key -> Prim (-1, T_mutez, [], None)
| Bool_key -> Prim (-1, T_bool, [], None)
| Key_hash_key -> Prim (-1, T_key_hash, [], None)
| Timestamp_key -> Prim (-1, T_timestamp, [], None)
| Address_key -> Prim (-1, T_address, [], None)
| Int_key -> Prim (-1, T_int, [], [])
| Nat_key -> Prim (-1, T_nat, [], [])
| String_key -> Prim (-1, T_string, [], [])
| Mutez_key -> Prim (-1, T_mutez, [], [])
| Bool_key -> Prim (-1, T_bool, [], [])
| Key_hash_key -> Prim (-1, T_key_hash, [], [])
| Timestamp_key -> Prim (-1, T_timestamp, [], [])
| Address_key -> Prim (-1, T_address, [], [])
let rec unparse_ty
: type a. annot -> a ty -> Script.node = fun annot ->
@ -530,7 +530,7 @@ let rec unparse_ty
| Signature_t -> Prim (-1, T_signature, [], annot)
| Operation_t -> Prim (-1, T_operation, [], annot)
| Contract_t ut ->
let t = unparse_ty None ut in
let t = unparse_ty [] ut in
Prim (-1, T_contract, [ t ], annot)
| Pair_t ((utl, left_annot), (utr, right_annot)) ->
let tl = unparse_ty left_annot utl in
@ -541,26 +541,26 @@ let rec unparse_ty
let tr = unparse_ty right_annot utr in
Prim (-1, T_or, [ tl; tr ], annot)
| Lambda_t (uta, utr) ->
let ta = unparse_ty None uta in
let tr = unparse_ty None utr in
let ta = unparse_ty [] uta in
let tr = unparse_ty [] utr in
Prim (-1, T_lambda, [ ta; tr ], annot)
| Option_t ut ->
let t = unparse_ty None ut in
let t = unparse_ty [] ut in
Prim (-1, T_option, [ t ], annot)
| List_t ut ->
let t = unparse_ty None ut in
let t = unparse_ty [] ut in
Prim (-1, T_list, [ t ], annot)
| Set_t ut ->
let t = unparse_comparable_ty ut in
Prim (-1, T_set, [ t ], None)
Prim (-1, T_set, [ t ], [])
| Map_t (uta, utr) ->
let ta = unparse_comparable_ty uta in
let tr = unparse_ty None utr in
Prim (-1, T_map, [ ta; tr ], None)
let tr = unparse_ty [] utr in
Prim (-1, T_map, [ ta; tr ], [])
| Big_map_t (uta, utr) ->
let ta = unparse_comparable_ty uta in
let tr = unparse_ty None utr in
Prim (-1, T_big_map, [ ta; tr ], None)
let tr = unparse_ty [] utr in
Prim (-1, T_big_map, [ ta; tr ], [])
(* ---- Equality witnesses --------------------------------------------------*)
@ -653,14 +653,16 @@ let rec stack_ty_eq
| Empty_t, Empty_t -> Ok Eq
| _, _ -> error Bad_stack_length
module CompareStringList = Compare.List (Compare.String)
let merge_annot annot1 annot2 =
match annot1, annot2 with
| None, None
| Some _, None
| None, Some _ -> ok None
| Some annot1, Some annot2 ->
if String.equal annot1 annot2
then ok (Some annot1)
| [], []
| _ :: _, []
| [], _ :: _ -> ok []
| annot1, annot2 ->
if CompareStringList.equal annot1 annot2
then ok annot1
else error (Inconsistent_annotations (annot1, annot2))
let merge_comparable_types
@ -680,14 +682,14 @@ let merge_comparable_types
let error_unexpected_annot loc annot =
match annot with
| None -> ok ()
| Some _ -> error (Unexpected_annotation loc)
| [] -> ok ()
| _ :: _ -> error (Unexpected_annotation loc)
let rec strip_annotations = function
| (Int (_,_) as i) -> i
| (String (_,_) as s) -> s
| Prim (loc, prim, args, _) -> Prim (loc, prim, List.map strip_annotations args, None)
| Seq (loc, items, _) -> Seq (loc, List.map strip_annotations items, None)
| Prim (loc, prim, args, _) -> Prim (loc, prim, List.map strip_annotations args, [])
| Seq (loc, items) -> Seq (loc, List.map strip_annotations items)
let fail_unexpected_annot loc annot =
Lwt.return (error_unexpected_annot loc annot)
@ -1201,7 +1203,7 @@ let rec parse_data
| Lambda_t (ta, tr), (Seq _ as script_instr) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.lambda) >>=? fun ctxt ->
traced @@
parse_returning Lambda ?type_logger ctxt (ta, Some "@arg") tr script_instr
parse_returning Lambda ?type_logger ctxt (ta, [ "@arg" ]) tr script_instr
| Lambda_t _, expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
(* Options *)
@ -1220,8 +1222,7 @@ let rec parse_data
| Option_t _, expr ->
traced (fail (unexpected expr [] Constant_namespace [ D_Some ; D_None ]))
(* Lists *)
| List_t t, Seq (loc, items, annot) ->
fail_unexpected_annot loc annot >>=? fun () ->
| List_t t, Seq (_, items) ->
traced @@
fold_right_s
(fun v (rest, ctxt) ->
@ -1232,8 +1233,7 @@ let rec parse_data
| List_t _, expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
(* Sets *)
| Set_t t, (Seq (loc, vs, annot) as expr) ->
fail_unexpected_annot loc annot >>=? fun () ->
| Set_t t, (Seq (loc, vs) as expr) ->
traced @@
fold_left_s
(fun (last_value, set, ctxt) v ->
@ -1256,13 +1256,11 @@ let rec parse_data
| Set_t _, expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
(* Maps *)
| Map_t (tk, tv), (Seq (loc, vs, annot) as expr) ->
fail_unexpected_annot loc annot >>=? fun () ->
| Map_t (tk, tv), (Seq (loc, vs) as expr) ->
parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x)
| Map_t _, expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
| Big_map_t (tk, tv), (Seq (loc, vs, annot) as expr) ->
fail_unexpected_annot loc annot >>=? fun () ->
| Big_map_t (tk, tv), (Seq (loc, vs) as expr) ->
parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) >>|? fun (diff, ctxt) ->
({ diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt)
| Big_map_t (_tk, _tv), expr ->
@ -1291,7 +1289,7 @@ and parse_returning
| (Typed { loc ; aft = stack_ty ; _ }, _gas) ->
fail (Bad_return (loc, stack_ty, ret))
| (Failed { descr }, gas) ->
return ((Lam (descr (Item_t (ret, Empty_t, None)), strip_locations script_instr)
return ((Lam (descr (Item_t (ret, Empty_t, [])), strip_locations script_instr)
: (arg, ret) lambda), gas)
and parse_instr
@ -1316,7 +1314,7 @@ and parse_instr
return (judgement, ctxt) in
let keep_or_rewrite_annot value_annot instr_annot =
match value_annot, instr_annot with
| annot, None -> annot
| annot, [] -> annot
| _, annot -> annot in
let check_item check loc name n m =
trace (Bad_stack (loc, name, m, stack_ty)) @@
@ -1327,7 +1325,7 @@ and parse_instr
let typed ctxt loc instr aft =
begin match type_logger, script_instr with
| None, _
| Some _, (Seq (-1, _, _) | Int _ | String _) -> ()
| Some _, (Seq (-1, _) | Int _ | String _) -> ()
| Some log, (Prim _ | Seq _) ->
log loc (unparse_stack stack_ty) (unparse_stack aft)
end ;
@ -1398,12 +1396,12 @@ and parse_instr
Item_t (tl, rest, stack_annot) ->
(Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true tr)) >>=? fun (Ex_ty tr, _) ->
typed ctxt loc Left
(Item_t (Union_t ((tl, stack_annot), (tr, None)), rest, instr_annot))
(Item_t (Union_t ((tl, stack_annot), (tr, [])), rest, instr_annot))
| Prim (loc, I_RIGHT, [ tl ], instr_annot),
Item_t (tr, rest, stack_annot) ->
(Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true tl)) >>=? fun (Ex_ty tl, _) ->
typed ctxt loc Right
(Item_t (Union_t ((tl, None), (tr, stack_annot)), rest, instr_annot))
(Item_t (Union_t ((tl, []), (tr, stack_annot)), rest, instr_annot))
| Prim (loc, I_IF_LEFT, [ bt ; bf ], instr_annot),
(Item_t (Union_t ((tl, left_annot), (tr, right_annot)), rest, _) as bef) ->
check_kind [ Seq_kind ] bt >>=? fun () ->
@ -1446,7 +1444,7 @@ and parse_instr
(Item_t (List_t elt, starting_rest, _)) ->
check_kind [ Seq_kind ] body >>=? fun () ->
parse_instr ?type_logger tc_context ctxt
body (Item_t (elt, starting_rest, None)) >>=? begin fun (judgement, ctxt) ->
body (Item_t (elt, starting_rest, [])) >>=? begin fun (judgement, ctxt) ->
match judgement with
| Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) ->
trace
@ -1462,7 +1460,7 @@ and parse_instr
check_kind [ Seq_kind ] body >>=? fun () ->
fail_unexpected_annot loc instr_annot >>=? fun () ->
parse_instr ?type_logger tc_context ctxt
body (Item_t (elt, rest, None)) >>=? begin fun (judgement, ctxt) ->
body (Item_t (elt, rest, [])) >>=? begin fun (judgement, ctxt) ->
match judgement with
| Typed ({ aft ; _ } as ibody) ->
trace
@ -1484,7 +1482,7 @@ and parse_instr
fail_unexpected_annot loc annot >>=? fun () ->
let elt = ty_of_comparable_ty comp_elt in
parse_instr ?type_logger tc_context ctxt
body (Item_t (elt, rest, None)) >>=? begin fun (judgement, ctxt) ->
body (Item_t (elt, rest, [])) >>=? begin fun (judgement, ctxt) ->
match judgement with
| Typed ({ aft ; _ } as ibody) ->
trace
@ -1522,7 +1520,7 @@ and parse_instr
let k = ty_of_comparable_ty ck in
check_kind [ Seq_kind ] body >>=? fun () ->
parse_instr ?type_logger tc_context ctxt
body (Item_t (Pair_t ((k, None), (elt, None)), starting_rest, None)) >>=? begin fun (judgement, ctxt) ->
body (Item_t (Pair_t ((k, []), (elt, [])), starting_rest, [])) >>=? begin fun (judgement, ctxt) ->
match judgement with
| Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) ->
trace
@ -1539,7 +1537,7 @@ and parse_instr
fail_unexpected_annot loc instr_annot >>=? fun () ->
let key = ty_of_comparable_ty comp_elt in
parse_instr ?type_logger tc_context ctxt body
(Item_t (Pair_t ((key, None), (element_ty, None)), rest, None))
(Item_t (Pair_t ((key, []), (element_ty, [])), rest, []))
>>=? begin fun (judgement, ctxt) -> match judgement with
| Typed ({ aft ; _ } as ibody) ->
trace
@ -1593,13 +1591,11 @@ and parse_instr
typed ctxt loc Big_map_update
(Item_t (Big_map_t (map_key, map_value), rest, instr_annot))
(* control *)
| Seq (loc, [], annot),
| Seq (loc, []),
stack ->
fail_unexpected_annot loc annot >>=? fun () ->
typed ctxt loc Nop stack
| Seq (loc, [ single ], annot),
| Seq (loc, [ single ]),
stack ->
fail_unexpected_annot loc annot >>=? fun () ->
parse_instr ?type_logger tc_context ctxt single
stack >>=? begin fun (judgement, ctxt) ->
match judgement with
@ -1613,16 +1609,15 @@ and parse_instr
{ descr with instr = Seq (descr, nop) } in
return ctxt (Failed { descr })
end
| Seq (loc, hd :: tl, annot),
| Seq (loc, hd :: tl),
stack ->
fail_unexpected_annot loc annot >>=? fun () ->
parse_instr ?type_logger tc_context ctxt hd
stack >>=? begin fun (judgement, ctxt) ->
match judgement with
| Failed _ ->
fail (Fail_not_in_tail_position (Micheline.location hd))
| Typed ({ aft = middle ; _ } as ihd) ->
parse_instr ?type_logger tc_context ctxt (Seq (-1, tl, None))
parse_instr ?type_logger tc_context ctxt (Seq (-1, tl))
middle >>=? fun (judgement, ctxt) ->
match judgement with
| Failed { descr } ->
@ -1672,7 +1667,7 @@ and parse_instr
(Lwt.return (stack_ty_eq 1 ibody.aft stack)) >>=? fun Eq ->
typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, tr_annot))
| Failed { descr } ->
let ibody = descr (Item_t (Union_t ((tl, tl_annot), (tr, tr_annot)), rest, None)) in
let ibody = descr (Item_t (Union_t ((tl, tl_annot), (tr, tr_annot)), rest, [])) in
typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, tr_annot))
end
| Prim (loc, I_LAMBDA, [ arg ; ret ; code ], instr_annot),
@ -1767,11 +1762,11 @@ and parse_instr
Item_t (Int_t, rest, _) ->
typed ctxt loc Abs_int
(Item_t (Nat_t, rest, instr_annot))
| Prim (loc, I_ISNAT, [], Some instr_annot),
Item_t (Int_t, rest, None) ->
| Prim (loc, I_ISNAT, [], (_ :: _ as instr_annot)),
Item_t (Int_t, rest, []) ->
typed ctxt loc Is_nat
(Item_t (Option_t Nat_t, rest, Some instr_annot))
| Prim (loc, I_ISNAT, [], None),
(Item_t (Option_t Nat_t, rest, instr_annot))
| Prim (loc, I_ISNAT, [], []),
Item_t (Int_t, rest, annot) ->
typed ctxt loc Is_nat
(Item_t (Option_t Nat_t, rest, annot))
@ -1838,27 +1833,27 @@ and parse_instr
| Prim (loc, I_EDIV, [], instr_annot),
Item_t (Mutez_t, Item_t (Nat_t, rest, _), _) ->
typed ctxt loc Ediv_teznat
(Item_t (Option_t (Pair_t ((Mutez_t, None), (Mutez_t, None))), rest, instr_annot))
(Item_t (Option_t (Pair_t ((Mutez_t, []), (Mutez_t, []))), rest, instr_annot))
| Prim (loc, I_EDIV, [], instr_annot),
Item_t (Mutez_t, Item_t (Mutez_t, rest, _), _) ->
typed ctxt loc Ediv_tez
(Item_t (Option_t (Pair_t ((Nat_t, None), (Mutez_t, None))), rest, instr_annot))
(Item_t (Option_t (Pair_t ((Nat_t, []), (Mutez_t, []))), rest, instr_annot))
| Prim (loc, I_EDIV, [], instr_annot),
Item_t (Int_t, Item_t (Int_t, rest, _), _) ->
typed ctxt loc Ediv_intint
(Item_t (Option_t (Pair_t ((Int_t, None), (Nat_t, None))), rest, instr_annot))
(Item_t (Option_t (Pair_t ((Int_t, []), (Nat_t, []))), rest, instr_annot))
| Prim (loc, I_EDIV, [], instr_annot),
Item_t (Int_t, Item_t (Nat_t, rest, _), _) ->
typed ctxt loc Ediv_intnat
(Item_t (Option_t (Pair_t ((Int_t, None), (Nat_t, None))), rest, instr_annot))
(Item_t (Option_t (Pair_t ((Int_t, []), (Nat_t, []))), rest, instr_annot))
| Prim (loc, I_EDIV, [], instr_annot),
Item_t (Nat_t, Item_t (Int_t, rest, _), _) ->
typed ctxt loc Ediv_natint
(Item_t (Option_t (Pair_t ((Int_t, None), (Nat_t, None))), rest, instr_annot))
(Item_t (Option_t (Pair_t ((Int_t, []), (Nat_t, []))), rest, instr_annot))
| Prim (loc, I_EDIV, [], instr_annot),
Item_t (Nat_t, Item_t (Nat_t, rest, _), _) ->
typed ctxt loc Ediv_natnat
(Item_t (Option_t (Pair_t ((Nat_t, None), (Nat_t, None))), rest, instr_annot))
(Item_t (Option_t (Pair_t ((Nat_t, []), (Nat_t, []))), rest, instr_annot))
| Prim (loc, I_LSL, [], instr_annot),
Item_t (Nat_t, Item_t (Nat_t, rest, _), _) ->
typed ctxt loc Lsl_nat
@ -1984,12 +1979,12 @@ and parse_instr
(Bool_t, Item_t
(Mutez_t, rest, _), _), _), _) ->
typed ctxt loc Create_account
(Item_t (Operation_t, Item_t (Address_t, rest, None), instr_annot))
(Item_t (Operation_t, Item_t (Address_t, rest, []), instr_annot))
| Prim (loc, I_IMPLICIT_ACCOUNT, [], instr_annot),
Item_t (Key_hash_t, rest, _) ->
typed ctxt loc Implicit_account
(Item_t (Contract_t Unit_t, rest, instr_annot))
| Prim (loc, I_CREATE_CONTRACT, [ (Seq (seq_loc, _, annot) as code)], instr_annot),
| Prim (loc, I_CREATE_CONTRACT, [ (Seq (_, _) as code)], instr_annot),
Item_t
(Key_hash_t, Item_t
(Option_t Key_hash_t, Item_t
@ -1997,7 +1992,6 @@ and parse_instr
(Bool_t, Item_t
(Mutez_t, Item_t
(ginit, rest, _), _), _), _), _), _) ->
fail_unexpected_annot seq_loc annot >>=? fun () ->
let cannonical_code = fst @@ Micheline.extract_locations code in
Lwt.return (parse_toplevel cannonical_code) >>=? fun (arg_type, storage_type, code_field) ->
trace
@ -2010,18 +2004,18 @@ and parse_instr
>>=? fun (Ex_ty storage_type, storage_annot) ->
let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot),
(storage_type, default_annot ~default:default_storage_annot storage_annot)) in
let ret_type_full = Pair_t ((List_t Operation_t, None), (storage_type, None)) in
let ret_type_full = Pair_t ((List_t Operation_t, []), (storage_type, [])) in
trace
(Ill_typed_contract (cannonical_code, []))
(parse_returning (Toplevel { storage_type ; param_type = arg_type })
ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=?
ctxt ?type_logger (arg_type_full, []) ret_type_full code_field) >>=?
fun (Lam ({ bef = Item_t (arg, Empty_t, _) ;
aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) ->
Lwt.return @@ ty_eq arg arg_type_full >>=? fun Eq ->
Lwt.return @@ ty_eq ret ret_type_full >>=? fun Eq ->
Lwt.return @@ ty_eq storage_type ginit >>=? fun Eq ->
typed ctxt loc (Create_contract (storage_type, arg_type, lambda))
(Item_t (Operation_t, Item_t (Address_t, rest, None), instr_annot))
(Item_t (Operation_t, Item_t (Address_t, rest, []), instr_annot))
| Prim (loc, I_NOW, [], instr_annot),
stack ->
typed ctxt loc Now
@ -2187,13 +2181,13 @@ and parse_toplevel
| Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind))
| String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind))
| Prim (loc, _, _, _) -> error (Invalid_kind (loc, [ Seq_kind ], Prim_kind))
| Seq (_, fields, _) ->
| Seq (_, fields) ->
let rec find_fields p s c fields =
match fields with
| [] -> ok (p, s, c)
| Int (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Int_kind))
| String (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], String_kind))
| Seq (loc, _, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Seq_kind))
| Seq (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Seq_kind))
| Prim (loc, K_parameter, [ arg ], _) :: rest ->
begin match p with
| None -> find_fields (Some arg) s c rest
@ -2238,14 +2232,14 @@ let parse_script
>>=? fun (Ex_ty storage_type, storage_annot) ->
let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot),
(storage_type, default_annot ~default:default_storage_annot storage_annot)) in
let ret_type_full = Pair_t ((List_t Operation_t, None), (storage_type, None)) in
let ret_type_full = Pair_t ((List_t Operation_t, []), (storage_type, [])) in
trace
(Ill_typed_data (None, storage, storage_type))
(parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) ->
trace
(Ill_typed_contract (code, []))
(parse_returning (Toplevel { storage_type ; param_type = arg_type })
ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) ->
ctxt ?type_logger (arg_type_full, []) ret_type_full code_field) >>=? fun (code, ctxt) ->
return (Ex_script { code ; arg_type ; storage ; storage_type }, ctxt)
let typecheck_code
@ -2264,13 +2258,13 @@ let typecheck_code
>>=? fun (Ex_ty storage_type, storage_annot) ->
let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot),
(storage_type, default_annot ~default:default_storage_annot storage_annot)) in
let ret_type_full = Pair_t ((List_t Operation_t, None), (storage_type, None)) in
let ret_type_full = Pair_t ((List_t Operation_t, []), (storage_type, [])) in
let result =
parse_returning
(Toplevel { storage_type ; param_type = arg_type })
ctxt
~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map)
(arg_type_full, None) ret_type_full code_field in
(arg_type_full, []) ret_type_full code_field in
trace
(Ill_typed_contract (code, !type_map))
result >>=? fun (Lam _, ctxt) ->
@ -2303,7 +2297,7 @@ let rec unparse_data
match ty, a with
| Unit_t, () ->
Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt ->
return (Prim (-1, D_Unit, [], None), ctxt)
return (Prim (-1, D_Unit, [], []), ctxt)
| Int_t, v ->
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
return (Int (-1, Script_int.to_zint v), ctxt)
@ -2315,10 +2309,10 @@ let rec unparse_data
return (String (-1, s), ctxt)
| Bool_t, true ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
return (Prim (-1, D_True, [], None), ctxt)
return (Prim (-1, D_True, [], []), ctxt)
| Bool_t, false ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
return (Prim (-1, D_False, [], None), ctxt)
return (Prim (-1, D_False, [], []), ctxt)
| Timestamp_t, t ->
Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt ->
begin
@ -2389,22 +2383,22 @@ let rec unparse_data
Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt ->
unparse_data ctxt mode tl l >>=? fun (l, ctxt) ->
unparse_data ctxt mode tr r >>=? fun (r, ctxt) ->
return (Prim (-1, D_Pair, [ l; r ], None), ctxt)
return (Prim (-1, D_Pair, [ l; r ], []), ctxt)
| Union_t ((tl, _), _), L l ->
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
unparse_data ctxt mode tl l >>=? fun (l, ctxt) ->
return (Prim (-1, D_Left, [ l ], None), ctxt)
return (Prim (-1, D_Left, [ l ], []), ctxt)
| Union_t (_, (tr, _)), R r ->
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
unparse_data ctxt mode tr r >>=? fun (r, ctxt) ->
return (Prim (-1, D_Right, [ r ], None), ctxt)
return (Prim (-1, D_Right, [ r ], []), ctxt)
| Option_t t, Some v ->
Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt ->
unparse_data ctxt mode t v >>=? fun (v, ctxt) ->
return (Prim (-1, D_Some, [ v ], None), ctxt)
return (Prim (-1, D_Some, [ v ], []), ctxt)
| Option_t _, None ->
Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt ->
return (Prim (-1, D_None, [], None), ctxt)
return (Prim (-1, D_None, [], []), ctxt)
| List_t t, items ->
fold_left_s
(fun (l, ctxt) element ->
@ -2413,7 +2407,7 @@ let rec unparse_data
return (unparsed :: l, ctxt))
([], ctxt)
items >>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, List.rev items, None), ctxt)
return (Micheline.Seq (-1, List.rev items), ctxt)
| Set_t t, set ->
let t = ty_of_comparable_ty t in
fold_left_s
@ -2423,7 +2417,7 @@ let rec unparse_data
return (item :: l, ctxt))
([], ctxt)
(set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, items, None), ctxt)
return (Micheline.Seq (-1, items), ctxt)
| Map_t (kt, vt), map ->
let kt = ty_of_comparable_ty kt in
fold_left_s
@ -2431,12 +2425,12 @@ let rec unparse_data
Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt ->
unparse_data ctxt mode kt k >>=? fun (key, ctxt) ->
unparse_data ctxt mode vt v >>=? fun (value, ctxt) ->
return (Prim (-1, D_Elt, [ key ; value ], None) :: l, ctxt))
return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt))
([], ctxt)
(map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, items, None), ctxt)
return (Micheline.Seq (-1, items), ctxt)
| Big_map_t (_kt, _kv), _map ->
return (Micheline.Seq (-1, [], None), ctxt)
return (Micheline.Seq (-1, []), ctxt)
| Lambda_t _, Lam (_, original_code) ->
unparse_code ctxt mode (root original_code)
@ -2446,13 +2440,13 @@ and unparse_code ctxt mode = function
parse_data ctxt t data >>=? fun (data, ctxt) ->
unparse_data ctxt mode t data >>=? fun (data, ctxt) ->
return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt)
| Seq (loc, items, annot) ->
| Seq (loc, items) ->
fold_left_s
(fun (l, ctxt) item ->
unparse_code ctxt mode item >>=? fun (item, ctxt) ->
return (item :: l, ctxt))
([], ctxt) items >>=? fun (items, ctxt) ->
return (Micheline.Seq (loc, List.rev items, annot), ctxt)
return (Micheline.Seq (loc, List.rev items), ctxt)
| Prim (loc, prim, items, annot) ->
fold_left_s
(fun (l, ctxt) item ->
@ -2466,13 +2460,13 @@ let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } =
let Lam (_, original_code) = code in
unparse_code ctxt mode (root original_code) >>=? fun (code, ctxt) ->
unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) ->
let arg_type = unparse_ty None arg_type in
let storage_type = unparse_ty None storage_type in
let arg_type = unparse_ty [] arg_type in
let storage_type = unparse_ty [] storage_type in
let open Micheline in
let code =
Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], None) ;
Prim (-1, K_storage, [ storage_type ], None) ;
Prim (-1, K_code, [ code ], None) ], None) in
Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], []) ;
Prim (-1, K_storage, [ storage_type ], []) ;
Prim (-1, K_code, [ code ], []) ]) in
return ({ code = lazy_expr (strip_locations code) ;
storage = lazy_expr (strip_locations storage) }, ctxt)

2
src/proto_alpha/lib_protocol/src/script_ir_translator.mli
View File

@ -71,7 +71,7 @@ val parse_ty :
Script.node ->
(ex_ty * Script_typed_ir.annot) tzresult
val unparse_ty :
string option -> 'a Script_typed_ir.ty -> Script.node
string list -> 'a Script_typed_ir.ty -> Script.node
val parse_toplevel
: Script.expr -> (Script.node * Script.node * Script.node) tzresult

12
src/proto_alpha/lib_protocol/src/script_repr.ml
View File

@ -76,17 +76,17 @@ let rec node_size node =
let (nblocks, nwords) = node_size node in
(blocks + 1 + nblocks, words + 2 + nwords))
(match annot with
| None -> (1, 2)
| Some annot -> (1, 4 + (String.length annot + 7) / 8))
| [] -> (1, 2)
| annots ->
let annots_length = List.fold_left (fun acc s -> acc + String.length s) 0 annots in
(1, 4 + (annots_length + 7) / 8))
args
| Seq (_, args, annot) ->
| Seq (_, args) ->
List.fold_left
(fun (blocks, words) node ->
let (nblocks, nwords) = node_size node in
(blocks + 1 + nblocks, words + 2 + nwords))
(match annot with
| None -> (1, 2)
| Some annot -> (1, 3 + (String.length annot + 7) / 8))
(1, 2)
args
let expr_size expr =

2
src/proto_alpha/lib_protocol/src/script_tc_errors.ml
View File

@ -39,7 +39,7 @@ type error += Unmatched_branches : Script.location * _ stack_ty * _ stack_ty ->
type error += Self_in_lambda of Script.location
type error += Bad_stack_length
type error += Bad_stack_item of int
type error += Inconsistent_annotations of string * string
type error += Inconsistent_annotations of string list * string list
type error += Inconsistent_type_annotations : Script.location * _ ty * _ ty -> error
type error += Unexpected_annotation of Script.location
type error += Invalid_map_body : Script.location * _ stack_ty -> error

8
src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml
View File

@ -28,7 +28,7 @@ let type_map_enc =
let ex_ty_enc =
Data_encoding.conv
(fun (Ex_ty ty) -> strip_locations (unparse_ty None ty))
(fun (Ex_ty ty) -> strip_locations (unparse_ty [] ty))
(fun expr ->
match parse_ty ~allow_big_map:true ~allow_operation:true (root expr) with
| Ok (Ex_ty ty, _) -> Ex_ty ty
@ -73,7 +73,7 @@ let () =
let Ex_stack_ty rest = fold rest in
Ex_stack_ty (Item_t (ty, rest, annot))
| [] -> Ex_stack_ty Empty_t in
conv unfold fold (list (tup2 ex_ty_enc (option string))) in
conv unfold fold (list (tup2 ex_ty_enc (list string))) in
(* -- Structure errors ---------------------- *)
(* Invalid arity *)
register_error_kind
@ -327,8 +327,8 @@ let () =
~title:"Annotations inconsistent between branches"
~description:"The annotations on two types could not be merged"
(obj2
(req "annot1" string)
(req "annot2" string))
(req "annot1" (list string))
(req "annot2" (list string)))
(function Inconsistent_annotations (annot1, annot2) -> Some (annot1, annot2)
| _ -> None)
(fun (annot1, annot2) -> Inconsistent_annotations (annot1, annot2)) ;

2
src/proto_alpha/lib_protocol/src/script_typed_ir.ml
View File

@ -42,7 +42,7 @@ end
type ('key, 'value) map = (module Boxed_map with type key = 'key and type value = 'value)
type annot = string option
type annot = string list
type ('arg, 'storage) script =
{ code : (('arg, 'storage) pair, (packed_internal_operation list, 'storage) pair) lambda ;