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

8
src/lib_micheline/micheline.mli
View File

@ -13,8 +13,8 @@
type ('l, 'p) node = type ('l, 'p) node =
| Int of 'l * Z.t | Int of 'l * Z.t
| String of 'l * string | String of 'l * string
| Prim of 'l * 'p * ('l, 'p) node list * string option | Prim of 'l * 'p * ('l, 'p) node list * string list
| Seq of 'l * ('l, 'p) node list * string option | Seq of 'l * ('l, 'p) node list
(** Encoding for expressions, as their {!canonical} encoding. (** Encoding for expressions, as their {!canonical} encoding.
Locations are stored in a side table. Locations are stored in a side table.
@ -33,8 +33,8 @@ val erased_encoding : variant:string ->
(** Extract the location of the node. *) (** Extract the location of the node. *)
val location : ('l, 'p) node -> 'l val location : ('l, 'p) node -> 'l
(** Extract the annotation of the node. *) (** Extract the annotations of the node. *)
val annotation : ('l, 'p) node -> string option val annotations : ('l, 'p) node -> string list
(** Expression form using canonical integer numbering as (** Expression form using canonical integer numbering as
locations. The root has number zero, and each node adds one in the 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 -> | `Uchar c, start ->
begin match uchar_to_char c with begin match uchar_to_char c with
| Some ('a'..'z' | 'A'..'Z') -> ident acc start (fun s _ -> Ident s) | Some ('a'..'z' | 'A'..'Z') -> ident acc start (fun s _ -> Ident s)
| Some '@' -> | Some ('@' | ':' | '$' | '&' | '%' | '!' | '?') ->
ident acc start ident acc start
(fun str stop -> (fun str stop ->
if String.length str > max_annot_length if String.length str > max_annot_length
@ -366,7 +366,7 @@ let min_point : node list -> point = function
| Int ({ start }, _) :: _ | Int ({ start }, _) :: _
| String ({ start }, _) :: _ | String ({ start }, _) :: _
| Prim ({ start }, _, _, _) :: _ | Prim ({ start }, _, _, _) :: _
| Seq ({ start }, _, _) :: _ -> start | Seq ({ start }, _) :: _ -> start
(* End of a sequence of consecutive primitives *) (* End of a sequence of consecutive primitives *)
let rec max_point : node list -> point = function let rec max_point : node list -> point = function
@ -375,7 +375,7 @@ let rec max_point : node list -> point = function
| Int ({ stop }, _) :: [] | Int ({ stop }, _) :: []
| String ({ stop }, _) :: [] | String ({ stop }, _) :: []
| Prim ({ stop }, _, _, _) :: [] | Prim ({ stop }, _, _, _) :: []
| Seq ({ stop }, _, _) :: [] -> stop | Seq ({ stop }, _) :: [] -> stop
(* An item in the parser's state stack. (* An item in the parser's state stack.
Not every value of type [mode list] is a valid parsing context. 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 = type mode =
| Toplevel of node list | Toplevel of node list
| Expression of node option | Expression of node option
| Sequence of token * node list * string option | Sequence of token * node list
| Unwrapped of location * string * node list * string option | Unwrapped of location * string * node list * string list
| Wrapped of token * string * node list * string option | Wrapped of token * string * node list * string list
(* Enter a new parsing state. *) (* Enter a new parsing state. *)
let push_mode mode stack = let push_mode mode stack =
@ -413,8 +413,8 @@ let fill_mode result = function
Expression (Some result) :: [] Expression (Some result) :: []
| Toplevel exprs :: [] -> | Toplevel exprs :: [] ->
Toplevel (result :: exprs) :: [] Toplevel (result :: exprs) :: []
| Sequence (token, exprs, annot) :: rest -> | Sequence (token, exprs) :: rest ->
Sequence (token, result :: exprs, annot) :: rest Sequence (token, result :: exprs) :: rest
| Wrapped (token, name, exprs, annot) :: rest -> | Wrapped (token, name, exprs, annot) :: rest ->
Wrapped (token, name, result :: exprs, annot) :: rest Wrapped (token, name, result :: exprs, annot) :: rest
| Unwrapped (start, name, 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 += Misaligned of node
type error += Empty 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 = let rec parse ?(check = true) errors tokens stack =
(* Two steps: (* Two steps:
- 1. parse without checking indentation [parse] - 1. parse without checking indentation [parse]
@ -451,8 +457,8 @@ let rec parse ?(check = true) errors tokens stack =
| Expression None :: _, [] -> | Expression None :: _, [] ->
let errors = Empty :: errors in let errors = Empty :: errors in
let ghost = { start = point_zero ; stop = point_zero} in let ghost = { start = point_zero ; stop = point_zero} in
[ Seq (ghost, [], None) ], List.rev errors [ Seq (ghost, []) ], List.rev errors
| Toplevel [ Seq (_, exprs, _) as expr ] :: [], | Toplevel [ Seq (_, exprs) as expr ] :: [],
[] -> [] ->
let errors = if check then do_check ~toplevel: false errors expr else errors in let errors = if check then do_check ~toplevel: false errors expr else errors in
exprs, List.rev errors exprs, List.rev errors
@ -460,7 +466,7 @@ let rec parse ?(check = true) errors tokens stack =
[] -> [] ->
let exprs = List.rev exprs in let exprs = List.rev exprs in
let loc = { start = min_point exprs ; stop = max_point 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 let errors = if check then do_check ~toplevel: true errors expr else errors in
exprs, List.rev errors exprs, List.rev errors
(* Ignore comments *) (* Ignore comments *)
@ -517,19 +523,20 @@ let rec parse ?(check = true) errors tokens stack =
let fake = { token with token = Close_paren } in let fake = { token with token = Close_paren } in
let tokens = (* insert *) fake :: tokens in let tokens = (* insert *) fake :: tokens in
parse ~check errors tokens stack parse ~check errors tokens stack
| (Sequence (token, _, _) :: _ | Unwrapped _ :: Sequence (token, _, _) :: _), [] -> | (Sequence (token, _) :: _ | Unwrapped _ :: Sequence (token, _) :: _), [] ->
let errors = Unclosed token :: errors in let errors = Unclosed token :: errors in
let fake = { token with token = Close_brace } in let fake = { token with token = Close_brace } in
let tokens = (* insert *) fake :: tokens in let tokens = (* insert *) fake :: tokens in
parse ~check errors tokens stack parse ~check errors tokens stack
(* Valid states *) (* Valid states *)
| (Toplevel _ | Sequence (_, _, _)) :: _ , | (Toplevel _ | Sequence (_, _)) :: _ ,
{ token = Ident name ; loc } :: { token = Annot annot } :: rest -> { token = Ident name ; loc } :: ({ token = Annot _ } :: _ as rest) ->
let mode = Unwrapped (loc, name, [], Some annot) in let annots, rest = annots rest in
let mode = Unwrapped (loc, name, [], annots) in
parse ~check errors rest (push_mode mode stack) parse ~check errors rest (push_mode mode stack)
| (Expression None | Toplevel _ | Sequence (_, _, _)) :: _ , | (Expression None | Toplevel _ | Sequence (_, _)) :: _ ,
{ token = Ident name ; loc } :: rest -> { 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) parse ~check errors rest (push_mode mode stack)
| (Unwrapped _ | Wrapped _) :: _, | (Unwrapped _ | Wrapped _) :: _,
{ token = Int value ; loc } :: rest { 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 expr : node = String (loc, contents) in
let errors = if check then do_check ~toplevel: false errors expr else errors in let errors = if check then do_check ~toplevel: false errors expr else errors in
parse ~check errors rest (fill_mode expr stack) parse ~check errors rest (fill_mode expr stack)
| Sequence ({ loc = { start } }, exprs, annot) :: _ , | Sequence ({ loc = { start } }, exprs) :: _ ,
{ token = Close_brace ; loc = { stop } } :: rest -> { token = Close_brace ; loc = { stop } } :: rest ->
let exprs = List.rev exprs in 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 let errors = if check then do_check ~toplevel: false errors expr else errors in
parse ~check errors rest (fill_mode expr (pop_mode stack)) parse ~check errors rest (fill_mode expr (pop_mode stack))
| (Sequence _ | Toplevel _) :: _ , | (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 let errors = if check then do_check ~toplevel: false errors expr else errors in
parse ~check errors rest (fill_mode expr (pop_mode stack)) parse ~check errors rest (fill_mode expr (pop_mode stack))
| (Wrapped _ | Unwrapped _) :: _ , | (Wrapped _ | Unwrapped _) :: _ ,
({ token = Open_paren } as token) :: { token = Ident name } :: { token = Annot annot } :: rest -> ({ token = Open_paren } as token) :: { token = Ident name } :: ({ token = Annot _ } :: _ as rest) ->
let mode = Wrapped (token, name, [], Some annot) in let annots, rest = annots rest in
let mode = Wrapped (token, name, [], annots) in
parse ~check errors rest (push_mode mode stack) parse ~check errors rest (push_mode mode stack)
| (Wrapped _ | Unwrapped _) :: _ , | (Wrapped _ | Unwrapped _) :: _ ,
({ token = Open_paren } as token) :: { token = Ident name } :: rest -> ({ 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) parse ~check errors rest (push_mode mode stack)
| (Wrapped _ | Unwrapped _) :: _ , | (Wrapped _ | Unwrapped _) :: _ ,
{ token = Ident name ; loc } :: rest -> { 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 let errors = if check then do_check ~toplevel: false errors expr else errors in
parse ~check errors rest (fill_mode expr stack) 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) :: _ , | (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _ | Expression None) :: _ ,
({ token = Open_brace } as token) :: rest -> ({ 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) parse ~check errors rest (push_mode mode stack)
(* indentation checker *) (* indentation checker *)
and do_check ?(toplevel = false) errors = function and do_check ?(toplevel = false) errors = function
| Seq ({ start ; stop }, [], _) as expr -> | Seq ({ start ; stop }, []) as expr ->
if start.column >= stop.column then if start.column >= stop.column then
Misaligned expr :: errors Misaligned expr :: errors
else errors else errors
| Prim ({ start ; stop }, _, first :: rest, _) | 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 } = let { column = first_column ; line = first_line } =
min_point [ first ] in min_point [ first ] in
if start.column >= stop.column then if start.column >= stop.column then
@ -623,11 +627,12 @@ and do_check ?(toplevel = false) errors = function
let parse_expression ?check tokens = let parse_expression ?check tokens =
let result = match tokens with let result = match tokens with
| ({ token = Open_paren } as token) :: { token = Ident name } :: { token = Annot annot } :: rest -> | ({ token = Open_paren } as token) :: { token = Ident name } :: { token = Annot _ } :: rest ->
let mode = Wrapped (token, name, [], Some annot) in let annots, rest = annots rest in
let mode = Wrapped (token, name, [], annots) in
parse ?check [] rest [ mode ; Expression None ] parse ?check [] rest [ mode ; Expression None ]
| ({ token = Open_paren } as token) :: { token = Ident name } :: rest -> | ({ 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 [] rest [ mode ; Expression None ]
| _ -> | _ ->
parse ?check [] tokens [ Expression None ] in parse ?check [] tokens [ Expression None ] in

34
src/lib_micheline/micheline_printer.ml
View File

@ -42,9 +42,9 @@ let preformat root =
(false, 0) (false, 0)
| { comment = Some text } -> | { comment = Some text } ->
(String.contains text '\n', String.length text + 1) in (String.contains text '\n', String.length text + 1) in
let preformat_annot = function let preformat_annots = function
| None -> 0 | [] -> 0
| Some annot -> String.length annot + 2 in | annots -> String.length (String.concat " " annots) + 2 in
let rec preformat_expr = function let rec preformat_expr = function
| Int (loc, value) -> | Int (loc, value) ->
let cml, csz = preformat_loc loc in let cml, csz = preformat_loc loc in
@ -52,9 +52,9 @@ let preformat root =
| String (loc, value) -> | String (loc, value) ->
let cml, csz = preformat_loc loc in let cml, csz = preformat_loc loc in
String ((cml, String.length value + csz, loc), value) 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 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 items = List.map preformat_expr items in
let ml, sz = let ml, sz =
List.fold_left List.fold_left
@ -63,26 +63,25 @@ let preformat root =
(tml || ml, tsz + 1 + sz)) (tml || ml, tsz + 1 + sz))
(cml, String.length name + csz + asz) (cml, String.length name + csz + asz)
items in items in
Prim ((ml, sz, loc), name, items, annot) Prim ((ml, sz, loc), name, items, annots)
| Seq (loc, items, annot) -> | Seq (loc, items) ->
let cml, csz = preformat_loc loc in let cml, csz = preformat_loc loc in
let asz = preformat_annot annot in
let items = List.map preformat_expr items in let items = List.map preformat_expr items in
let ml, sz = let ml, sz =
List.fold_left List.fold_left
(fun (tml, tsz) e -> (fun (tml, tsz) e ->
let (ml, sz, _) = location e in let (ml, sz, _) = location e in
(tml || ml, tsz + 3 + sz)) (tml || ml, tsz + 3 + sz))
(cml, 4 + csz + asz) (cml, 4 + csz)
items in items in
Seq ((ml, sz, loc), items, annot) in Seq ((ml, sz, loc), items) in
preformat_expr root preformat_expr root
let rec print_expr_unwrapped ppf = function let rec print_expr_unwrapped ppf = function
| Prim ((ml, s, { comment }), name, args, annot) -> | Prim ((ml, s, { comment }), name, args, annot) ->
let name = match annot with let name = match annot with
| None -> name | [] -> name
| Some annot -> Format.asprintf "%s %s" name annot in | 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 not ml && s < 80 then begin
if args = [] then if args = [] then
Format.fprintf ppf "%s" name Format.fprintf ppf "%s" name
@ -114,18 +113,13 @@ let rec print_expr_unwrapped ppf = function
| None -> print_string ppf value | None -> print_string ppf value
| Some comment -> Format.fprintf ppf "%a@ %a" print_string value print_comment comment | Some comment -> Format.fprintf ppf "%a@ %a" print_string value print_comment comment
end end
| Seq ((_, _, { comment = None }), [], None) -> | Seq ((_, _, { comment = None }), []) ->
Format.fprintf ppf "{}" Format.fprintf ppf "{}"
| Seq ((ml, s, { comment }), items, annot) -> | Seq ((ml, s, { comment }), items) ->
if not ml && s < 80 then if not ml && s < 80 then
Format.fprintf ppf "{ @[<h 0>" Format.fprintf ppf "{ @[<h 0>"
else else
Format.fprintf ppf "{ @[<v 0>" ; 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 begin match comment, items with
| None, _ -> () | None, _ -> ()
| Some comment, [] -> Format.fprintf ppf "%a" print_comment comment | 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 and print_expr ppf = function
| Prim (_, _, _ :: _, _) | Prim (_, _, _ :: _, _)
| Prim (_, _, [], Some _) as expr -> | Prim (_, _, [], _ :: _) as expr ->
Format.fprintf ppf "(%a)" print_expr_unwrapped expr Format.fprintf ppf "(%a)" print_expr_unwrapped expr
| expr -> print_expr_unwrapped ppf 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 = type ('l, 'p) node =
| Int of 'l * Z.t | Int of 'l * Z.t
| String of 'l * string | String of 'l * string
| Prim of 'l * 'p * ('l, 'p) node list * string option | Prim of 'l * 'p * ('l, 'p) node list * string list
| Seq of 'l * ('l, 'p) node list * string option | Seq of 'l * ('l, 'p) node list
type 'p canonical type 'p canonical
type canonical_location = int 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 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 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 strip_locations : (_, 'p) node -> 'p canonical
val extract_locations : ('l, 'p) node -> 'p canonical * (canonical_location * 'l) list 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 () ok ()
| errors -> Error errors | errors -> Error errors
let left_branch = Seq(zero_loc, [ Prim(zero_loc, "SWAP", [], None) ], None) let left_branch = Seq(zero_loc, [ Prim(zero_loc, "SWAP", [], []) ])
let right_branch = Seq(zero_loc, [ ], None) let right_branch = Seq(zero_loc, [])
let test_expansion () = let test_expansion () =
assert_expands (Prim (zero_loc, "CAAR", [], None)) assert_expands (Prim (zero_loc, "CAAR", [], []))
(Seq (zero_loc, (Seq (zero_loc,
[(Prim (zero_loc, "CAR", [], None)); [(Prim (zero_loc, "CAR", [], []));
(Prim (zero_loc, "CAR", [], None)) ], (Prim (zero_loc, "CAR", [], [])) ])) >>? fun () ->
None)) >>? fun () -> assert_expands (Prim (zero_loc, "CAAR", [], [ "annot" ]))
assert_expands (Prim (zero_loc, "CAAR", [], Some "annot"))
(Seq (zero_loc, (Seq (zero_loc,
[(Prim (zero_loc, "CAR", [], None)); [(Prim (zero_loc, "CAR", [], []));
(Prim (zero_loc, "CAR", [], Some "annot")) ], (Prim (zero_loc, "CAR", [], [ "annot" ])) ])) >>? fun () ->
None)) >>? fun () -> let car = Prim (zero_loc, "CAR", [], [ "annot" ]) in
let car = Prim (zero_loc, "CAR", [], Some "annot") in
assert_expands car car >>? fun () -> assert_expands car car >>? fun () ->
let arg = [ Seq (zero_loc, [ car ], None) ] in let arg = [ Seq (zero_loc, [ car ]) ] in
assert_expands assert_expands
(Prim (zero_loc, "DIP", arg, Some "new_annot")) (Prim (zero_loc, "DIP", arg, [ "new_annot" ]))
(Prim (zero_loc, "DIP", arg, Some "new_annot")) >>? fun () -> (Prim (zero_loc, "DIP", arg, [ "new_annot" ])) >>? fun () ->
assert_expands assert_expands
(Prim (zero_loc, "DIIP", arg, None)) (Prim (zero_loc, "DIIP", arg, []))
(Seq (zero_loc, (Seq (zero_loc,
[ Prim (zero_loc, "DIP", [ Prim (zero_loc, "DIP",
[ (Seq (zero_loc, [ (Seq (zero_loc,
[ Prim (zero_loc, "DIP", arg, None) ], [ Prim (zero_loc, "DIP", arg, []) ])) ],
None)) ], []) ])) >>? fun () ->
None) ],
None)) >>? fun () ->
assert_expands assert_expands
(Prim (zero_loc, "DIIIP", arg, None)) (Prim (zero_loc, "DIIIP", arg, []))
(Seq (zero_loc, (Seq (zero_loc,
[ Prim (zero_loc, "DIP", [ Prim (zero_loc, "DIP",
[ (Seq (zero_loc, [ (Seq (zero_loc,
[ Prim (zero_loc, [ Prim (zero_loc,
"DIP", "DIP",
[ (Seq (zero_loc, [ (Seq (zero_loc,
[ Prim (zero_loc, "DIP", arg, None) ], [ Prim (zero_loc, "DIP", arg, []) ])) ],
None)) ], []) ])) ],
None) ], []) ])) >>? fun () ->
None)) ],
None) ],
None)) >>? fun () ->
assert_expands assert_expands
(Prim (zero_loc, "DUUP", [], None)) (Prim (zero_loc, "DUUP", [], []))
(Seq (zero_loc, (Seq (zero_loc,
[ Prim (zero_loc, "DIP", [ Seq (zero_loc, [ Prim (zero_loc, "DUP", [], None) ], None) ], None) ; [ Prim (zero_loc, "DIP", [ Seq (zero_loc, [ Prim (zero_loc, "DUP", [], []) ]) ], []) ;
Prim (zero_loc, "SWAP", [], None) ], None)) >>? fun () -> Prim (zero_loc, "SWAP", [], []) ])) >>? fun () ->
assert_expands assert_expands
(Prim (zero_loc, "DUUUP", [], None)) (Prim (zero_loc, "DUUUP", [], []))
(Seq (zero_loc, (Seq (zero_loc,
[ Prim (zero_loc, "DIP", [ Prim (zero_loc, "DIP",
[ Seq (zero_loc, [ [ Seq (zero_loc, [
Prim (zero_loc, "DIP", [ Prim (zero_loc, "DIP", [
Seq (zero_loc, [ Prim (zero_loc, "DUP", [], None) ], None)], Seq (zero_loc, [ Prim (zero_loc, "DUP", [], []) ])],
None); []);
Prim (zero_loc, "SWAP", [], None) ], Prim (zero_loc, "SWAP", [], []) ]) ],
None) ], []) ;
None) ; Prim (zero_loc, "SWAP", [], []) ])) >>? fun () ->
Prim (zero_loc, "SWAP", [], None) ], None)) >>? fun () ->
let assert_compare_macro prim_name compare_name = let assert_compare_macro prim_name compare_name =
assert_expands assert_expands
(Prim (zero_loc, prim_name, [], None)) (Prim (zero_loc, prim_name, [], []))
(Seq (zero_loc, (Seq (zero_loc,
[ Prim (zero_loc, "COMPARE", [], None) ; [ Prim (zero_loc, "COMPARE", [], []) ;
Prim (zero_loc, compare_name, [], None) ], None)) in Prim (zero_loc, compare_name, [], []) ])) in
let assert_compare_if_macro prim_name compare_name = let assert_compare_if_macro prim_name compare_name =
assert_expands assert_expands
(Prim (zero_loc, prim_name, (Prim (zero_loc, prim_name,
[ left_branch ; right_branch ], [ left_branch ; right_branch ],
None)) []))
(Seq (zero_loc, [ Prim(zero_loc, "COMPARE", [], None); (Seq (zero_loc, [ Prim(zero_loc, "COMPARE", [], []);
Prim(zero_loc, compare_name, [], None); Prim(zero_loc, compare_name, [], []);
Prim (zero_loc, "IF", [ left_branch ; right_branch ], None) ], None)) in Prim (zero_loc, "IF", [ left_branch ; right_branch ], []) ])) in
assert_compare_macro "CMPEQ" "EQ" >>? fun () -> assert_compare_macro "CMPEQ" "EQ" >>? fun () ->
assert_compare_macro "CMPNEQ" "NEQ" >>? fun () -> assert_compare_macro "CMPNEQ" "NEQ" >>? fun () ->
assert_compare_macro "CMPLT" "LT" >>? 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 "IFCMPLE" "LE" >>? fun () ->
assert_compare_if_macro "IFCMPGT" "GT" >>? fun () -> assert_compare_if_macro "IFCMPGT" "GT" >>? fun () ->
assert_compare_if_macro "IFCMPGE" "GE" >>? 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, [ Prim (zero_loc, "IF_LEFT",
[ Seq (zero_loc, [ ], None) ; [ Seq (zero_loc, []) ;
Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], None) ], None) ], Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], []) ]) ],
None) ], None)) >>? fun () -> []) ])) >>? fun () ->
assert_expands (Prim (zero_loc, "ASSERT_RIGHT", [], None)) assert_expands (Prim (zero_loc, "ASSERT_RIGHT", [], []))
(Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT", (Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT",
[ Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], None) ], None) ; [ Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], []) ]) ;
Seq (zero_loc, [ ], None) ], Seq (zero_loc, []) ],
None) ], None)) >>? fun () -> []) ])) >>? fun () ->
assert_expands (Prim (zero_loc, "IF_RIGHT", [ left_branch ; right_branch ], None)) assert_expands (Prim (zero_loc, "IF_RIGHT", [ left_branch ; right_branch ], []))
(Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT", [ right_branch ; left_branch ], None) ], None)) >>? fun () -> (Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT", [ right_branch ; left_branch ], []) ])) >>? fun () ->
assert_expands (Prim (zero_loc, "IF_SOME", [ left_branch ; right_branch ], None)) assert_expands (Prim (zero_loc, "IF_SOME", [ left_branch ; right_branch ], []))
(Seq (zero_loc, [ Prim (zero_loc, "IF_NONE", [ right_branch ; left_branch ], None) ], None)) >>? fun () -> (Seq (zero_loc, [ Prim (zero_loc, "IF_NONE", [ right_branch ; left_branch ], []) ])) >>? fun () ->
assert_expands assert_expands
(Prim (zero_loc, "PAIR", [], None)) (Prim (zero_loc, "PAIR", [], []))
(Prim (zero_loc, "PAIR", [], None)) >>? fun () -> (Prim (zero_loc, "PAIR", [], [])) >>? fun () ->
assert_expands assert_expands
(Prim (zero_loc, "PAAIR", [], None)) (Prim (zero_loc, "PAAIR", [], []))
(Seq (zero_loc, (Seq (zero_loc,
[Prim [Prim
(zero_loc, (zero_loc,
"DIP", "DIP",
[Seq (zero_loc, [Prim [Seq (zero_loc, [Prim (zero_loc, "PAIR", [], [])])],
(zero_loc, "PAIR", [], None)], [])])) >>? fun () ->
None)],
None)],
None)) >>? fun () ->
assert_expands assert_expands
(Prim (zero_loc, "PAAIAIR", [], None)) (Prim (zero_loc, "PAAIAIR", [], []))
(Seq (zero_loc, [Prim (Seq (zero_loc, [Prim
(zero_loc, (zero_loc,
"DIP", "DIP",
[Seq [Seq
(zero_loc, (zero_loc,
[Prim [Prim (zero_loc, "PAIR", [], [])])],
(zero_loc, []);
"PAIR", [], None)], Prim (zero_loc, "PAIR", [], [])]))
None)],
None);
Prim
(zero_loc,
"PAIR", [], None)],
None))
let assert_unexpansion_consistent original = let assert_unexpansion_consistent original =
let { Michelson_v1_parser.expanded }, errors = let { Michelson_v1_parser.expanded }, errors =
@ -259,30 +242,30 @@ let assert_unexpansion_consistent original =
ok () ok ()
let test_unexpansion_consistency () = let test_unexpansion_consistency () =
assert_unexpansion_consistent (Prim (zero_loc, "PAAAIAIR", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "PAAAIAIR", [], [])) >>? fun () ->
assert_unexpansion_consistent assert_unexpansion_consistent
(Prim (zero_loc, "DIIIP", [ Seq (zero_loc, [ Prim (zero_loc, "DROP", [], None) ], None) ], None)) >>? fun () -> (Prim (zero_loc, "DIIIP", [ Seq (zero_loc, [ Prim (zero_loc, "DROP", [], []) ]) ], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "SET_CAR", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "SET_CAR", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "SET_CDR", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "SET_CDR", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUP", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "DUP", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUUP", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "DUUP", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUUUP", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "DUUUP", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUUUUP", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "DUUUUP", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "DUUUUUP", [], None)) >>? 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_EQ", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_NEQ", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_NEQ", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LT", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LT", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LE", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LE", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_GT", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_GT", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_GE", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_GE", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_NONE", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_NONE", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_SOME", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_SOME", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LEFT", [], None)) >>? fun () -> assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LEFT", [], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_RIGHT", [], None)) >>? 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_RIGHT", [ left_branch ; right_branch], [])) >>? fun () ->
assert_unexpansion_consistent (Prim (zero_loc, "IF_SOME", [ left_branch ; right_branch], None)) assert_unexpansion_consistent (Prim (zero_loc, "IF_SOME", [ left_branch ; right_branch], []))
let test_lexing () = let test_lexing () =
let open Micheline_parser in let open Micheline_parser in
@ -329,96 +312,96 @@ let test_parsing () =
ok () in ok () in
assert_parses "PUSH int 100" assert_parses "PUSH int 100"
[ (Prim ((), "PUSH", [ Prim ((), "int", [], None) ; [ (Prim ((), "PUSH", [ Prim ((), "int", [], []) ;
Int ((), Z.of_int 100) ], None)) ] >>? fun () -> Int ((), Z.of_int 100) ], [])) ] >>? fun () ->
assert_parses "DROP" [ (Prim ((), "DROP", [], None)) ] >>? fun () -> assert_parses "DROP" [ (Prim ((), "DROP", [], [])) ] >>? fun () ->
assert_parses "DIP{DROP}" assert_parses "DIP{DROP}"
[ Prim ((), "DIP", [ Seq((), [ Prim ((), "DROP", [], None) ], None) ], None) ] >>? fun () -> [ Prim ((), "DIP", [ Seq((), [ Prim ((), "DROP", [], []) ]) ], []) ] >>? fun () ->
assert_parses "LAMBDA int int {}" assert_parses "LAMBDA int int {}"
[ Prim ((), "LAMBDA", [ Prim ((), "int", [], None) ; [ Prim ((), "LAMBDA", [ Prim ((), "int", [], []) ;
Prim ((), "int", [], None) ; Prim ((), "int", [], []) ;
Seq ((), [ ], None) ], None) ] >>? fun () -> Seq ((), []) ], []) ] >>? fun () ->
assert_parses "LAMBDA @name int int {}" assert_parses "LAMBDA @name int int {}"
[ Prim ((), "LAMBDA", [ Prim ((), "int", [], None) ; [ Prim ((), "LAMBDA", [ Prim ((), "int", [], []) ;
Prim ((), "int", [], None) ; Prim ((), "int", [], []) ;
Seq ((), [ ], None) ], Some "@name") ] >>? fun () -> Seq ((), []) ], [ "@name" ]) ] >>? fun () ->
assert_parses "NIL @annot string; # comment\n" 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\")" assert_parses "PUSH (pair bool string) (Pair False \"abc\")"
[ Prim ((), "PUSH", [ Prim ((), "pair", [ Prim ((), "PUSH", [ Prim ((), "pair",
[ Prim ((), "bool", [], None) ; [ Prim ((), "bool", [], []) ;
Prim ((), "string", [], None) ], None) ; Prim ((), "string", [], []) ], []) ;
Prim ((), "Pair", Prim ((), "Pair",
[ Prim ((), "False", [], None) ; [ Prim ((), "False", [], []) ;
String ((), "abc")], None) ], None) ] >>? fun () -> String ((), "abc")], []) ], []) ] >>? fun () ->
assert_parses "PUSH (list nat) (List 1 2 3)" assert_parses "PUSH (list nat) (List 1 2 3)"
[ Prim ((), "PUSH", [ Prim ((), "list", [ Prim ((), "PUSH", [ Prim ((), "list",
[ Prim ((), "nat", [], None) ], None) ; [ Prim ((), "nat", [], []) ], []) ;
Prim ((), "List", Prim ((), "List",
[ Int((), Z.of_int 1); [ Int((), Z.of_int 1);
Int ((), Z.of_int 2); Int ((), Z.of_int 2);
Int ((), Z.of_int 3)], Int ((), Z.of_int 3)],
None) ], None) ] >>? fun () -> []) ], []) ] >>? fun () ->
assert_parses "PUSH (lambda nat nat) {}" assert_parses "PUSH (lambda nat nat) {}"
[ Prim ((), "PUSH", [ Prim ((), "lambda", [ Prim ((), "PUSH", [ Prim ((), "lambda",
[ Prim ((), "nat", [], None); [ Prim ((), "nat", [], []);
Prim ((), "nat", [], None)], None) ; Prim ((), "nat", [], [])], []) ;
Seq((), [], None)], Seq((), [])],
None) ] >>? fun () -> []) ] >>? fun () ->
assert_parses "PUSH key \"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx\"" assert_parses "PUSH key \"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx\""
[ Prim ((), "PUSH", [ Prim ((), "key", [], None) ; [ Prim ((), "PUSH", [ Prim ((), "key", [], []) ;
String ((),"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") ], String ((),"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") ],
None) ] >>? fun () -> []) ] >>? fun () ->
assert_parses "PUSH (map int bool) (Map (Item 100 False))" assert_parses "PUSH (map int bool) (Map (Item 100 False))"
[ Prim ((), "PUSH", [ Prim ((), "map", [ Prim ((), "PUSH", [ Prim ((), "map",
[ Prim((), "int", [], None); [ Prim((), "int", [], []);
Prim((), "bool", [], None)], None) ; Prim((), "bool", [], [])], []) ;
Prim ((), "Map", Prim ((), "Map",
[Prim ((), "Item", [Prim ((), "Item",
[Int ((), Z.of_int 100); [Int ((), Z.of_int 100);
Prim ((), "False", [], None)], None)], None) ], Prim ((), "False", [], [])], [])], []) ],
None) ] >>? fun () -> []) ] >>? fun () ->
assert_parses assert_parses
"parameter int; \ "parameter int; \
return int; \ return int; \
storage unit; \ storage unit; \
code {}" code {}"
[ Prim ((), "parameter", [ Prim((), "int", [], None) ], None); [ Prim ((), "parameter", [ Prim((), "int", [], []) ], []);
Prim ((), "return", [ Prim((), "int", [], None) ], None); Prim ((), "return", [ Prim((), "int", [], []) ], []);
Prim ((), "storage", [ Prim((), "unit", [], None) ], None); Prim ((), "storage", [ Prim((), "unit", [], []) ], []);
Prim ((), "code", [ Seq((), [], None) ], None)] >>? fun () -> Prim ((), "code", [ Seq((), []) ], [])] >>? fun () ->
assert_parses assert_parses
"parameter int; \ "parameter int; \
storage unit; \ storage unit; \
return int; \ return int; \
code {CAR; PUSH int 1; ADD; UNIT; SWAP; PAIR};" code {CAR; PUSH int 1; ADD; UNIT; SWAP; PAIR};"
[ Prim ((), "parameter", [ Prim((), "int", [], None) ], None); [ Prim ((), "parameter", [ Prim((), "int", [], []) ], []);
Prim ((), "storage", [ Prim((), "unit", [], None) ], None); Prim ((), "storage", [ Prim((), "unit", [], []) ], []);
Prim ((), "return", [ Prim((), "int", [], None) ], None); Prim ((), "return", [ Prim((), "int", [], []) ], []);
Prim ((), "code", [ Seq((), [ Prim ((), "CAR", [], None) ; Prim ((), "code", [ Seq((), [ Prim ((), "CAR", [], []) ;
Prim ((), "PUSH", [ Prim((), "int", [], None) ; Prim ((), "PUSH", [ Prim((), "int", [], []) ;
Int ((), Z.of_int 1)], None) ; Int ((), Z.of_int 1)], []) ;
Prim ((), "ADD", [], None) ; Prim ((), "ADD", [], []) ;
Prim ((), "UNIT", [], None) ; Prim ((), "UNIT", [], []) ;
Prim ((), "SWAP", [], None) ; Prim ((), "SWAP", [], []) ;
Prim ((), "PAIR", [], None)], None) ], None)] >>? fun () -> Prim ((), "PAIR", [], [])]) ], [])] >>? fun () ->
assert_parses assert_parses
"code {DUP @test; DROP}" "code {DUP @test; DROP}"
[ Prim ((), "code", [Seq ((), [ Prim ((), "DUP", [], Some "@test"); [ Prim ((), "code", [Seq ((), [ Prim ((), "DUP", [], [ "@test" ]);
Prim ((), "DROP", [], None)], None)], None) ] >>? fun () -> Prim ((), "DROP", [], [])])], []) ] >>? fun () ->
assert_parses assert_parses
"IF {CAR} {CDR}" "IF {CAR} {CDR}"
[ Prim ((), "IF", [ Seq ((), [ Prim ((), "CAR", [], None) ], None); [ Prim ((), "IF", [ Seq ((), [ Prim ((), "CAR", [], []) ]);
Seq ((), [ Prim ((), "CDR", [], None) ], None) ], None) ] >>? fun () -> Seq ((), [ Prim ((), "CDR", [], []) ]) ], []) ] >>? fun () ->
assert_parses assert_parses
"IF_NONE {FAIL} {}" "IF_NONE {FAIL} {}"
[ Prim ((), "IF_NONE", [ Seq ((), [ Prim ((), "FAIL", [], None) ], None); [ Prim ((), "IF_NONE", [ Seq ((), [ Prim ((), "FAIL", [], []) ]);
Seq ((), [ ], None) ], None) ] Seq ((), []) ], []) ]
let tests = [ let tests = [
"lexing", (fun _ -> Lwt.return (test_lexing ())) ; "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_expr ppf expr =
let print_annot ppf = function 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 let rec print_expr ppf = function
| Int (_, value) -> Format.fprintf ppf "%s" (Z.to_string value) | Int (_, value) -> Format.fprintf ppf "%s" (Z.to_string value)
| String (_, value) -> Micheline_printer.print_string ppf value | String (_, value) -> Micheline_printer.print_string ppf value
| Seq (_, items, annot) -> | Seq (_, items) ->
Format.fprintf ppf "(seq%a %a)" Format.fprintf ppf "(seq %a)"
print_annot annot
(Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr) (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
items items
| Prim (_, name, [], None) -> | Prim (_, name, [], []) ->
Format.fprintf ppf "%s" name Format.fprintf ppf "%s" name
| Prim (_, name, items, annot) -> | Prim (_, name, items, annot) ->
Format.fprintf ppf "(%s%a%s%a)" Format.fprintf ppf "(%s%a%s%a)"
@ -39,12 +38,12 @@ open Script_tc_errors
let print_type_map ppf (parsed, type_map) = let print_type_map ppf (parsed, type_map) =
let rec print_expr_types ppf = function let rec print_expr_types ppf = function
| Seq (loc, [], _) | Seq (loc, [])
| Prim (loc, _, [], _) | Prim (loc, _, [], _)
| Int (loc, _) | Int (loc, _)
| String (loc, _) -> | String (loc, _) ->
print_item ppf loc print_item ppf loc
| Seq (loc, items, _) | Seq (loc, items)
| Prim (loc, _, items, _) -> | Prim (loc, _, items, _) ->
print_item ppf loc ; print_item ppf loc ;
List.iter (print_expr_types ppf) items 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) | Some s -> Format.fprintf ppf "%s " s)
name name
print_source (parsed, hilights) print_source (parsed, hilights)
print_ty (None, ty) ; print_ty ([], ty) ;
if rest <> [] then Format.fprintf ppf "@," ; if rest <> [] then Format.fprintf ppf "@," ;
print_trace (parsed_locations parsed) rest print_trace (parsed_locations parsed) rest
| Alpha_environment.Ecoproto_error (Ill_formed_type (_, expr, loc)) :: 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.@]@]" @[<hov 2>and@ %a.@]@]"
print_loc loc print_loc loc
(Michelson_v1_primitives.string_of_prim name) (Michelson_v1_primitives.string_of_prim name)
print_ty (None, tya) print_ty ([], tya)
print_ty (None, tyb) print_ty ([], tyb)
| Undefined_unop (loc, name, ty) -> | Undefined_unop (loc, name, ty) ->
Format.fprintf ppf Format.fprintf ppf
"@[<hov 0>@[<hov 2>%aoperator %s is undefined on@ %a@]@]" "@[<hov 0>@[<hov 2>%aoperator %s is undefined on@ %a@]@]"
print_loc loc print_loc loc
(Michelson_v1_primitives.string_of_prim name) (Michelson_v1_primitives.string_of_prim name)
print_ty (None, ty) print_ty ([], ty)
| Bad_return (loc, got, exp) -> | Bad_return (loc, got, exp) ->
Format.fprintf ppf Format.fprintf ppf
"@[<v 2>%awrong stack type at end of body:@,\ "@[<v 2>%awrong stack type at end of body:@,\
- @[<v 0>expected return stack type:@ %a,@]@,\ - @[<v 0>expected return stack type:@ %a,@]@,\
- @[<v 0>actual stack type:@ %a.@]@]" - @[<v 0>actual stack type:@ %a.@]@]"
print_loc loc 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 (fun ppf -> print_stack_ty ppf) got
| Bad_stack (loc, name, depth, sty) -> | Bad_stack (loc, name, depth, sty) ->
Format.fprintf ppf Format.fprintf ppf
@ -358,17 +358,18 @@ let report_errors ~details ~show_source ?parsed ppf errs =
| Inconsistent_annotations (annot1, annot2) -> | Inconsistent_annotations (annot1, annot2) ->
Format.fprintf ppf Format.fprintf ppf
"@[<v 2>The two annotations do not match:@,\ "@[<v 2>The two annotations do not match:@,\
- @[<hov>%s@]@,\ - @[<v>%a@]@,\
- @[<hov>%s@]" - @[<v>%a@]@]"
annot1 annot2 (Format.pp_print_list Format.pp_print_string) annot1
(Format.pp_print_list Format.pp_print_string) annot2
| Inconsistent_type_annotations (loc, ty1, ty2) -> | Inconsistent_type_annotations (loc, ty1, ty2) ->
Format.fprintf ppf Format.fprintf ppf
"@[<v 2>%athe two types contain incompatible annotations:@,\ "@[<v 2>%athe two types contain incompatible annotations:@,\
- @[<hov>%a@]@,\ - @[<hov>%a@]@,\
- @[<hov>%a@]" - @[<hov>%a@]@]"
print_loc loc print_loc loc
print_ty (None, ty1) print_ty ([], ty1)
print_ty (None, ty2) print_ty ([], ty2)
| Unexpected_annotation loc -> | Unexpected_annotation loc ->
Format.fprintf ppf Format.fprintf ppf
"@[<v 2>%aunexpected annotation." "@[<v 2>%aunexpected annotation."
@ -395,7 +396,7 @@ let report_errors ~details ~show_source ?parsed ppf errs =
@[<hov 2>is invalid for type@ %a.@]@]" @[<hov 2>is invalid for type@ %a.@]@]"
print_loc loc print_loc loc
print_expr got print_expr got
print_ty (None, exp) print_ty ([], exp)
| Invalid_contract (loc, contract) -> | Invalid_contract (loc, contract) ->
Format.fprintf ppf Format.fprintf ppf
"%ainvalid contract %a." "%ainvalid contract %a."
@ -404,13 +405,13 @@ let report_errors ~details ~show_source ?parsed ppf errs =
Format.fprintf ppf "%acomparable type expected." Format.fprintf ppf "%acomparable type expected."
print_loc loc ; print_loc loc ;
Format.fprintf ppf "@[<hov 0>@[<hov 2>Type@ %a@]@ is not comparable.@]" Format.fprintf ppf "@[<hov 0>@[<hov 2>Type@ %a@]@ is not comparable.@]"
print_ty (None, ty) print_ty ([], ty)
| Inconsistent_types (tya, tyb) -> | Inconsistent_types (tya, tyb) ->
Format.fprintf ppf Format.fprintf ppf
"@[<hov 0>@[<hov 2>Type@ %a@]@ \ "@[<hov 0>@[<hov 2>Type@ %a@]@ \
@[<hov 2>is not compatible with type@ %a.@]@]" @[<hov 2>is not compatible with type@ %a.@]@]"
print_ty (None, tya) print_ty ([], tya)
print_ty (None, tyb) print_ty ([], tyb)
| Reject loc -> | Reject loc ->
Format.fprintf ppf "%ascript reached FAIL instruction" Format.fprintf ppf "%ascript reached FAIL instruction"
print_loc loc print_loc loc

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

@ -32,16 +32,16 @@ let expand_caddadr original =
| [] -> ok () | [] -> ok ()
| _ :: _ -> error (Invalid_arity (str, List.length args, 0)) | _ :: _ -> error (Invalid_arity (str, List.length args, 0))
end >>? fun () -> end >>? fun () ->
let rec parse i ?annot acc = let rec parse i annot acc =
if i = 0 then if i = 0 then
Seq (loc, acc, None) Seq (loc, acc)
else 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 match String.get str i with
| 'A' -> parse (i - 1) (Prim (loc, "CAR", [], annot) :: acc) | 'A' -> parse (i - 1) [] (Prim (loc, "CAR", [], annot) :: acc)
| 'D' -> parse (i - 1) (Prim (loc, "CDR", [], annot) :: acc) | 'D' -> parse (i - 1) [] (Prim (loc, "CDR", [], annot) :: acc)
| _ -> assert false in | _ -> assert false in
ok (Some (parse (len - 2) ?annot [])) ok (Some (parse (len - 2) annot []))
else else
ok None ok None
| _ -> ok None | _ -> ok None
@ -67,45 +67,45 @@ let expand_set_caddadr original =
| 'A' -> | 'A' ->
let acc = let acc =
Seq (loc, Seq (loc,
[ Prim (loc, "DUP", [], None) ; [ Prim (loc, "DUP", [], []) ;
Prim (loc, "DIP", Prim (loc, "DIP",
[ Seq (loc, [ Seq (loc,
[ Prim (loc, "CAR", [], None) ; [ Prim (loc, "CAR", [], []) ;
acc ], None) ], None) ; acc ]) ], []) ;
Prim (loc, "CDR", [], None) ; Prim (loc, "CDR", [], []) ;
Prim (loc, "SWAP", [], None) ; Prim (loc, "SWAP", [], []) ;
Prim (loc, "PAIR", [], None) ], None) in Prim (loc, "PAIR", [], []) ]) in
parse (i - 1) acc parse (i - 1) acc
| 'D' -> | 'D' ->
let acc = let acc =
Seq (loc, Seq (loc,
[ Prim (loc, "DUP", [], None) ; [ Prim (loc, "DUP", [], []) ;
Prim (loc, "DIP", Prim (loc, "DIP",
[ Seq (loc, [ Seq (loc,
[ Prim (loc, "CDR", [], None) ; [ Prim (loc, "CDR", [], []) ;
acc ], None) ], None) ; acc ]) ], []) ;
Prim (loc, "CAR", [], None) ; Prim (loc, "CAR", [], []) ;
Prim (loc, "PAIR", [], None) ], None) in Prim (loc, "PAIR", [], []) ]) in
parse (i - 1) acc parse (i - 1) acc
| _ -> assert false in | _ -> assert false in
match String.get str (len - 2) with match String.get str (len - 2) with
| 'A' -> | 'A' ->
let init = let init =
Seq (loc, Seq (loc,
[ Prim (loc, "CDR", [], None) ; [ Prim (loc, "CDR", [], []) ;
Prim (loc, "SWAP", [], annot) ; Prim (loc, "SWAP", [], annot) ;
Prim (loc, "PAIR", [], None) ], None) in Prim (loc, "PAIR", [], []) ]) in
ok (Some (parse (len - 3) init)) ok (Some (parse (len - 3) init))
| 'D' -> | 'D' ->
let init = let init =
Seq (loc, Seq (loc,
(Prim (loc, "CAR", [], None)) :: (Prim (loc, "CAR", [], [])) ::
(let pair = Prim (loc, "PAIR", [], None) in (let pair = Prim (loc, "PAIR", [], []) in
match annot with match annot with
| None -> [ pair ] | [] -> [ pair ]
| Some _ -> [ Prim (loc, "SWAP", [], annot) ; | _ -> [ Prim (loc, "SWAP", [], annot) ;
Prim (loc, "SWAP", [], None) ; Prim (loc, "SWAP", [], []) ;
pair]), None) in pair])) in
ok (Some (parse (len - 3) init)) ok (Some (parse (len - 3) init))
| _ -> assert false | _ -> assert false
else else
@ -122,8 +122,8 @@ let expand_map_caddadr original =
&& check_letters str 5 (len - 2) && check_letters str 5 (len - 2)
(function 'A' | 'D' -> true | _ -> false) then (function 'A' | 'D' -> true | _ -> false) then
begin match annot with begin match annot with
| Some _ -> (error (Unexpected_macro_annotation str)) | _ :: _ -> (error (Unexpected_macro_annotation str))
| None -> ok () | [] -> ok ()
end >>? fun () -> end >>? fun () ->
begin match args with begin match args with
| [ Seq _ as code ] -> ok code | [ Seq _ as code ] -> ok code
@ -138,47 +138,47 @@ let expand_map_caddadr original =
| 'A' -> | 'A' ->
let acc = let acc =
Seq (loc, Seq (loc,
[ Prim (loc, "DUP", [], None) ; [ Prim (loc, "DUP", [], []) ;
Prim (loc, "DIP", Prim (loc, "DIP",
[ Seq (loc, [ Seq (loc,
[ Prim (loc, "CAR", [], None) ; [ Prim (loc, "CAR", [], []) ;
acc ], None) ], None) ; acc ]) ], []) ;
Prim (loc, "CDR", [], None) ; Prim (loc, "CDR", [], []) ;
Prim (loc, "SWAP", [], None) ; Prim (loc, "SWAP", [], []) ;
Prim (loc, "PAIR", [], None) ], None) in Prim (loc, "PAIR", [], []) ]) in
parse (i - 1) acc parse (i - 1) acc
| 'D' -> | 'D' ->
let acc = let acc =
Seq (loc, Seq (loc,
[ Prim (loc, "DUP", [], None) ; [ Prim (loc, "DUP", [], []) ;
Prim (loc, "DIP", Prim (loc, "DIP",
[ Seq (loc, [ Seq (loc,
[ Prim (loc, "CDR", [], None) ; [ Prim (loc, "CDR", [], []) ;
acc ], None) ], None) ; acc ]) ], []) ;
Prim (loc, "CAR", [], None) ; Prim (loc, "CAR", [], []) ;
Prim (loc, "PAIR", [], None) ], None) in Prim (loc, "PAIR", [], []) ]) in
parse (i - 1) acc parse (i - 1) acc
| _ -> assert false in | _ -> assert false in
match String.get str (len - 2) with match String.get str (len - 2) with
| 'A' -> | 'A' ->
let init = let init =
Seq (loc, Seq (loc,
[ Prim (loc, "DUP", [], None) ; [ Prim (loc, "DUP", [], []) ;
Prim (loc, "CDR", [], None) ; Prim (loc, "CDR", [], []) ;
Prim (loc, "DIP", Prim (loc, "DIP",
[ Seq (loc, [ Prim (loc, "CAR", [], None) ; code ], None) ], None) ; [ Seq (loc, [ Prim (loc, "CAR", [], []) ; code ]) ], []) ;
Prim (loc, "SWAP", [], None) ; Prim (loc, "SWAP", [], []) ;
Prim (loc, "PAIR", [], None) ], None) in Prim (loc, "PAIR", [], []) ]) in
ok (Some (parse (len - 3) init)) ok (Some (parse (len - 3) init))
| 'D' -> | 'D' ->
let init = let init =
Seq (loc, Seq (loc,
[ Prim (loc, "DUP", [], None) ; [ Prim (loc, "DUP", [], []) ;
Prim (loc, "CDR", [], None) ; Prim (loc, "CDR", [], []) ;
code ; code ;
Prim (loc, "SWAP", [], None) ; Prim (loc, "SWAP", [], []) ;
Prim (loc, "CAR", [], None) ; Prim (loc, "CAR", [], []) ;
Prim (loc, "PAIR", [], None) ], None) in Prim (loc, "PAIR", [], []) ]) in
ok (Some (parse (len - 3) init)) ok (Some (parse (len - 3) init))
| _ -> assert false | _ -> assert false
else else
@ -224,9 +224,9 @@ let expand_dxiiivp original =
acc acc
else else
make (i - 1) make (i - 1)
(Seq (loc, [ Prim (loc, "DIP", [ acc ], annot) ], None)) in (Seq (loc, [ Prim (loc, "DIP", [ acc ], annot) ])) in
match args with match args with
| [ Seq (_, _, _) as arg ] -> ok @@ Some (make depth arg) | [ Seq (_, _) as arg ] -> ok @@ Some (make depth arg)
| [ _ ] -> error (Sequence_expected str) | [ _ ] -> error (Sequence_expected str)
| [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1)) | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))
with Not_a_roman -> ok None with Not_a_roman -> ok None
@ -250,14 +250,14 @@ let expand_paaiair original =
acc acc
else if String.get str i = 'I' else if String.get str i = 'I'
&& String.get str (i - 1) = 'A' then && 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 else if String.get str i = 'A' then
match acc with match acc with
| [] -> | [] ->
raise_notrace Not_a_pair raise_notrace Not_a_pair
| acc :: accs -> | acc :: accs ->
parse (i - 1) parse (i - 1)
(Prim (loc, "DIP", [ Seq (loc, [ acc ], None) ], None) (Prim (loc, "DIP", [ Seq (loc, [ acc ]) ], [])
:: accs) :: accs)
else else
raise_notrace Not_a_pair in raise_notrace Not_a_pair in
@ -266,7 +266,7 @@ let expand_paaiair original =
| [] -> ok () | [] -> ok ()
| _ :: _ -> error (Invalid_arity (str, List.length args, 0)) | _ :: _ -> error (Invalid_arity (str, List.length args, 0))
end >>? fun () -> end >>? fun () ->
ok (Some (Seq (loc, expanded, None))) ok (Some (Seq (loc, expanded)))
with Not_a_pair -> ok None with Not_a_pair -> ok None
else else
ok None ok None
@ -274,7 +274,7 @@ let expand_paaiair original =
let expand_unpaaiair original = let expand_unpaaiair original =
match original with match original with
| Prim (loc, str, args, None) -> | Prim (loc, str, args, []) ->
let len = String.length str in let len = String.length str in
if len >= 6 if len >= 6
&& String.sub str 0 3 = "UNP" && String.sub str 0 3 = "UNP"
@ -286,16 +286,15 @@ let expand_unpaaiair original =
if i = 2 then if i = 2 then
match acc with match acc with
| [ Seq _ as acc ] -> acc | [ Seq _ as acc ] -> acc
| _ -> Seq (loc, List.rev acc, None) | _ -> Seq (loc, List.rev acc)
else if String.get str i = 'I' else if String.get str i = 'I'
&& String.get str (i - 1) = 'A' then && String.get str (i - 1) = 'A' then
parse (i - 2) parse (i - 2)
(Seq (loc, [ Prim (loc, "DUP", [], None) ; (Seq (loc, [ Prim (loc, "DUP", [], []) ;
Prim (loc, "CAR", [], None) ; Prim (loc, "CAR", [], []) ;
Prim (loc, "DIP", Prim (loc, "DIP",
[ Seq (loc, [ Seq (loc,
[ Prim (loc, "CDR", [], None) ], [ Prim (loc, "CDR", [], []) ]) ], []) ])
None) ], None) ], None)
:: acc) :: acc)
else if String.get str i = 'A' then else if String.get str i = 'A' then
match acc with match acc with
@ -303,12 +302,12 @@ let expand_unpaaiair original =
raise_notrace Not_a_pair raise_notrace Not_a_pair
| (Seq _ as acc) :: accs -> | (Seq _ as acc) :: accs ->
parse (i - 1) parse (i - 1)
(Prim (loc, "DIP", [ acc ], None) :: accs) (Prim (loc, "DIP", [ acc ], []) :: accs)
| acc :: accs -> | acc :: accs ->
parse (i - 1) parse (i - 1)
(Prim (loc, "DIP", (Prim (loc, "DIP",
[ Seq (loc, [ acc ], None) ], [ Seq (loc, [ acc ]) ],
None) :: accs) []) :: accs)
else else
raise_notrace Not_a_pair in raise_notrace Not_a_pair in
let expanded = parse (len - 2) [] in let expanded = parse (len - 2) [] in
@ -341,11 +340,11 @@ let expand_duuuuup original =
if i = 1 then acc if i = 1 then acc
else if String.get str i = 'U' then else if String.get str i = 'U' then
parse (i - 1) parse (i - 1)
(Seq (loc, [ Prim (loc, "DIP", [ acc ], None) ; (Seq (loc, [ Prim (loc, "DIP", [ acc ], []) ;
Prim (loc, "SWAP", [], None) ], None)) Prim (loc, "SWAP", [], []) ]))
else else
raise_notrace Not_a_dup in 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 with Not_a_dup -> ok None
else else
ok None ok None
@ -354,88 +353,88 @@ let expand_duuuuup original =
let expand_compare original = let expand_compare original =
let cmp loc is = let cmp loc is =
let is = let is =
List.map (fun i -> Prim (loc, i, [], None)) is in List.map (fun i -> Prim (loc, i, [], [])) is in
ok (Some (Seq (loc, is, None))) in ok (Some (Seq (loc, is))) in
let ifcmp loc is l r = let ifcmp loc is l r =
let is = let is =
List.map (fun i -> Prim (loc, i, [], None)) is @ List.map (fun i -> Prim (loc, i, [], [])) is @
[ Prim (loc, "IF", [ l ; r ], None) ] in [ Prim (loc, "IF", [ l ; r ], []) ] in
ok (Some (Seq (loc, is, None))) in ok (Some (Seq (loc, is))) in
match original with match original with
| Prim (loc, "CMPEQ", [], None) -> | Prim (loc, "CMPEQ", [], []) ->
cmp loc [ "COMPARE" ; "EQ" ] cmp loc [ "COMPARE" ; "EQ" ]
| Prim (loc, "CMPNEQ", [], None) -> | Prim (loc, "CMPNEQ", [], []) ->
cmp loc [ "COMPARE" ; "NEQ" ] cmp loc [ "COMPARE" ; "NEQ" ]
| Prim (loc, "CMPLT", [], None) -> | Prim (loc, "CMPLT", [], []) ->
cmp loc [ "COMPARE" ; "LT" ] cmp loc [ "COMPARE" ; "LT" ]
| Prim (loc, "CMPGT", [], None) -> | Prim (loc, "CMPGT", [], []) ->
cmp loc [ "COMPARE" ; "GT" ] cmp loc [ "COMPARE" ; "GT" ]
| Prim (loc, "CMPLE", [], None) -> | Prim (loc, "CMPLE", [], []) ->
cmp loc [ "COMPARE" ; "LE" ] cmp loc [ "COMPARE" ; "LE" ]
| Prim (loc, "CMPGE", [], None) -> | Prim (loc, "CMPGE", [], []) ->
cmp loc [ "COMPARE" ; "GE" ] cmp loc [ "COMPARE" ; "GE" ]
| Prim (_, ("CMPEQ" | "CMPNEQ" | "CMPLT" | 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)) 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 ifcmp loc [ "COMPARE" ; "EQ" ] l r
| Prim (loc, "IFCMPNEQ", [ l ; r ], None) -> | Prim (loc, "IFCMPNEQ", [ l ; r ], []) ->
ifcmp loc [ "COMPARE" ; "NEQ" ] 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 ifcmp loc [ "COMPARE" ; "LT" ] l r
| Prim (loc, "IFCMPGT", [ l ; r ], None) -> | Prim (loc, "IFCMPGT", [ l ; r ], []) ->
ifcmp loc [ "COMPARE" ; "GT" ] 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 ifcmp loc [ "COMPARE" ; "LE" ] l r
| Prim (loc, "IFCMPGE", [ l ; r ], None) -> | Prim (loc, "IFCMPGE", [ l ; r ], []) ->
ifcmp loc [ "COMPARE" ; "GE" ] l r ifcmp loc [ "COMPARE" ; "GE" ] l r
| Prim (loc, "IFEQ", [ l ; r ], None) -> | Prim (loc, "IFEQ", [ l ; r ], []) ->
ifcmp loc [ "EQ" ] l r ifcmp loc [ "EQ" ] l r
| Prim (loc, "IFNEQ", [ l ; r ], None) -> | Prim (loc, "IFNEQ", [ l ; r ], []) ->
ifcmp loc [ "NEQ" ] l r ifcmp loc [ "NEQ" ] l r
| Prim (loc, "IFLT", [ l ; r ], None) -> | Prim (loc, "IFLT", [ l ; r ], []) ->
ifcmp loc [ "LT" ] l r ifcmp loc [ "LT" ] l r
| Prim (loc, "IFGT", [ l ; r ], None) -> | Prim (loc, "IFGT", [ l ; r ], []) ->
ifcmp loc [ "GT" ] l r ifcmp loc [ "GT" ] l r
| Prim (loc, "IFLE", [ l ; r ], None) -> | Prim (loc, "IFLE", [ l ; r ], []) ->
ifcmp loc [ "LE" ] l r ifcmp loc [ "LE" ] l r
| Prim (loc, "IFGE", [ l ; r ], None) -> | Prim (loc, "IFGE", [ l ; r ], []) ->
ifcmp loc [ "GE" ] l r ifcmp loc [ "GE" ] l r
| Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT"
| "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE"
| "IFEQ" | "IFNEQ" | "IFLT" | "IFEQ" | "IFNEQ" | "IFLT"
| "IFGT" | "IFLE" | "IFGE" as str), args, None) -> | "IFGT" | "IFLE" | "IFGE" as str), args, []) ->
error (Invalid_arity (str, List.length args, 2)) error (Invalid_arity (str, List.length args, 2))
| Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT"
| "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE"
| "IFEQ" | "IFNEQ" | "IFLT" | "IFEQ" | "IFNEQ" | "IFLT"
| "IFGT" | "IFLE" | "IFGE" | "IFGT" | "IFLE" | "IFGE"
| "CMPEQ" | "CMPNEQ" | "CMPLT" | "CMPEQ" | "CMPNEQ" | "CMPLT"
| "CMPGT" | "CMPLE" | "CMPGE" as str), [], Some _) -> | "CMPGT" | "CMPLE" | "CMPGE" as str), [], _ :: _) ->
error (Unexpected_macro_annotation str) error (Unexpected_macro_annotation str)
| _ -> ok None | _ -> ok None
let expand_asserts original = let expand_asserts original =
let fail_false loc = 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 = 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 match original with
| Prim (loc, "ASSERT", [], None) -> | Prim (loc, "ASSERT", [], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF", fail_false loc, None) ], None)) ok @@ Some (Seq (loc, [ Prim (loc, "IF", fail_false loc, []) ]))
| Prim (loc, "ASSERT_NONE", [], None) -> | Prim (loc, "ASSERT_NONE", [], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_false loc, None) ], None)) ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_false loc, []) ]))
| Prim (loc, "ASSERT_SOME", [], None) -> | Prim (loc, "ASSERT_SOME", [], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_true loc, None) ], None)) ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_true loc, []) ]))
| Prim (loc, "ASSERT_LEFT", [], None) -> | Prim (loc, "ASSERT_LEFT", [], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_false loc, None) ], None)) ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_false loc, []) ]))
| Prim (loc, "ASSERT_RIGHT", [], None) -> | Prim (loc, "ASSERT_RIGHT", [], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_true loc, None) ], None)) ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_true loc, []) ]))
| Prim (_, ("ASSERT" | "ASSERT_NONE" | "ASSERT_SOME" | 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)) error (Invalid_arity (str, List.length args, 0))
| Prim (_, ("ASSERT" | "ASSERT_NONE" | "ASSERT_SOME" | Prim (_, ("ASSERT" | "ASSERT_NONE" | "ASSERT_SOME"
| "ASSERT_LEFT" | "ASSERT_RIGHT" as str), [], Some _) -> | "ASSERT_LEFT" | "ASSERT_RIGHT" as str), [], _ :: _) ->
error (Unexpected_macro_annotation str) error (Unexpected_macro_annotation str)
| Prim (loc, s, args, annot) | Prim (loc, s, args, annot)
when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") -> 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)) | _ :: _ -> error (Invalid_arity (s, List.length args, 0))
end >>? fun () -> end >>? fun () ->
begin match annot with begin match annot with
| Some _ -> (error (Unexpected_macro_annotation s)) | _ :: _ -> (error (Unexpected_macro_annotation s))
| None -> ok () end >>? fun () -> | [] -> ok () end >>? fun () ->
begin begin
let remaining = String.(sub s 7 ((length s) - 7)) in 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 match remaining with
| "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" -> | "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" ->
ok @@ Some (Seq (loc, [ remaining_prim ; ok @@ Some (Seq (loc, [ remaining_prim ;
Prim (loc, "IF", fail_false loc, None) ], None)) Prim (loc, "IF", fail_false loc, []) ]))
| _ -> | _ ->
begin begin
expand_compare remaining_prim >|? function expand_compare remaining_prim >|? function
| None -> None | None -> None
| Some seq -> | Some seq ->
Some (Seq (loc, [ seq ; Some (Seq (loc, [ seq ;
Prim (loc, "IF", fail_false loc, None) ], None)) Prim (loc, "IF", fail_false loc, []) ]))
end end
end end
| _ -> ok None | _ -> ok None
let expand_if_some = function let expand_if_some = function
| Prim (loc, "IF_SOME", [ right ; left ], None) -> | Prim (loc, "IF_SOME", [ right ; left ], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", [ left ; right ], None) ], None)) ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", [ left ; right ], []) ]))
| Prim (_, "IF_SOME", args, None) -> | Prim (_, "IF_SOME", args, []) ->
error (Invalid_arity ("IF_SOME", List.length args, 2)) error (Invalid_arity ("IF_SOME", List.length args, 2))
| Prim (_, "IF_SOME", [], Some _) -> | Prim (_, "IF_SOME", [], _ :: _) ->
error (Unexpected_macro_annotation "IF_SOME") error (Unexpected_macro_annotation "IF_SOME")
| _ -> ok @@ None | _ -> ok @@ None
let expand_if_right = function let expand_if_right = function
| Prim (loc, "IF_RIGHT", [ right ; left ], None) -> | Prim (loc, "IF_RIGHT", [ right ; left ], []) ->
ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", [ left ; right ], None) ], None)) ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", [ left ; right ], []) ]))
| Prim (_, "IF_RIGHT", args, None) -> | Prim (_, "IF_RIGHT", args, []) ->
error (Invalid_arity ("IF_RIGHT", List.length args, 2)) error (Invalid_arity ("IF_RIGHT", List.length args, 2))
| Prim (_, "IF_RIGHT", [], Some _) -> | Prim (_, "IF_RIGHT", [], _ :: _) ->
error (Unexpected_macro_annotation "IF_RIGHT") error (Unexpected_macro_annotation "IF_RIGHT")
| _ -> ok @@ None | _ -> ok @@ None
@ -517,9 +516,9 @@ let expand_rec expr =
| Ok expanded -> | Ok expanded ->
begin begin
match expanded with match expanded with
| Seq (loc, items, annot) -> | Seq (loc, items) ->
let items, errors = error_map expand_rec items in let items, errors = error_map expand_rec items in
(Seq (loc, items, annot), errors) (Seq (loc, items), errors)
| Prim (loc, name, args, annot) -> | Prim (loc, name, args, annot) ->
let args, errors = error_map expand_rec args in let args, errors = error_map expand_rec args in
(Prim (loc, name, args, annot), errors) (Prim (loc, name, args, annot), errors)
@ -530,18 +529,18 @@ let expand_rec expr =
let unexpand_caddadr expanded = let unexpand_caddadr expanded =
let rec rsteps acc = function let rec rsteps acc = function
| [] -> Some acc | [] -> Some acc
| Prim (_, "CAR" , [], None) :: rest -> | Prim (_, "CAR" , [], []) :: rest ->
rsteps ("A" :: acc) rest rsteps ("A" :: acc) rest
| Prim (_, "CDR" , [], None) :: rest -> | Prim (_, "CDR" , [], []) :: rest ->
rsteps ("D" :: acc) rest rsteps ("D" :: acc) rest
| _ -> None in | _ -> None in
match expanded with match expanded with
| Seq (loc, (Prim (_, "CAR" , [], None) :: _ as nodes), None) | Seq (loc, (Prim (_, "CAR" , [], []) :: _ as nodes))
| Seq (loc, (Prim (_, "CDR" , [], None) :: _ as nodes), None) -> | Seq (loc, (Prim (_, "CDR" , [], []) :: _ as nodes)) ->
begin match rsteps [] nodes with begin match rsteps [] nodes with
| Some steps -> | Some steps ->
let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in
Some (Prim (loc, name, [], None)) Some (Prim (loc, name, [], []))
| None -> None | None -> None
end end
| _ -> None | _ -> None
@ -549,82 +548,82 @@ let unexpand_caddadr expanded =
let unexpand_set_caddadr expanded = let unexpand_set_caddadr expanded =
let rec steps acc = function let rec steps acc = function
| Seq (loc, | Seq (loc,
[ Prim (_, "CDR", [], None) ; [ Prim (_, "CDR", [], []) ;
Prim (_, "SWAP", [], None) ; Prim (_, "SWAP", [], []) ;
Prim (_, "PAIR", [], None) ], None) -> Prim (_, "PAIR", [], []) ]) ->
Some (loc, "A" :: acc) Some (loc, "A" :: acc)
| Seq (loc, | Seq (loc,
[ Prim (_, "CAR", [], None) ; [ Prim (_, "CAR", [], []) ;
Prim (_, "PAIR", [], None) ], None) -> Prim (_, "PAIR", [], []) ]) ->
Some (loc, "D" :: acc) Some (loc, "D" :: acc)
| Seq (_, | Seq (_,
[ Prim (_, "DUP", [], None) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "DIP", Prim (_, "DIP",
[ Seq (_, [ Seq (_,
[ Prim (_, "CAR", [], None) ; [ Prim (_, "CAR", [], []) ;
sub ], None) ], None) ; sub ]) ], []) ;
Prim (_, "CDR", [], None) ; Prim (_, "CDR", [], []) ;
Prim (_, "SWAP", [], None) ; Prim (_, "SWAP", [], []) ;
Prim (_, "PAIR", [], None) ], None) -> Prim (_, "PAIR", [], []) ]) ->
steps ("A" :: acc) sub steps ("A" :: acc) sub
| Seq (_, | Seq (_,
[ Prim (_, "DUP", [], None) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "DIP", Prim (_, "DIP",
[ Seq (_, [ Seq (_,
[ Prim (_, "CDR", [], None) ; [ Prim (_, "CDR", [], []) ;
sub ], None) ], None) ; sub ]) ], []) ;
Prim (_, "CAR", [], None) ; Prim (_, "CAR", [], []) ;
Prim (_, "PAIR", [], None) ], None) -> Prim (_, "PAIR", [], []) ]) ->
steps ("D" :: acc) sub steps ("D" :: acc) sub
| _ -> None in | _ -> None in
match steps [] expanded with match steps [] expanded with
| Some (loc, steps) -> | Some (loc, steps) ->
let name = String.concat "" ("SET_C" :: List.rev ("R" :: steps)) in let name = String.concat "" ("SET_C" :: List.rev ("R" :: steps)) in
Some (Prim (loc, name, [], None)) Some (Prim (loc, name, [], []))
| None -> None | None -> None
let unexpand_map_caddadr expanded = let unexpand_map_caddadr expanded =
let rec steps acc = function let rec steps acc = function
| Seq (loc, | Seq (loc,
[ Prim (_, "DUP", [], None) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "CDR", [], None) ; Prim (_, "CDR", [], []) ;
Prim (_, "SWAP", [], None) ; Prim (_, "SWAP", [], []) ;
Prim (_, "CAR", [], None) ; Prim (_, "CAR", [], []) ;
code ; code ;
Prim (_, "PAIR", [], None) ], None) -> Prim (_, "PAIR", [], []) ]) ->
Some (loc, "A" :: acc, code) Some (loc, "A" :: acc, code)
| Seq (loc, | Seq (loc,
[ Prim (_, "DUP", [], None) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "CDR", [], None) ; Prim (_, "CDR", [], []) ;
code ; code ;
Prim (_, "SWAP", [], None) ; Prim (_, "SWAP", [], []) ;
Prim (_, "CAR", [], None) ; Prim (_, "CAR", [], []) ;
Prim (_, "PAIR", [], None) ], None) -> Prim (_, "PAIR", [], []) ]) ->
Some (loc, "D" :: acc, code) Some (loc, "D" :: acc, code)
| Seq (_, | Seq (_,
[ Prim (_, "DUP", [], None) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "DIP", Prim (_, "DIP",
[ Seq (_, [ Seq (_,
[ Prim (_, "CAR", [], None) ; [ Prim (_, "CAR", [], []) ;
sub ], None) ], None) ; sub ]) ], []) ;
Prim (_, "CDR", [], None) ; Prim (_, "CDR", [], []) ;
Prim (_, "SWAP", [], None) ; Prim (_, "SWAP", [], []) ;
Prim (_, "PAIR", [], None) ], None) -> Prim (_, "PAIR", [], []) ]) ->
steps ("A" :: acc) sub steps ("A" :: acc) sub
| Seq (_, | Seq (_,
[ Prim (_, "DUP", [], None) ; [ Prim (_, "DUP", [], []) ;
Prim (_, "DIP", Prim (_, "DIP",
[ Seq (_, [ Seq (_,
[ Prim (_, "CDR", [], None) ; [ Prim (_, "CDR", [], []) ;
sub ], None) ], None) ; sub ]) ], []) ;
Prim (_, "CAR", [], None) ; Prim (_, "CAR", [], []) ;
Prim (_, "PAIR", [], None) ], None) -> Prim (_, "PAIR", [], []) ]) ->
steps ("D" :: acc) sub steps ("D" :: acc) sub
| _ -> None in | _ -> None in
match steps [] expanded with match steps [] expanded with
| Some (loc, steps, code) -> | Some (loc, steps, code) ->
let name = String.concat "" ("MAP_C" :: List.rev ("R" :: steps)) in let name = String.concat "" ("MAP_C" :: List.rev ("R" :: steps)) in
Some (Prim (loc, name, [ code ], None)) Some (Prim (loc, name, [ code ], []))
| None -> None | None -> None
let roman_of_decimal decimal = let roman_of_decimal decimal =
@ -658,23 +657,22 @@ let unexpand_dxiiivp expanded =
match expanded with match expanded with
| Seq (loc, | Seq (loc,
[ Prim (_, "DIP", [ Prim (_, "DIP",
[ Seq (_, [ Prim (_, "DIP", [ _ ], None) ], None) as sub ], [ Seq (_, [ Prim (_, "DIP", [ _ ], []) ]) as sub ],
None) ], []) ]) ->
None) ->
let rec count acc = function 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 | sub -> (acc, sub) in
let depth, sub = count 1 sub in let depth, sub = count 1 sub in
let name = "D" ^ roman_of_decimal depth ^ "P" in let name = "D" ^ roman_of_decimal depth ^ "P" in
Some (Prim (loc, name, [ sub ], None)) Some (Prim (loc, name, [ sub ], []))
| _ -> None | _ -> None
let unexpand_duuuuup expanded = let unexpand_duuuuup expanded =
let rec help expanded = let rec help expanded =
match expanded with match expanded with
| Seq (loc, [ Prim (_, "DUP", [], None) ], None) -> Some (loc, 1) | Seq (loc, [ Prim (_, "DUP", [], []) ]) -> Some (loc, 1)
| Seq (_, [ Prim (_, "DIP", [expanded'], None); | Seq (_, [ Prim (_, "DIP", [expanded'], []);
Prim (_, "SWAP", [], None) ], None) -> Prim (_, "SWAP", [], []) ]) ->
begin begin
match help expanded' with match help expanded' with
| None -> None | None -> None
@ -686,158 +684,157 @@ let unexpand_duuuuup expanded =
| n -> "U" ^ (dupn (n - 1)) in | n -> "U" ^ (dupn (n - 1)) in
match help expanded with match help expanded with
| None -> None | 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 = let unexpand_paaiair expanded =
match expanded with match expanded with
| Seq (_, [ Prim (_, "PAIR", [], None) ], None) -> Some expanded | Seq (_, [ Prim (_, "PAIR", [], []) ]) -> Some expanded
| Seq (loc, (_ :: _ as nodes), None) -> | Seq (loc, (_ :: _ as nodes)) ->
let rec destruct acc = function let rec destruct acc = function
| [] -> Some acc | [] -> Some acc
| Prim (_, "DIP", [ Seq (_, [ sub ], None) ], None) :: rest -> | Prim (_, "DIP", [ Seq (_, [ sub ]) ], []) :: rest ->
destruct ("A" :: acc) (sub :: rest) destruct ("A" :: acc) (sub :: rest)
| Prim (_, "PAIR", [], None) :: rest -> | Prim (_, "PAIR", [], []) :: rest ->
destruct ("AI" :: acc) rest destruct ("AI" :: acc) rest
| _ -> None in | _ -> None in
begin match destruct [] nodes with begin match destruct [] nodes with
| None -> None | None -> None
| Some seq -> | Some seq ->
let name = String.concat "" ("P" :: List.rev ("R" :: seq)) in let name = String.concat "" ("P" :: List.rev ("R" :: seq)) in
Some (Prim (loc, name, [], None)) Some (Prim (loc, name, [], []))
end end
| _ -> None | _ -> None
let unexpand_unpaaiair expanded = let unexpand_unpaaiair expanded =
match expanded with match expanded with
| Seq (loc, (_ :: _ as nodes), None) -> | Seq (loc, (_ :: _ as nodes)) ->
let rec destruct sacc acc = function let rec destruct sacc acc = function
| [] -> Some acc | [] -> Some acc
| Prim (_, "DIP", [ Seq (_, [ sub ], None) ], None) :: rest | Prim (_, "DIP", [ Seq (_, [ sub ]) ], []) :: rest
| Prim (_, "DIP", [ Seq (_, _, _) as sub ], None) :: rest -> | Prim (_, "DIP", [ Seq (_, _) as sub ], []) :: rest ->
destruct ("A" :: sacc) acc (sub :: rest) destruct ("A" :: sacc) acc (sub :: rest)
| Seq (_, [ Prim (_, "DUP", [], None) ; | Seq (_, [ Prim (_, "DUP", [], []) ;
Prim (_, "CAR", [], None) ; Prim (_, "CAR", [], []) ;
Prim (_, "DIP", Prim (_, "DIP",
[ Seq (_, [ Seq (_, [ Prim (_, "CDR", [], []) ]) ],
[ Prim (_, "CDR", [], None) ], None) ], []) ]) :: rest ->
None) ], None) :: rest ->
destruct [] (List.rev ("AI" :: sacc) :: acc) rest destruct [] (List.rev ("AI" :: sacc) :: acc) rest
| _ -> None in | _ -> None in
begin match destruct [] [ [ "R" ] ] nodes with begin match destruct [] [ [ "R" ] ] nodes with
| None -> None | None -> None
| Some seq -> | Some seq ->
let name = String.concat "" ("UNP" :: List.flatten seq) in let name = String.concat "" ("UNP" :: List.flatten seq) in
Some (Prim (loc, name, [], None)) Some (Prim (loc, name, [], []))
end end
| _ -> None | _ -> None
let unexpand_compare expanded = let unexpand_compare expanded =
match expanded with match expanded with
| Seq (loc, [ Prim (_, "COMPARE", [], None) ; | Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "EQ", [], None) ], None) -> Prim (_, "EQ", [], []) ]) ->
Some (Prim (loc, "CMPEQ", [], None)) Some (Prim (loc, "CMPEQ", [], []))
| Seq (loc, [ Prim (_, "COMPARE", [], None) ; | Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "NEQ", [], None) ], None) -> Prim (_, "NEQ", [], []) ]) ->
Some (Prim (loc, "CMPNEQ", [], None)) Some (Prim (loc, "CMPNEQ", [], []))
| Seq (loc, [ Prim (_, "COMPARE", [], None) ; | Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "LT", [], None) ], None) -> Prim (_, "LT", [], []) ]) ->
Some (Prim (loc, "CMPLT", [], None)) Some (Prim (loc, "CMPLT", [], []))
| Seq (loc, [ Prim (_, "COMPARE", [], None) ; | Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "GT", [], None) ], None) -> Prim (_, "GT", [], []) ]) ->
Some (Prim (loc, "CMPGT", [], None)) Some (Prim (loc, "CMPGT", [], []))
| Seq (loc, [ Prim (_, "COMPARE", [], None) ; | Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "LE", [], None) ], None) -> Prim (_, "LE", [], []) ]) ->
Some (Prim (loc, "CMPLE", [], None)) Some (Prim (loc, "CMPLE", [], []))
| Seq (loc, [ Prim (_, "COMPARE", [], None) ; | Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "GE", [], None) ], None) -> Prim (_, "GE", [], []) ]) ->
Some (Prim (loc, "CMPGE", [], None)) Some (Prim (loc, "CMPGE", [], []))
| Seq (loc, [ Prim (_, "COMPARE", [], None) ; | Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "EQ", [], None) ; Prim (_, "EQ", [], []) ;
Prim (_, "IF", args, None) ], None) -> Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFCMPEQ", args, None)) Some (Prim (loc, "IFCMPEQ", args, []))
| Seq (loc, [ Prim (_, "COMPARE", [], None) ; | Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "NEQ", [], None) ; Prim (_, "NEQ", [], []) ;
Prim (_, "IF", args, None) ], None) -> Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFCMPNEQ", args, None)) Some (Prim (loc, "IFCMPNEQ", args, []))
| Seq (loc, [ Prim (_, "COMPARE", [], None) ; | Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "LT", [], None) ; Prim (_, "LT", [], []) ;
Prim (_, "IF", args, None) ], None) -> Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFCMPLT", args, None)) Some (Prim (loc, "IFCMPLT", args, []))
| Seq (loc, [ Prim (_, "COMPARE", [], None) ; | Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "GT", [], None) ; Prim (_, "GT", [], []) ;
Prim (_, "IF", args, None) ], None) -> Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFCMPGT", args, None)) Some (Prim (loc, "IFCMPGT", args, []))
| Seq (loc, [ Prim (_, "COMPARE", [], None) ; | Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "LE", [], None) ; Prim (_, "LE", [], []) ;
Prim (_, "IF", args, None) ], None) -> Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFCMPLE", args, None)) Some (Prim (loc, "IFCMPLE", args, []))
| Seq (loc, [ Prim (_, "COMPARE", [], None) ; | Seq (loc, [ Prim (_, "COMPARE", [], []) ;
Prim (_, "GE", [], None) ; Prim (_, "GE", [], []) ;
Prim (_, "IF", args, None) ], None) -> Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFCMPGE", args, None)) Some (Prim (loc, "IFCMPGE", args, []))
| Seq (loc, [ Prim (_, "EQ", [], None) ; | Seq (loc, [ Prim (_, "EQ", [], []) ;
Prim (_, "IF", args, None) ], None) -> Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFEQ", args, None)) Some (Prim (loc, "IFEQ", args, []))
| Seq (loc, [ Prim (_, "NEQ", [], None) ; | Seq (loc, [ Prim (_, "NEQ", [], []) ;
Prim (_, "IF", args, None) ], None) -> Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFNEQ", args, None)) Some (Prim (loc, "IFNEQ", args, []))
| Seq (loc, [ Prim (_, "LT", [], None) ; | Seq (loc, [ Prim (_, "LT", [], []) ;
Prim (_, "IF", args, None) ], None) -> Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFLT", args, None)) Some (Prim (loc, "IFLT", args, []))
| Seq (loc, [ Prim (_, "GT", [], None) ; | Seq (loc, [ Prim (_, "GT", [], []) ;
Prim (_, "IF", args, None) ], None) -> Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFGT", args, None)) Some (Prim (loc, "IFGT", args, []))
| Seq (loc, [ Prim (_, "LE", [], None) ; | Seq (loc, [ Prim (_, "LE", [], []) ;
Prim (_, "IF", args, None) ], None) -> Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFLE", args, None)) Some (Prim (loc, "IFLE", args, []))
| Seq (loc, [ Prim (_, "GE", [], None) ; | Seq (loc, [ Prim (_, "GE", [], []) ;
Prim (_, "IF", args, None) ], None) -> Prim (_, "IF", args, []) ]) ->
Some (Prim (loc, "IFGE", args, None)) Some (Prim (loc, "IFGE", args, []))
| _ -> None | _ -> None
let unexpand_asserts expanded = let unexpand_asserts expanded =
match expanded with match expanded with
| Seq (loc, [ Prim (_, "IF", [ Seq (_, [ ], None) ; | Seq (loc, [ Prim (_, "IF", [ Seq (_, []) ;
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ], Seq (_, [ Prim(_, "FAIL", [], []) ]) ],
None) ], None) -> []) ]) ->
Some (Prim (loc, "ASSERT", [], None)) Some (Prim (loc, "ASSERT", [], []))
| Seq (loc, [ Seq (_, [ Prim(_, "COMPARE", [], None) ; Prim(_, comparison, [], None) ], None) ; | Seq (loc, [ Seq (_, [ Prim(_, "COMPARE", [], []) ; Prim (_, comparison, [], []) ]) ;
Prim (_, "IF", [ Seq (_, [ ], None) ; Prim (_, "IF", [ Seq (_, []) ;
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ], Seq (_, [ Prim (_, "FAIL", [], []) ]) ],
None) ], None) -> []) ]) ->
Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], None)) Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], []))
| Seq (loc, [ Prim (_, comparison, [], None) ; | Seq (loc, [ Prim (_, comparison, [], []) ;
Prim (_, "IF", [ Seq (_, [ ], None) ; Prim (_, "IF", [ Seq (_, []) ;
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ], Seq (_, [ Prim (_, "FAIL", [], []) ]) ],
None) ], None) -> []) ]) ->
Some (Prim (loc, "ASSERT_" ^ comparison, [], None)) Some (Prim (loc, "ASSERT_" ^ comparison, [], []))
| Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ ], None) ; | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, []) ;
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ], Seq (_, [ Prim (_, "FAIL", [], []) ]) ],
None) ], None) -> []) ]) ->
Some (Prim (loc, "ASSERT_NONE", [], None)) Some (Prim (loc, "ASSERT_NONE", [], []))
| Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Prim(_, "FAIL", [], None) ], None) ; | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Prim (_, "FAIL", [], []) ]) ;
Seq (_, [ ], None)], Seq (_, [])],
None) ], None) -> []) ]) ->
Some (Prim (loc, "ASSERT_SOME", [], None)) Some (Prim (loc, "ASSERT_SOME", [], []))
| Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ ], None) ; | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, []) ;
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ], Seq (_, [ Prim (_, "FAIL", [], []) ]) ],
None) ], None) -> []) ]) ->
Some (Prim (loc, "ASSERT_LEFT", [], None)) Some (Prim (loc, "ASSERT_LEFT", [], []))
| Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Prim(_, "FAIL", [], None) ], None) ; | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Prim (_, "FAIL", [], []) ]) ;
Seq (_, [ ], None) ], Seq (_, []) ],
None) ], None) -> []) ]) ->
Some (Prim (loc, "ASSERT_RIGHT", [], None)) Some (Prim (loc, "ASSERT_RIGHT", [], []))
| _ -> None | _ -> None
let unexpand_if_some = function let unexpand_if_some = function
| Seq (loc, [ Prim (_, "IF_NONE", [ left ; right ], None) ], None) -> | Seq (loc, [ Prim (_, "IF_NONE", [ left ; right ], []) ]) ->
Some (Prim (loc, "IF_SOME", [ right ; left ], None)) Some (Prim (loc, "IF_SOME", [ right ; left ], []))
| _ -> None | _ -> None
let unexpand_if_right = function let unexpand_if_right = function
| Seq (loc, [ Prim (_, "IF_LEFT", [ left ; right ], None) ], None) -> | Seq (loc, [ Prim (_, "IF_LEFT", [ left ; right ], []) ]) ->
Some (Prim (loc, "IF_RIGHT", [ right ; left ], None)) Some (Prim (loc, "IF_RIGHT", [ right ; left ], []))
| _ -> None | _ -> None
let unexpand original = let unexpand original =
@ -866,8 +863,8 @@ let unexpand original =
let rec unexpand_rec expr = let rec unexpand_rec expr =
match unexpand expr with match unexpand expr with
| Seq (loc, items, annot) -> | Seq (loc, items) ->
Seq (loc, List.map unexpand_rec items, annot) Seq (loc, List.map unexpand_rec items)
| Prim (loc, name, args, annot) -> | Prim (loc, name, args, annot) ->
Prim (loc, name, List.map unexpand_rec args, annot) Prim (loc, name, List.map unexpand_rec args, annot)
| Int _ | String _ as atom -> atom | 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 errors @ expansion_errors
| Error errs -> | Error errs ->
{ source ; unexpanded ; { source ; unexpanded ;
expanded = Micheline.strip_locations (Seq ((), [], None)) ; expanded = Micheline.strip_locations (Seq ((), [])) ;
expansion_table ; unexpansion_table }, expansion_table ; unexpansion_table },
errors @ expansion_errors @ errs 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 asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in
let ast = let ast =
let start = min_point asts and stop = max_point asts in 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) expand_all source ast (lexing_errors @ parsing_errors)
let parse_expression ?check source = 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 inject_types type_map parsed =
let rec inject_expr = function let rec inject_expr = function
| Seq (loc, items, annot) -> | Seq (loc, items) ->
Seq (inject_loc `before loc, List.map inject_expr items, annot) Seq (inject_loc `before loc, List.map inject_expr items)
| Prim (loc, name, items, annot) -> | Prim (loc, name, items, annot) ->
Prim (inject_loc `after loc, name, List.map inject_expr items, annot) Prim (inject_loc `after loc, name, List.map inject_expr items, annot)
| Int (loc, value) -> | Int (loc, value) ->
@ -69,8 +69,8 @@ let unparse ?type_map parse expanded =
|> Michelson_v1_primitives.strings_of_prims |> Michelson_v1_primitives.strings_of_prims
|> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in
let rec inject_expr = function let rec inject_expr = function
| Seq (loc, items, annot) -> | Seq (loc, items) ->
Seq (inject_loc `before loc, List.map inject_expr items, annot) Seq (inject_loc `before loc, List.map inject_expr items)
| Prim (loc, name, items, annot) -> | Prim (loc, name, items, annot) ->
Prim (inject_loc `after loc, name, List.map inject_expr items, annot) Prim (inject_loc `after loc, name, List.map inject_expr items, annot)
| Int (loc, value) -> | 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 begin match parameters with
| None -> | None ->
(* Forge a [Unit] parameter that will be checked by [execute]. *) (* 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) return (ctxt, unit)
| Some parameters -> | Some parameters ->
Lwt.return (Script.force_decode parameters) >>=? fun arg -> 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 (arg :: args))
(ok []) args >>? fun args -> (ok []) args >>? fun args ->
ok (Prim (0, prim, List.rev args, annot)) ok (Prim (0, prim, List.rev args, annot))
| Seq (_, args, annot) -> | Seq (_, args) ->
List.fold_left List.fold_left
(fun acc arg -> (fun acc arg ->
acc >>? fun args -> acc >>? fun args ->
convert arg >>? fun arg -> convert arg >>? fun arg ->
ok (arg :: args)) ok (arg :: args))
(ok []) args >>? fun 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 -> convert (root expr) >>? fun expr ->
ok (strip_locations expr) ok (strip_locations expr)
@ -387,9 +387,9 @@ let strings_of_prims expr =
let prim = string_of_prim prim in let prim = string_of_prim prim in
let args = List.map convert args in let args = List.map convert args in
Prim (0, prim, args, annot) Prim (0, prim, args, annot)
| Seq (_, args, annot) -> | Seq (_, args) ->
let args = List.map convert args in let args = List.map convert args in
Seq (0, args, annot) in Seq (0, args) in
strip_locations (convert (root expr)) strip_locations (convert (root expr))
let prim_encoding = 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 -> Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt ->
let code = let code =
Micheline.strip_locations Micheline.strip_locations
(Seq (0, [ Prim (0, K_parameter, [ unparse_ty None param_type ], None) ; (Seq (0, [ Prim (0, K_parameter, [ unparse_ty [] param_type ], []) ;
Prim (0, K_storage, [ unparse_ty None storage_type ], None) ; Prim (0, K_storage, [ unparse_ty [] storage_type ], []) ;
Prim (0, K_code, [ Micheline.root code ], None) ], None)) in Prim (0, K_code, [ Micheline.root code ], []) ])) in
unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) ->
let storage = Micheline.strip_locations storage in let storage = Micheline.strip_locations storage in
Contract.spend_from_script ctxt self credit >>=? fun ctxt -> 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) | Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot), prev)
| Dip (stack, _) -> Dip (Item_t (ty, stack, annot), prev) | Dip (stack, _) -> Dip (Item_t (ty, stack, annot), prev)
let default_param_annot = Some "@parameter" let default_param_annot = [ "@parameter" ]
let default_storage_annot = Some "@storage" let default_storage_annot = [ "@storage" ]
let default_arg_annot = Some "@arg" let default_arg_annot = [ "@arg" ]
let default_annot ~default = function let default_annot ~default = function
| None -> default | [] -> default
| annot -> annot | annot -> annot
(* ---- Type size accounting ------------------------------------------------*) (* ---- Type size accounting ------------------------------------------------*)
@ -216,7 +216,7 @@ let location = function
| Prim (loc, _, _, _) | Prim (loc, _, _, _)
| Int (loc, _) | Int (loc, _)
| String (loc, _) | String (loc, _)
| Seq (loc, _, _) -> loc | Seq (loc, _) -> loc
let kind = function let kind = function
| Int _ -> Int_kind | Int _ -> Int_kind
@ -335,7 +335,7 @@ let unexpected expr exp_kinds exp_ns exp_prims =
match expr with match expr with
| Int (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind) | Int (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind)
| String (loc, _ ) -> Invalid_kind (loc, Prim_kind :: exp_kinds, String_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, _, _) -> | Prim (loc, name, _, _) ->
match namespace name, exp_ns with match namespace name, exp_ns with
| Type_namespace, Type_namespace | Type_namespace, Type_namespace
@ -505,14 +505,14 @@ let ty_of_comparable_ty
let unparse_comparable_ty let unparse_comparable_ty
: type a. a comparable_ty -> Script.node = function : type a. a comparable_ty -> Script.node = function
| Int_key -> Prim (-1, T_int, [], None) | Int_key -> Prim (-1, T_int, [], [])
| Nat_key -> Prim (-1, T_nat, [], None) | Nat_key -> Prim (-1, T_nat, [], [])
| String_key -> Prim (-1, T_string, [], None) | String_key -> Prim (-1, T_string, [], [])
| Mutez_key -> Prim (-1, T_mutez, [], None) | Mutez_key -> Prim (-1, T_mutez, [], [])
| Bool_key -> Prim (-1, T_bool, [], None) | Bool_key -> Prim (-1, T_bool, [], [])
| Key_hash_key -> Prim (-1, T_key_hash, [], None) | Key_hash_key -> Prim (-1, T_key_hash, [], [])
| Timestamp_key -> Prim (-1, T_timestamp, [], None) | Timestamp_key -> Prim (-1, T_timestamp, [], [])
| Address_key -> Prim (-1, T_address, [], None) | Address_key -> Prim (-1, T_address, [], [])
let rec unparse_ty let rec unparse_ty
: type a. annot -> a ty -> Script.node = fun annot -> : type a. annot -> a ty -> Script.node = fun annot ->
@ -530,7 +530,7 @@ let rec unparse_ty
| Signature_t -> Prim (-1, T_signature, [], annot) | Signature_t -> Prim (-1, T_signature, [], annot)
| Operation_t -> Prim (-1, T_operation, [], annot) | Operation_t -> Prim (-1, T_operation, [], annot)
| Contract_t ut -> | Contract_t ut ->
let t = unparse_ty None ut in let t = unparse_ty [] ut in
Prim (-1, T_contract, [ t ], annot) Prim (-1, T_contract, [ t ], annot)
| Pair_t ((utl, left_annot), (utr, right_annot)) -> | Pair_t ((utl, left_annot), (utr, right_annot)) ->
let tl = unparse_ty left_annot utl in let tl = unparse_ty left_annot utl in
@ -541,26 +541,26 @@ let rec unparse_ty
let tr = unparse_ty right_annot utr in let tr = unparse_ty right_annot utr in
Prim (-1, T_or, [ tl; tr ], annot) Prim (-1, T_or, [ tl; tr ], annot)
| Lambda_t (uta, utr) -> | Lambda_t (uta, utr) ->
let ta = unparse_ty None uta in let ta = unparse_ty [] uta in
let tr = unparse_ty None utr in let tr = unparse_ty [] utr in
Prim (-1, T_lambda, [ ta; tr ], annot) Prim (-1, T_lambda, [ ta; tr ], annot)
| Option_t ut -> | Option_t ut ->
let t = unparse_ty None ut in let t = unparse_ty [] ut in
Prim (-1, T_option, [ t ], annot) Prim (-1, T_option, [ t ], annot)
| List_t ut -> | List_t ut ->
let t = unparse_ty None ut in let t = unparse_ty [] ut in
Prim (-1, T_list, [ t ], annot) Prim (-1, T_list, [ t ], annot)
| Set_t ut -> | Set_t ut ->
let t = unparse_comparable_ty ut in let t = unparse_comparable_ty ut in
Prim (-1, T_set, [ t ], None) Prim (-1, T_set, [ t ], [])
| Map_t (uta, utr) -> | Map_t (uta, utr) ->
let ta = unparse_comparable_ty uta in let ta = unparse_comparable_ty uta in
let tr = unparse_ty None utr in let tr = unparse_ty [] utr in
Prim (-1, T_map, [ ta; tr ], None) Prim (-1, T_map, [ ta; tr ], [])
| Big_map_t (uta, utr) -> | Big_map_t (uta, utr) ->
let ta = unparse_comparable_ty uta in let ta = unparse_comparable_ty uta in
let tr = unparse_ty None utr in let tr = unparse_ty [] utr in
Prim (-1, T_big_map, [ ta; tr ], None) Prim (-1, T_big_map, [ ta; tr ], [])
(* ---- Equality witnesses --------------------------------------------------*) (* ---- Equality witnesses --------------------------------------------------*)
@ -653,14 +653,16 @@ let rec stack_ty_eq
| Empty_t, Empty_t -> Ok Eq | Empty_t, Empty_t -> Ok Eq
| _, _ -> error Bad_stack_length | _, _ -> error Bad_stack_length
module CompareStringList = Compare.List (Compare.String)
let merge_annot annot1 annot2 = let merge_annot annot1 annot2 =
match annot1, annot2 with match annot1, annot2 with
| None, None | [], []
| Some _, None | _ :: _, []
| None, Some _ -> ok None | [], _ :: _ -> ok []
| Some annot1, Some annot2 -> | annot1, annot2 ->
if String.equal annot1 annot2 if CompareStringList.equal annot1 annot2
then ok (Some annot1) then ok annot1
else error (Inconsistent_annotations (annot1, annot2)) else error (Inconsistent_annotations (annot1, annot2))
let merge_comparable_types let merge_comparable_types
@ -680,14 +682,14 @@ let merge_comparable_types
let error_unexpected_annot loc annot = let error_unexpected_annot loc annot =
match annot with match annot with
| None -> ok () | [] -> ok ()
| Some _ -> error (Unexpected_annotation loc) | _ :: _ -> error (Unexpected_annotation loc)
let rec strip_annotations = function let rec strip_annotations = function
| (Int (_,_) as i) -> i | (Int (_,_) as i) -> i
| (String (_,_) as s) -> s | (String (_,_) as s) -> s
| Prim (loc, prim, args, _) -> Prim (loc, prim, List.map strip_annotations args, None) | Prim (loc, prim, args, _) -> Prim (loc, prim, List.map strip_annotations args, [])
| Seq (loc, items, _) -> Seq (loc, List.map strip_annotations items, None) | Seq (loc, items) -> Seq (loc, List.map strip_annotations items)
let fail_unexpected_annot loc annot = let fail_unexpected_annot loc annot =
Lwt.return (error_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) -> | Lambda_t (ta, tr), (Seq _ as script_instr) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.lambda) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Typecheck_costs.lambda) >>=? fun ctxt ->
traced @@ 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 -> | Lambda_t _, expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
(* Options *) (* Options *)
@ -1220,8 +1222,7 @@ let rec parse_data
| Option_t _, expr -> | Option_t _, expr ->
traced (fail (unexpected expr [] Constant_namespace [ D_Some ; D_None ])) traced (fail (unexpected expr [] Constant_namespace [ D_Some ; D_None ]))
(* Lists *) (* Lists *)
| List_t t, Seq (loc, items, annot) -> | List_t t, Seq (_, items) ->
fail_unexpected_annot loc annot >>=? fun () ->
traced @@ traced @@
fold_right_s fold_right_s
(fun v (rest, ctxt) -> (fun v (rest, ctxt) ->
@ -1232,8 +1233,7 @@ let rec parse_data
| List_t _, expr -> | List_t _, expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
(* Sets *) (* Sets *)
| Set_t t, (Seq (loc, vs, annot) as expr) -> | Set_t t, (Seq (loc, vs) as expr) ->
fail_unexpected_annot loc annot >>=? fun () ->
traced @@ traced @@
fold_left_s fold_left_s
(fun (last_value, set, ctxt) v -> (fun (last_value, set, ctxt) v ->
@ -1256,13 +1256,11 @@ let rec parse_data
| Set_t _, expr -> | Set_t _, expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
(* Maps *) (* Maps *)
| Map_t (tk, tv), (Seq (loc, vs, annot) as expr) -> | Map_t (tk, tv), (Seq (loc, vs) as expr) ->
fail_unexpected_annot loc annot >>=? fun () ->
parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x) parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x)
| Map_t _, expr -> | Map_t _, expr ->
traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr)))
| Big_map_t (tk, tv), (Seq (loc, vs, annot) as expr) -> | Big_map_t (tk, tv), (Seq (loc, vs) as expr) ->
fail_unexpected_annot loc annot >>=? fun () ->
parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) >>|? fun (diff, ctxt) -> 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) ({ diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt)
| Big_map_t (_tk, _tv), expr -> | Big_map_t (_tk, _tv), expr ->
@ -1291,7 +1289,7 @@ and parse_returning
| (Typed { loc ; aft = stack_ty ; _ }, _gas) -> | (Typed { loc ; aft = stack_ty ; _ }, _gas) ->
fail (Bad_return (loc, stack_ty, ret)) fail (Bad_return (loc, stack_ty, ret))
| (Failed { descr }, gas) -> | (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) : (arg, ret) lambda), gas)
and parse_instr and parse_instr
@ -1316,7 +1314,7 @@ and parse_instr
return (judgement, ctxt) in return (judgement, ctxt) in
let keep_or_rewrite_annot value_annot instr_annot = let keep_or_rewrite_annot value_annot instr_annot =
match value_annot, instr_annot with match value_annot, instr_annot with
| annot, None -> annot | annot, [] -> annot
| _, annot -> annot in | _, annot -> annot in
let check_item check loc name n m = let check_item check loc name n m =
trace (Bad_stack (loc, name, m, stack_ty)) @@ trace (Bad_stack (loc, name, m, stack_ty)) @@
@ -1327,7 +1325,7 @@ and parse_instr
let typed ctxt loc instr aft = let typed ctxt loc instr aft =
begin match type_logger, script_instr with begin match type_logger, script_instr with
| None, _ | None, _
| Some _, (Seq (-1, _, _) | Int _ | String _) -> () | Some _, (Seq (-1, _) | Int _ | String _) -> ()
| Some log, (Prim _ | Seq _) -> | Some log, (Prim _ | Seq _) ->
log loc (unparse_stack stack_ty) (unparse_stack aft) log loc (unparse_stack stack_ty) (unparse_stack aft)
end ; end ;
@ -1398,12 +1396,12 @@ and parse_instr
Item_t (tl, rest, stack_annot) -> Item_t (tl, rest, stack_annot) ->
(Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true tr)) >>=? fun (Ex_ty tr, _) -> (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true tr)) >>=? fun (Ex_ty tr, _) ->
typed ctxt loc Left 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), | Prim (loc, I_RIGHT, [ tl ], instr_annot),
Item_t (tr, rest, stack_annot) -> Item_t (tr, rest, stack_annot) ->
(Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true tl)) >>=? fun (Ex_ty tl, _) -> (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true tl)) >>=? fun (Ex_ty tl, _) ->
typed ctxt loc Right 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), | Prim (loc, I_IF_LEFT, [ bt ; bf ], instr_annot),
(Item_t (Union_t ((tl, left_annot), (tr, right_annot)), rest, _) as bef) -> (Item_t (Union_t ((tl, left_annot), (tr, right_annot)), rest, _) as bef) ->
check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bt >>=? fun () ->
@ -1446,7 +1444,7 @@ and parse_instr
(Item_t (List_t elt, starting_rest, _)) -> (Item_t (List_t elt, starting_rest, _)) ->
check_kind [ Seq_kind ] body >>=? fun () -> check_kind [ Seq_kind ] body >>=? fun () ->
parse_instr ?type_logger tc_context ctxt 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 match judgement with
| Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) ->
trace trace
@ -1462,7 +1460,7 @@ and parse_instr
check_kind [ Seq_kind ] body >>=? fun () -> check_kind [ Seq_kind ] body >>=? fun () ->
fail_unexpected_annot loc instr_annot >>=? fun () -> fail_unexpected_annot loc instr_annot >>=? fun () ->
parse_instr ?type_logger tc_context ctxt 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 match judgement with
| Typed ({ aft ; _ } as ibody) -> | Typed ({ aft ; _ } as ibody) ->
trace trace
@ -1484,7 +1482,7 @@ and parse_instr
fail_unexpected_annot loc annot >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () ->
let elt = ty_of_comparable_ty comp_elt in let elt = ty_of_comparable_ty comp_elt in
parse_instr ?type_logger tc_context ctxt 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 match judgement with
| Typed ({ aft ; _ } as ibody) -> | Typed ({ aft ; _ } as ibody) ->
trace trace
@ -1522,7 +1520,7 @@ and parse_instr
let k = ty_of_comparable_ty ck in let k = ty_of_comparable_ty ck in
check_kind [ Seq_kind ] body >>=? fun () -> check_kind [ Seq_kind ] body >>=? fun () ->
parse_instr ?type_logger tc_context ctxt 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 match judgement with
| Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) ->
trace trace
@ -1539,7 +1537,7 @@ and parse_instr
fail_unexpected_annot loc instr_annot >>=? fun () -> fail_unexpected_annot loc instr_annot >>=? fun () ->
let key = ty_of_comparable_ty comp_elt in let key = ty_of_comparable_ty comp_elt in
parse_instr ?type_logger tc_context ctxt body 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 >>=? begin fun (judgement, ctxt) -> match judgement with
| Typed ({ aft ; _ } as ibody) -> | Typed ({ aft ; _ } as ibody) ->
trace trace
@ -1593,13 +1591,11 @@ and parse_instr
typed ctxt loc Big_map_update typed ctxt loc Big_map_update
(Item_t (Big_map_t (map_key, map_value), rest, instr_annot)) (Item_t (Big_map_t (map_key, map_value), rest, instr_annot))
(* control *) (* control *)
| Seq (loc, [], annot), | Seq (loc, []),
stack -> stack ->
fail_unexpected_annot loc annot >>=? fun () ->
typed ctxt loc Nop stack typed ctxt loc Nop stack
| Seq (loc, [ single ], annot), | Seq (loc, [ single ]),
stack -> stack ->
fail_unexpected_annot loc annot >>=? fun () ->
parse_instr ?type_logger tc_context ctxt single parse_instr ?type_logger tc_context ctxt single
stack >>=? begin fun (judgement, ctxt) -> stack >>=? begin fun (judgement, ctxt) ->
match judgement with match judgement with
@ -1613,16 +1609,15 @@ and parse_instr
{ descr with instr = Seq (descr, nop) } in { descr with instr = Seq (descr, nop) } in
return ctxt (Failed { descr }) return ctxt (Failed { descr })
end end
| Seq (loc, hd :: tl, annot), | Seq (loc, hd :: tl),
stack -> stack ->
fail_unexpected_annot loc annot >>=? fun () ->
parse_instr ?type_logger tc_context ctxt hd parse_instr ?type_logger tc_context ctxt hd
stack >>=? begin fun (judgement, ctxt) -> stack >>=? begin fun (judgement, ctxt) ->
match judgement with match judgement with
| Failed _ -> | Failed _ ->
fail (Fail_not_in_tail_position (Micheline.location hd)) fail (Fail_not_in_tail_position (Micheline.location hd))
| Typed ({ aft = middle ; _ } as ihd) -> | 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) -> middle >>=? fun (judgement, ctxt) ->
match judgement with match judgement with
| Failed { descr } -> | Failed { descr } ->
@ -1672,7 +1667,7 @@ and parse_instr
(Lwt.return (stack_ty_eq 1 ibody.aft stack)) >>=? fun Eq -> (Lwt.return (stack_ty_eq 1 ibody.aft stack)) >>=? fun Eq ->
typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, tr_annot)) typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, tr_annot))
| Failed { descr } -> | 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)) typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, tr_annot))
end end
| Prim (loc, I_LAMBDA, [ arg ; ret ; code ], instr_annot), | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], instr_annot),
@ -1767,11 +1762,11 @@ and parse_instr
Item_t (Int_t, rest, _) -> Item_t (Int_t, rest, _) ->
typed ctxt loc Abs_int typed ctxt loc Abs_int
(Item_t (Nat_t, rest, instr_annot)) (Item_t (Nat_t, rest, instr_annot))
| Prim (loc, I_ISNAT, [], Some instr_annot), | Prim (loc, I_ISNAT, [], (_ :: _ as instr_annot)),
Item_t (Int_t, rest, None) -> Item_t (Int_t, rest, []) ->
typed ctxt loc Is_nat typed ctxt loc Is_nat
(Item_t (Option_t Nat_t, rest, Some instr_annot)) (Item_t (Option_t Nat_t, rest, instr_annot))
| Prim (loc, I_ISNAT, [], None), | Prim (loc, I_ISNAT, [], []),
Item_t (Int_t, rest, annot) -> Item_t (Int_t, rest, annot) ->
typed ctxt loc Is_nat typed ctxt loc Is_nat
(Item_t (Option_t Nat_t, rest, annot)) (Item_t (Option_t Nat_t, rest, annot))
@ -1838,27 +1833,27 @@ and parse_instr
| Prim (loc, I_EDIV, [], instr_annot), | Prim (loc, I_EDIV, [], instr_annot),
Item_t (Mutez_t, Item_t (Nat_t, rest, _), _) -> Item_t (Mutez_t, Item_t (Nat_t, rest, _), _) ->
typed ctxt loc Ediv_teznat 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), | Prim (loc, I_EDIV, [], instr_annot),
Item_t (Mutez_t, Item_t (Mutez_t, rest, _), _) -> Item_t (Mutez_t, Item_t (Mutez_t, rest, _), _) ->
typed ctxt loc Ediv_tez 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), | Prim (loc, I_EDIV, [], instr_annot),
Item_t (Int_t, Item_t (Int_t, rest, _), _) -> Item_t (Int_t, Item_t (Int_t, rest, _), _) ->
typed ctxt loc Ediv_intint 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), | Prim (loc, I_EDIV, [], instr_annot),
Item_t (Int_t, Item_t (Nat_t, rest, _), _) -> Item_t (Int_t, Item_t (Nat_t, rest, _), _) ->
typed ctxt loc Ediv_intnat 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), | Prim (loc, I_EDIV, [], instr_annot),
Item_t (Nat_t, Item_t (Int_t, rest, _), _) -> Item_t (Nat_t, Item_t (Int_t, rest, _), _) ->
typed ctxt loc Ediv_natint 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), | Prim (loc, I_EDIV, [], instr_annot),
Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> Item_t (Nat_t, Item_t (Nat_t, rest, _), _) ->
typed ctxt loc Ediv_natnat 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), | Prim (loc, I_LSL, [], instr_annot),
Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> Item_t (Nat_t, Item_t (Nat_t, rest, _), _) ->
typed ctxt loc Lsl_nat typed ctxt loc Lsl_nat
@ -1984,12 +1979,12 @@ and parse_instr
(Bool_t, Item_t (Bool_t, Item_t
(Mutez_t, rest, _), _), _), _) -> (Mutez_t, rest, _), _), _), _) ->
typed ctxt loc Create_account 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), | Prim (loc, I_IMPLICIT_ACCOUNT, [], instr_annot),
Item_t (Key_hash_t, rest, _) -> Item_t (Key_hash_t, rest, _) ->
typed ctxt loc Implicit_account typed ctxt loc Implicit_account
(Item_t (Contract_t Unit_t, rest, instr_annot)) (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 Item_t
(Key_hash_t, Item_t (Key_hash_t, Item_t
(Option_t Key_hash_t, Item_t (Option_t Key_hash_t, Item_t
@ -1997,7 +1992,6 @@ and parse_instr
(Bool_t, Item_t (Bool_t, Item_t
(Mutez_t, Item_t (Mutez_t, Item_t
(ginit, rest, _), _), _), _), _), _) -> (ginit, rest, _), _), _), _), _), _) ->
fail_unexpected_annot seq_loc annot >>=? fun () ->
let cannonical_code = fst @@ Micheline.extract_locations code in let cannonical_code = fst @@ Micheline.extract_locations code in
Lwt.return (parse_toplevel cannonical_code) >>=? fun (arg_type, storage_type, code_field) -> Lwt.return (parse_toplevel cannonical_code) >>=? fun (arg_type, storage_type, code_field) ->
trace trace
@ -2010,18 +2004,18 @@ and parse_instr
>>=? fun (Ex_ty storage_type, storage_annot) -> >>=? fun (Ex_ty storage_type, storage_annot) ->
let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_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 (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 trace
(Ill_typed_contract (cannonical_code, [])) (Ill_typed_contract (cannonical_code, []))
(parse_returning (Toplevel { storage_type ; param_type = arg_type }) (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, _) ; fun (Lam ({ bef = Item_t (arg, Empty_t, _) ;
aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) -> aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) ->
Lwt.return @@ ty_eq arg arg_type_full >>=? fun Eq -> Lwt.return @@ ty_eq arg arg_type_full >>=? fun Eq ->
Lwt.return @@ ty_eq ret ret_type_full >>=? fun Eq -> Lwt.return @@ ty_eq ret ret_type_full >>=? fun Eq ->
Lwt.return @@ ty_eq storage_type ginit >>=? fun Eq -> Lwt.return @@ ty_eq storage_type ginit >>=? fun Eq ->
typed ctxt loc (Create_contract (storage_type, arg_type, lambda)) 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), | Prim (loc, I_NOW, [], instr_annot),
stack -> stack ->
typed ctxt loc Now typed ctxt loc Now
@ -2187,13 +2181,13 @@ and parse_toplevel
| Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind)) | Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind))
| String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind)) | String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind))
| Prim (loc, _, _, _) -> error (Invalid_kind (loc, [ Seq_kind ], Prim_kind)) | Prim (loc, _, _, _) -> error (Invalid_kind (loc, [ Seq_kind ], Prim_kind))
| Seq (_, fields, _) -> | Seq (_, fields) ->
let rec find_fields p s c fields = let rec find_fields p s c fields =
match fields with match fields with
| [] -> ok (p, s, c) | [] -> ok (p, s, c)
| Int (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Int_kind)) | Int (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Int_kind))
| String (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], String_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 -> | Prim (loc, K_parameter, [ arg ], _) :: rest ->
begin match p with begin match p with
| None -> find_fields (Some arg) s c rest | None -> find_fields (Some arg) s c rest
@ -2238,14 +2232,14 @@ let parse_script
>>=? fun (Ex_ty storage_type, storage_annot) -> >>=? fun (Ex_ty storage_type, storage_annot) ->
let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_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 (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 trace
(Ill_typed_data (None, storage, storage_type)) (Ill_typed_data (None, storage, storage_type))
(parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) -> (parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) ->
trace trace
(Ill_typed_contract (code, [])) (Ill_typed_contract (code, []))
(parse_returning (Toplevel { storage_type ; param_type = arg_type }) (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) return (Ex_script { code ; arg_type ; storage ; storage_type }, ctxt)
let typecheck_code let typecheck_code
@ -2264,13 +2258,13 @@ let typecheck_code
>>=? fun (Ex_ty storage_type, storage_annot) -> >>=? fun (Ex_ty storage_type, storage_annot) ->
let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_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 (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 = let result =
parse_returning parse_returning
(Toplevel { storage_type ; param_type = arg_type }) (Toplevel { storage_type ; param_type = arg_type })
ctxt ctxt
~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map) ~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 trace
(Ill_typed_contract (code, !type_map)) (Ill_typed_contract (code, !type_map))
result >>=? fun (Lam _, ctxt) -> result >>=? fun (Lam _, ctxt) ->
@ -2303,7 +2297,7 @@ let rec unparse_data
match ty, a with match ty, a with
| Unit_t, () -> | Unit_t, () ->
Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt -> 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 -> | Int_t, v ->
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
return (Int (-1, Script_int.to_zint v), ctxt) return (Int (-1, Script_int.to_zint v), ctxt)
@ -2315,10 +2309,10 @@ let rec unparse_data
return (String (-1, s), ctxt) return (String (-1, s), ctxt)
| Bool_t, true -> | Bool_t, true ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> 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 -> | Bool_t, false ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> 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 -> | Timestamp_t, t ->
Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt ->
begin begin
@ -2389,22 +2383,22 @@ let rec unparse_data
Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt ->
unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> unparse_data ctxt mode tl l >>=? fun (l, ctxt) ->
unparse_data ctxt mode tr r >>=? fun (r, 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 -> | Union_t ((tl, _), _), L l ->
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
unparse_data ctxt mode tl l >>=? fun (l, 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 -> | Union_t (_, (tr, _)), R r ->
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
unparse_data ctxt mode tr r >>=? fun (r, 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 -> | Option_t t, Some v ->
Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt ->
unparse_data ctxt mode t v >>=? fun (v, 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 -> | Option_t _, None ->
Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> 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 -> | List_t t, items ->
fold_left_s fold_left_s
(fun (l, ctxt) element -> (fun (l, ctxt) element ->
@ -2413,7 +2407,7 @@ let rec unparse_data
return (unparsed :: l, ctxt)) return (unparsed :: l, ctxt))
([], ctxt) ([], ctxt)
items >>=? fun (items, 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 -> | Set_t t, set ->
let t = ty_of_comparable_ty t in let t = ty_of_comparable_ty t in
fold_left_s fold_left_s
@ -2423,7 +2417,7 @@ let rec unparse_data
return (item :: l, ctxt)) return (item :: l, ctxt))
([], ctxt) ([], ctxt)
(set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, 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 -> | Map_t (kt, vt), map ->
let kt = ty_of_comparable_ty kt in let kt = ty_of_comparable_ty kt in
fold_left_s fold_left_s
@ -2431,12 +2425,12 @@ let rec unparse_data
Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt ->
unparse_data ctxt mode kt k >>=? fun (key, ctxt) -> unparse_data ctxt mode kt k >>=? fun (key, ctxt) ->
unparse_data ctxt mode vt v >>=? fun (value, 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) ([], ctxt)
(map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, 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 -> | Big_map_t (_kt, _kv), _map ->
return (Micheline.Seq (-1, [], None), ctxt) return (Micheline.Seq (-1, []), ctxt)
| Lambda_t _, Lam (_, original_code) -> | Lambda_t _, Lam (_, original_code) ->
unparse_code ctxt mode (root 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) -> parse_data ctxt t data >>=? fun (data, ctxt) ->
unparse_data ctxt mode t data >>=? fun (data, ctxt) -> unparse_data ctxt mode t data >>=? fun (data, ctxt) ->
return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt)
| Seq (loc, items, annot) -> | Seq (loc, items) ->
fold_left_s fold_left_s
(fun (l, ctxt) item -> (fun (l, ctxt) item ->
unparse_code ctxt mode item >>=? fun (item, ctxt) -> unparse_code ctxt mode item >>=? fun (item, ctxt) ->
return (item :: l, ctxt)) return (item :: l, ctxt))
([], ctxt) items >>=? fun (items, 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) -> | Prim (loc, prim, items, annot) ->
fold_left_s fold_left_s
(fun (l, ctxt) item -> (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 let Lam (_, original_code) = code in
unparse_code ctxt mode (root original_code) >>=? fun (code, ctxt) -> unparse_code ctxt mode (root original_code) >>=? fun (code, ctxt) ->
unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) -> unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) ->
let arg_type = unparse_ty None arg_type in let arg_type = unparse_ty [] arg_type in
let storage_type = unparse_ty None storage_type in let storage_type = unparse_ty [] storage_type in
let open Micheline in let open Micheline in
let code = let code =
Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], None) ; Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], []) ;
Prim (-1, K_storage, [ storage_type ], None) ; Prim (-1, K_storage, [ storage_type ], []) ;
Prim (-1, K_code, [ code ], None) ], None) in Prim (-1, K_code, [ code ], []) ]) in
return ({ code = lazy_expr (strip_locations code) ; return ({ code = lazy_expr (strip_locations code) ;
storage = lazy_expr (strip_locations storage) }, ctxt) 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 -> Script.node ->
(ex_ty * Script_typed_ir.annot) tzresult (ex_ty * Script_typed_ir.annot) tzresult
val unparse_ty : val unparse_ty :
string option -> 'a Script_typed_ir.ty -> Script.node string list -> 'a Script_typed_ir.ty -> Script.node
val parse_toplevel val parse_toplevel
: Script.expr -> (Script.node * Script.node * Script.node) tzresult : 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 let (nblocks, nwords) = node_size node in
(blocks + 1 + nblocks, words + 2 + nwords)) (blocks + 1 + nblocks, words + 2 + nwords))
(match annot with (match annot with
| None -> (1, 2) | [] -> (1, 2)
| Some annot -> (1, 4 + (String.length annot + 7) / 8)) | annots ->
let annots_length = List.fold_left (fun acc s -> acc + String.length s) 0 annots in
(1, 4 + (annots_length + 7) / 8))
args args
| Seq (_, args, annot) -> | Seq (_, args) ->
List.fold_left List.fold_left
(fun (blocks, words) node -> (fun (blocks, words) node ->
let (nblocks, nwords) = node_size node in let (nblocks, nwords) = node_size node in
(blocks + 1 + nblocks, words + 2 + nwords)) (blocks + 1 + nblocks, words + 2 + nwords))
(match annot with (1, 2)
| None -> (1, 2)
| Some annot -> (1, 3 + (String.length annot + 7) / 8))
args args
let expr_size expr = 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 += Self_in_lambda of Script.location
type error += Bad_stack_length type error += Bad_stack_length
type error += Bad_stack_item of int 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 += Inconsistent_type_annotations : Script.location * _ ty * _ ty -> error
type error += Unexpected_annotation of Script.location type error += Unexpected_annotation of Script.location
type error += Invalid_map_body : Script.location * _ stack_ty -> error 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 = let ex_ty_enc =
Data_encoding.conv Data_encoding.conv
(fun (Ex_ty ty) -> strip_locations (unparse_ty None ty)) (fun (Ex_ty ty) -> strip_locations (unparse_ty [] ty))
(fun expr -> (fun expr ->
match parse_ty ~allow_big_map:true ~allow_operation:true (root expr) with match parse_ty ~allow_big_map:true ~allow_operation:true (root expr) with
| Ok (Ex_ty ty, _) -> Ex_ty ty | Ok (Ex_ty ty, _) -> Ex_ty ty
@ -73,7 +73,7 @@ let () =
let Ex_stack_ty rest = fold rest in let Ex_stack_ty rest = fold rest in
Ex_stack_ty (Item_t (ty, rest, annot)) Ex_stack_ty (Item_t (ty, rest, annot))
| [] -> Ex_stack_ty Empty_t in | [] -> 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 ---------------------- *) (* -- Structure errors ---------------------- *)
(* Invalid arity *) (* Invalid arity *)
register_error_kind register_error_kind
@ -327,8 +327,8 @@ let () =
~title:"Annotations inconsistent between branches" ~title:"Annotations inconsistent between branches"
~description:"The annotations on two types could not be merged" ~description:"The annotations on two types could not be merged"
(obj2 (obj2
(req "annot1" string) (req "annot1" (list string))
(req "annot2" string)) (req "annot2" (list string)))
(function Inconsistent_annotations (annot1, annot2) -> Some (annot1, annot2) (function Inconsistent_annotations (annot1, annot2) -> Some (annot1, annot2)
| _ -> None) | _ -> None)
(fun (annot1, annot2) -> Inconsistent_annotations (annot1, annot2)) ; (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 ('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 = type ('arg, 'storage) script =
{ code : (('arg, 'storage) pair, (packed_internal_operation list, 'storage) pair) lambda ; { code : (('arg, 'storage) pair, (packed_internal_operation list, 'storage) pair) lambda ;