Alpha/test: fix symbolic link
This commit is contained in:
Grégoire Henry
parent
f6b55fa46d
commit
d417a679e6
@ -1,888 +0,0 @@
|
|||||||
(**************************************************************************)
|
|
||||||
(* *)
|
|
||||||
(* Copyright (c) 2014 - 2018. *)
|
|
||||||
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
|
||||||
(* *)
|
|
||||||
(* All rights reserved. No warranty, explicit or implicit, provided. *)
|
|
||||||
(* *)
|
|
||||||
(**************************************************************************)
|
|
||||||
|
|
||||||
open Tezos_micheline
|
|
||||||
open Micheline
|
|
||||||
|
|
||||||
type 'l node = ('l, string) Micheline.node
|
|
||||||
|
|
||||||
type error += Unexpected_macro_annotation of string
|
|
||||||
type error += Sequence_expected of string
|
|
||||||
type error += Invalid_arity of string * int * int
|
|
||||||
|
|
||||||
let rec check_letters str i j f =
|
|
||||||
i > j || f (String.get str i) && check_letters str (i + 1) j f
|
|
||||||
|
|
||||||
let expand_caddadr original =
|
|
||||||
match original with
|
|
||||||
| Prim (loc, str, args, annot) ->
|
|
||||||
let len = String.length str in
|
|
||||||
if len > 3
|
|
||||||
&& String.get str 0 = 'C'
|
|
||||||
&& String.get str (len - 1) = 'R'
|
|
||||||
&& check_letters str 1 (len - 2)
|
|
||||||
(function 'A' | 'D' -> true | _ -> false) then
|
|
||||||
begin match args with
|
|
||||||
| [] -> ok ()
|
|
||||||
| _ :: _ -> error (Invalid_arity (str, List.length args, 0))
|
|
||||||
end >>? fun () ->
|
|
||||||
let rec parse i ?annot acc =
|
|
||||||
if i = 0 then
|
|
||||||
Seq (loc, acc, None)
|
|
||||||
else
|
|
||||||
let annot = if i = (String.length str - 2) then annot else None in
|
|
||||||
match String.get str i with
|
|
||||||
| 'A' -> parse (i - 1) (Prim (loc, "CAR", [], annot) :: acc)
|
|
||||||
| 'D' -> parse (i - 1) (Prim (loc, "CDR", [], annot) :: acc)
|
|
||||||
| _ -> assert false in
|
|
||||||
ok (Some (parse (len - 2) ?annot []))
|
|
||||||
else
|
|
||||||
ok None
|
|
||||||
| _ -> ok None
|
|
||||||
|
|
||||||
let expand_set_caddadr original =
|
|
||||||
match original with
|
|
||||||
| Prim (loc, str, args, annot) ->
|
|
||||||
let len = String.length str in
|
|
||||||
if len >= 7
|
|
||||||
&& String.sub str 0 5 = "SET_C"
|
|
||||||
&& String.get str (len - 1) = 'R'
|
|
||||||
&& check_letters str 5 (len - 2)
|
|
||||||
(function 'A' | 'D' -> true | _ -> false) then
|
|
||||||
begin match args with
|
|
||||||
| [] -> ok ()
|
|
||||||
| _ :: _ -> error (Invalid_arity (str, List.length args, 0))
|
|
||||||
end >>? fun () ->
|
|
||||||
let rec parse i acc =
|
|
||||||
if i = 4 then
|
|
||||||
acc
|
|
||||||
else
|
|
||||||
match String.get str i with
|
|
||||||
| 'A' ->
|
|
||||||
let acc =
|
|
||||||
Seq (loc,
|
|
||||||
[ Prim (loc, "DUP", [], None) ;
|
|
||||||
Prim (loc, "DIP",
|
|
||||||
[ Seq (loc,
|
|
||||||
[ Prim (loc, "CAR", [], None) ;
|
|
||||||
acc ], None) ], None) ;
|
|
||||||
Prim (loc, "CDR", [], None) ;
|
|
||||||
Prim (loc, "SWAP", [], None) ;
|
|
||||||
Prim (loc, "PAIR", [], None) ], None) in
|
|
||||||
parse (i - 1) acc
|
|
||||||
| 'D' ->
|
|
||||||
let acc =
|
|
||||||
Seq (loc,
|
|
||||||
[ Prim (loc, "DUP", [], None) ;
|
|
||||||
Prim (loc, "DIP",
|
|
||||||
[ Seq (loc,
|
|
||||||
[ Prim (loc, "CDR", [], None) ;
|
|
||||||
acc ], None) ], None) ;
|
|
||||||
Prim (loc, "CAR", [], None) ;
|
|
||||||
Prim (loc, "PAIR", [], None) ], None) in
|
|
||||||
parse (i - 1) acc
|
|
||||||
| _ -> assert false in
|
|
||||||
match String.get str (len - 2) with
|
|
||||||
| 'A' ->
|
|
||||||
let init =
|
|
||||||
Seq (loc,
|
|
||||||
[ Prim (loc, "CDR", [], None) ;
|
|
||||||
Prim (loc, "SWAP", [], annot) ;
|
|
||||||
Prim (loc, "PAIR", [], None) ], None) in
|
|
||||||
ok (Some (parse (len - 3) init))
|
|
||||||
| 'D' ->
|
|
||||||
let init =
|
|
||||||
Seq (loc,
|
|
||||||
(Prim (loc, "CAR", [], None)) ::
|
|
||||||
(let pair = Prim (loc, "PAIR", [], None) in
|
|
||||||
match annot with
|
|
||||||
| None -> [ pair ]
|
|
||||||
| Some _ -> [ Prim (loc, "SWAP", [], annot) ;
|
|
||||||
Prim (loc, "SWAP", [], None) ;
|
|
||||||
pair]), None) in
|
|
||||||
ok (Some (parse (len - 3) init))
|
|
||||||
| _ -> assert false
|
|
||||||
else
|
|
||||||
ok None
|
|
||||||
| _ -> ok None
|
|
||||||
|
|
||||||
let expand_map_caddadr original =
|
|
||||||
match original with
|
|
||||||
| Prim (loc, str, args, annot) ->
|
|
||||||
let len = String.length str in
|
|
||||||
if len >= 7
|
|
||||||
&& String.sub str 0 5 = "MAP_C"
|
|
||||||
&& String.get str (len - 1) = 'R'
|
|
||||||
&& check_letters str 5 (len - 2)
|
|
||||||
(function 'A' | 'D' -> true | _ -> false) then
|
|
||||||
begin match annot with
|
|
||||||
| Some _ -> (error (Unexpected_macro_annotation str))
|
|
||||||
| None -> ok ()
|
|
||||||
end >>? fun () ->
|
|
||||||
begin match args with
|
|
||||||
| [ Seq _ as code ] -> ok code
|
|
||||||
| [ _ ] -> error (Sequence_expected str)
|
|
||||||
| [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))
|
|
||||||
end >>? fun code ->
|
|
||||||
let rec parse i acc =
|
|
||||||
if i = 4 then
|
|
||||||
acc
|
|
||||||
else
|
|
||||||
match String.get str i with
|
|
||||||
| 'A' ->
|
|
||||||
let acc =
|
|
||||||
Seq (loc,
|
|
||||||
[ Prim (loc, "DUP", [], None) ;
|
|
||||||
Prim (loc, "DIP",
|
|
||||||
[ Seq (loc,
|
|
||||||
[ Prim (loc, "CAR", [], None) ;
|
|
||||||
acc ], None) ], None) ;
|
|
||||||
Prim (loc, "CDR", [], None) ;
|
|
||||||
Prim (loc, "SWAP", [], None) ;
|
|
||||||
Prim (loc, "PAIR", [], None) ], None) in
|
|
||||||
parse (i - 1) acc
|
|
||||||
| 'D' ->
|
|
||||||
let acc =
|
|
||||||
Seq (loc,
|
|
||||||
[ Prim (loc, "DUP", [], None) ;
|
|
||||||
Prim (loc, "DIP",
|
|
||||||
[ Seq (loc,
|
|
||||||
[ Prim (loc, "CDR", [], None) ;
|
|
||||||
acc ], None) ], None) ;
|
|
||||||
Prim (loc, "CAR", [], None) ;
|
|
||||||
Prim (loc, "PAIR", [], None) ], None) in
|
|
||||||
parse (i - 1) acc
|
|
||||||
| _ -> assert false in
|
|
||||||
match String.get str (len - 2) with
|
|
||||||
| 'A' ->
|
|
||||||
let init =
|
|
||||||
Seq (loc,
|
|
||||||
[ Prim (loc, "DUP", [], None) ;
|
|
||||||
Prim (loc, "CDR", [], None) ;
|
|
||||||
Prim (loc, "DIP",
|
|
||||||
[ Seq (loc, [ Prim (loc, "CAR", [], None) ; code ], None) ], None) ;
|
|
||||||
Prim (loc, "SWAP", [], None) ;
|
|
||||||
Prim (loc, "PAIR", [], None) ], None) in
|
|
||||||
ok (Some (parse (len - 3) init))
|
|
||||||
| 'D' ->
|
|
||||||
let init =
|
|
||||||
Seq (loc,
|
|
||||||
[ Prim (loc, "DUP", [], None) ;
|
|
||||||
Prim (loc, "CDR", [], None) ;
|
|
||||||
code ;
|
|
||||||
Prim (loc, "SWAP", [], None) ;
|
|
||||||
Prim (loc, "CAR", [], None) ;
|
|
||||||
Prim (loc, "PAIR", [], None) ], None) in
|
|
||||||
ok (Some (parse (len - 3) init))
|
|
||||||
| _ -> assert false
|
|
||||||
else
|
|
||||||
ok None
|
|
||||||
| _ -> ok None
|
|
||||||
|
|
||||||
exception Not_a_roman
|
|
||||||
|
|
||||||
let decimal_of_roman roman =
|
|
||||||
(* http://rosettacode.org/wiki/Roman_numerals/Decode#OCaml *)
|
|
||||||
let arabic = ref 0 in
|
|
||||||
let lastval = ref 0 in
|
|
||||||
for i = (String.length roman) - 1 downto 0 do
|
|
||||||
let n =
|
|
||||||
match roman.[i] with
|
|
||||||
| 'M' -> 1000
|
|
||||||
| 'D' -> 500
|
|
||||||
| 'C' -> 100
|
|
||||||
| 'L' -> 50
|
|
||||||
| 'X' -> 10
|
|
||||||
| 'V' -> 5
|
|
||||||
| 'I' -> 1
|
|
||||||
| _ -> raise_notrace Not_a_roman
|
|
||||||
in
|
|
||||||
if Compare.Int.(n < !lastval)
|
|
||||||
then arabic := !arabic - n
|
|
||||||
else arabic := !arabic + n;
|
|
||||||
lastval := n
|
|
||||||
done;
|
|
||||||
!arabic
|
|
||||||
|
|
||||||
let expand_dxiiivp original =
|
|
||||||
match original with
|
|
||||||
| Prim (loc, str, args, annot) ->
|
|
||||||
let len = String.length str in
|
|
||||||
if len > 3
|
|
||||||
&& String.get str 0 = 'D'
|
|
||||||
&& String.get str (len - 1) = 'P' then
|
|
||||||
try
|
|
||||||
let depth = decimal_of_roman (String.sub str 1 (len - 2)) in
|
|
||||||
let rec make i acc =
|
|
||||||
if i = 0 then
|
|
||||||
acc
|
|
||||||
else
|
|
||||||
make (i - 1)
|
|
||||||
(Seq (loc, [ Prim (loc, "DIP", [ acc ], annot) ], None)) in
|
|
||||||
match args with
|
|
||||||
| [ Seq (_, _, _) as arg ] -> ok @@ Some (make depth arg)
|
|
||||||
| [ _ ] -> error (Sequence_expected str)
|
|
||||||
| [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))
|
|
||||||
with Not_a_roman -> ok None
|
|
||||||
else ok None
|
|
||||||
| _ -> ok None
|
|
||||||
|
|
||||||
exception Not_a_pair
|
|
||||||
|
|
||||||
let expand_paaiair original =
|
|
||||||
match original with
|
|
||||||
| Prim (loc, str, args, annot) ->
|
|
||||||
let len = String.length str in
|
|
||||||
if len > 4
|
|
||||||
&& String.get str 0 = 'P'
|
|
||||||
&& String.get str (len - 1) = 'R'
|
|
||||||
&& check_letters str 1 (len - 2)
|
|
||||||
(function 'A' | 'I' -> true | _ -> false) then
|
|
||||||
try
|
|
||||||
let rec parse i acc =
|
|
||||||
if i = 0 then
|
|
||||||
acc
|
|
||||||
else if String.get str i = 'I'
|
|
||||||
&& String.get str (i - 1) = 'A' then
|
|
||||||
parse (i - 2) (Prim (loc, "PAIR", [], if i = (len - 2) then annot else None) :: acc)
|
|
||||||
else if String.get str i = 'A' then
|
|
||||||
match acc with
|
|
||||||
| [] ->
|
|
||||||
raise_notrace Not_a_pair
|
|
||||||
| acc :: accs ->
|
|
||||||
parse (i - 1)
|
|
||||||
(Prim (loc, "DIP", [ Seq (loc, [ acc ], None) ], None)
|
|
||||||
:: accs)
|
|
||||||
else
|
|
||||||
raise_notrace Not_a_pair in
|
|
||||||
let expanded = parse (len - 2) [] in
|
|
||||||
begin match args with
|
|
||||||
| [] -> ok ()
|
|
||||||
| _ :: _ -> error (Invalid_arity (str, List.length args, 0))
|
|
||||||
end >>? fun () ->
|
|
||||||
ok (Some (Seq (loc, expanded, None)))
|
|
||||||
with Not_a_pair -> ok None
|
|
||||||
else
|
|
||||||
ok None
|
|
||||||
| _ -> ok None
|
|
||||||
|
|
||||||
let expand_unpaaiair original =
|
|
||||||
match original with
|
|
||||||
| Prim (loc, str, args, None) ->
|
|
||||||
let len = String.length str in
|
|
||||||
if len >= 6
|
|
||||||
&& String.sub str 0 3 = "UNP"
|
|
||||||
&& String.get str (len - 1) = 'R'
|
|
||||||
&& check_letters str 3 (len - 2)
|
|
||||||
(function 'A' | 'I' -> true | _ -> false) then
|
|
||||||
try
|
|
||||||
let rec parse i acc =
|
|
||||||
if i = 2 then
|
|
||||||
match acc with
|
|
||||||
| [ Seq _ as acc ] -> acc
|
|
||||||
| _ -> Seq (loc, List.rev acc, None)
|
|
||||||
else if String.get str i = 'I'
|
|
||||||
&& String.get str (i - 1) = 'A' then
|
|
||||||
parse (i - 2)
|
|
||||||
(Seq (loc, [ Prim (loc, "DUP", [], None) ;
|
|
||||||
Prim (loc, "CAR", [], None) ;
|
|
||||||
Prim (loc, "DIP",
|
|
||||||
[ Seq (loc,
|
|
||||||
[ Prim (loc, "CDR", [], None) ],
|
|
||||||
None) ], None) ], None)
|
|
||||||
:: acc)
|
|
||||||
else if String.get str i = 'A' then
|
|
||||||
match acc with
|
|
||||||
| [] ->
|
|
||||||
raise_notrace Not_a_pair
|
|
||||||
| (Seq _ as acc) :: accs ->
|
|
||||||
parse (i - 1)
|
|
||||||
(Prim (loc, "DIP", [ acc ], None) :: accs)
|
|
||||||
| acc :: accs ->
|
|
||||||
parse (i - 1)
|
|
||||||
(Prim (loc, "DIP",
|
|
||||||
[ Seq (loc, [ acc ], None) ],
|
|
||||||
None) :: accs)
|
|
||||||
else
|
|
||||||
raise_notrace Not_a_pair in
|
|
||||||
let expanded = parse (len - 2) [] in
|
|
||||||
begin match args with
|
|
||||||
| [] -> ok ()
|
|
||||||
| _ :: _ -> error (Invalid_arity (str, List.length args, 0))
|
|
||||||
end >>? fun () ->
|
|
||||||
ok (Some expanded)
|
|
||||||
with Not_a_pair -> ok None
|
|
||||||
else
|
|
||||||
ok None
|
|
||||||
| _ -> ok None
|
|
||||||
|
|
||||||
exception Not_a_dup
|
|
||||||
|
|
||||||
let expand_duuuuup original =
|
|
||||||
match original with
|
|
||||||
| Prim (loc, str, args, annot) ->
|
|
||||||
let len = String.length str in
|
|
||||||
if len > 3
|
|
||||||
&& String.get str 0 = 'D'
|
|
||||||
&& String.get str (len - 1) = 'P'
|
|
||||||
&& check_letters str 1 (len - 2) ((=) 'U') then
|
|
||||||
begin match args with
|
|
||||||
| [] -> ok ()
|
|
||||||
| _ :: _ -> error (Invalid_arity (str, List.length args, 0))
|
|
||||||
end >>? fun () ->
|
|
||||||
try
|
|
||||||
let rec parse i acc =
|
|
||||||
if i = 1 then acc
|
|
||||||
else if String.get str i = 'U' then
|
|
||||||
parse (i - 1)
|
|
||||||
(Seq (loc, [ Prim (loc, "DIP", [ acc ], None) ;
|
|
||||||
Prim (loc, "SWAP", [], None) ], None))
|
|
||||||
else
|
|
||||||
raise_notrace Not_a_dup in
|
|
||||||
ok (Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", [], annot) ], None))))
|
|
||||||
with Not_a_dup -> ok None
|
|
||||||
else
|
|
||||||
ok None
|
|
||||||
| _ -> ok None
|
|
||||||
|
|
||||||
let expand_compare original =
|
|
||||||
let cmp loc is =
|
|
||||||
let is =
|
|
||||||
List.map (fun i -> Prim (loc, i, [], None)) is in
|
|
||||||
ok (Some (Seq (loc, is, None))) in
|
|
||||||
let ifcmp loc is l r =
|
|
||||||
let is =
|
|
||||||
List.map (fun i -> Prim (loc, i, [], None)) is @
|
|
||||||
[ Prim (loc, "IF", [ l ; r ], None) ] in
|
|
||||||
ok (Some (Seq (loc, is, None))) in
|
|
||||||
match original with
|
|
||||||
| Prim (loc, "CMPEQ", [], None) ->
|
|
||||||
cmp loc [ "COMPARE" ; "EQ" ]
|
|
||||||
| Prim (loc, "CMPNEQ", [], None) ->
|
|
||||||
cmp loc [ "COMPARE" ; "NEQ" ]
|
|
||||||
| Prim (loc, "CMPLT", [], None) ->
|
|
||||||
cmp loc [ "COMPARE" ; "LT" ]
|
|
||||||
| Prim (loc, "CMPGT", [], None) ->
|
|
||||||
cmp loc [ "COMPARE" ; "GT" ]
|
|
||||||
| Prim (loc, "CMPLE", [], None) ->
|
|
||||||
cmp loc [ "COMPARE" ; "LE" ]
|
|
||||||
| Prim (loc, "CMPGE", [], None) ->
|
|
||||||
cmp loc [ "COMPARE" ; "GE" ]
|
|
||||||
| Prim (_, ("CMPEQ" | "CMPNEQ" | "CMPLT"
|
|
||||||
| "CMPGT" | "CMPLE" | "CMPGE" as str), args, None) ->
|
|
||||||
error (Invalid_arity (str, List.length args, 0))
|
|
||||||
| Prim (loc, "IFCMPEQ", [ l ; r ], None) ->
|
|
||||||
ifcmp loc [ "COMPARE" ; "EQ" ] l r
|
|
||||||
| Prim (loc, "IFCMPNEQ", [ l ; r ], None) ->
|
|
||||||
ifcmp loc [ "COMPARE" ; "NEQ" ] l r
|
|
||||||
| Prim (loc, "IFCMPLT", [ l ; r ], None) ->
|
|
||||||
ifcmp loc [ "COMPARE" ; "LT" ] l r
|
|
||||||
| Prim (loc, "IFCMPGT", [ l ; r ], None) ->
|
|
||||||
ifcmp loc [ "COMPARE" ; "GT" ] l r
|
|
||||||
| Prim (loc, "IFCMPLE", [ l ; r ], None) ->
|
|
||||||
ifcmp loc [ "COMPARE" ; "LE" ] l r
|
|
||||||
| Prim (loc, "IFCMPGE", [ l ; r ], None) ->
|
|
||||||
ifcmp loc [ "COMPARE" ; "GE" ] l r
|
|
||||||
| Prim (loc, "IFEQ", [ l ; r ], None) ->
|
|
||||||
ifcmp loc [ "EQ" ] l r
|
|
||||||
| Prim (loc, "IFNEQ", [ l ; r ], None) ->
|
|
||||||
ifcmp loc [ "NEQ" ] l r
|
|
||||||
| Prim (loc, "IFLT", [ l ; r ], None) ->
|
|
||||||
ifcmp loc [ "LT" ] l r
|
|
||||||
| Prim (loc, "IFGT", [ l ; r ], None) ->
|
|
||||||
ifcmp loc [ "GT" ] l r
|
|
||||||
| Prim (loc, "IFLE", [ l ; r ], None) ->
|
|
||||||
ifcmp loc [ "LE" ] l r
|
|
||||||
| Prim (loc, "IFGE", [ l ; r ], None) ->
|
|
||||||
ifcmp loc [ "GE" ] l r
|
|
||||||
| Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT"
|
|
||||||
| "IFCMPGT" | "IFCMPLE" | "IFCMPGE"
|
|
||||||
| "IFEQ" | "IFNEQ" | "IFLT"
|
|
||||||
| "IFGT" | "IFLE" | "IFGE" as str), args, None) ->
|
|
||||||
error (Invalid_arity (str, List.length args, 2))
|
|
||||||
| Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT"
|
|
||||||
| "IFCMPGT" | "IFCMPLE" | "IFCMPGE"
|
|
||||||
| "IFEQ" | "IFNEQ" | "IFLT"
|
|
||||||
| "IFGT" | "IFLE" | "IFGE"
|
|
||||||
| "CMPEQ" | "CMPNEQ" | "CMPLT"
|
|
||||||
| "CMPGT" | "CMPLE" | "CMPGE" as str), [], Some _) ->
|
|
||||||
error (Unexpected_macro_annotation str)
|
|
||||||
| _ -> ok None
|
|
||||||
|
|
||||||
let expand_asserts original =
|
|
||||||
let fail_false loc =
|
|
||||||
[ Seq(loc, [], None) ; Seq(loc, [ Prim (loc, "FAIL", [], None) ], None) ] in
|
|
||||||
let fail_true loc =
|
|
||||||
[ Seq(loc, [ Prim (loc, "FAIL", [], None) ], None) ; Seq(loc, [], None) ] in
|
|
||||||
match original with
|
|
||||||
| Prim (loc, "ASSERT", [], None) ->
|
|
||||||
ok @@ Some (Seq (loc, [ Prim (loc, "IF", fail_false loc, None) ], None))
|
|
||||||
| Prim (loc, "ASSERT_NONE", [], None) ->
|
|
||||||
ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_false loc, None) ], None))
|
|
||||||
| Prim (loc, "ASSERT_SOME", [], None) ->
|
|
||||||
ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_true loc, None) ], None))
|
|
||||||
| Prim (loc, "ASSERT_LEFT", [], None) ->
|
|
||||||
ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_false loc, None) ], None))
|
|
||||||
| Prim (loc, "ASSERT_RIGHT", [], None) ->
|
|
||||||
ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_true loc, None) ], None))
|
|
||||||
| Prim (_, ("ASSERT" | "ASSERT_NONE" | "ASSERT_SOME"
|
|
||||||
| "ASSERT_LEFT" | "ASSERT_RIGHT" as str), args, None) ->
|
|
||||||
error (Invalid_arity (str, List.length args, 0))
|
|
||||||
| Prim (_, ("ASSERT" | "ASSERT_NONE" | "ASSERT_SOME"
|
|
||||||
| "ASSERT_LEFT" | "ASSERT_RIGHT" as str), [], Some _) ->
|
|
||||||
error (Unexpected_macro_annotation str)
|
|
||||||
| Prim (loc, s, args, annot)
|
|
||||||
when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") ->
|
|
||||||
begin match args with
|
|
||||||
| [] -> ok ()
|
|
||||||
| _ :: _ -> error (Invalid_arity (s, List.length args, 0))
|
|
||||||
end >>? fun () ->
|
|
||||||
begin match annot with
|
|
||||||
| Some _ -> (error (Unexpected_macro_annotation s))
|
|
||||||
| None -> ok () end >>? fun () ->
|
|
||||||
begin
|
|
||||||
let remaining = String.(sub s 7 ((length s) - 7)) in
|
|
||||||
let remaining_prim = Prim(loc, remaining, [], None) in
|
|
||||||
match remaining with
|
|
||||||
| "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" ->
|
|
||||||
ok @@ Some (Seq (loc, [ remaining_prim ;
|
|
||||||
Prim (loc, "IF", fail_false loc, None) ], None))
|
|
||||||
| _ ->
|
|
||||||
begin
|
|
||||||
expand_compare remaining_prim >|? function
|
|
||||||
| None -> None
|
|
||||||
| Some seq ->
|
|
||||||
Some (Seq (loc, [ seq ;
|
|
||||||
Prim (loc, "IF", fail_false loc, None) ], None))
|
|
||||||
end
|
|
||||||
end
|
|
||||||
| _ -> ok None
|
|
||||||
|
|
||||||
|
|
||||||
let expand_if_some = function
|
|
||||||
| Prim (loc, "IF_SOME", [ right ; left ], None) ->
|
|
||||||
ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", [ left ; right ], None) ], None))
|
|
||||||
| Prim (_, "IF_SOME", args, None) ->
|
|
||||||
error (Invalid_arity ("IF_SOME", List.length args, 2))
|
|
||||||
| Prim (_, "IF_SOME", [], Some _) ->
|
|
||||||
error (Unexpected_macro_annotation "IF_SOME")
|
|
||||||
| _ -> ok @@ None
|
|
||||||
|
|
||||||
let expand_if_right = function
|
|
||||||
| Prim (loc, "IF_RIGHT", [ right ; left ], None) ->
|
|
||||||
ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", [ left ; right ], None) ], None))
|
|
||||||
| Prim (_, "IF_RIGHT", args, None) ->
|
|
||||||
error (Invalid_arity ("IF_RIGHT", List.length args, 2))
|
|
||||||
| Prim (_, "IF_RIGHT", [], Some _) ->
|
|
||||||
error (Unexpected_macro_annotation "IF_RIGHT")
|
|
||||||
| _ -> ok @@ None
|
|
||||||
|
|
||||||
let expand original =
|
|
||||||
let rec try_expansions = function
|
|
||||||
| [] -> ok @@ original
|
|
||||||
| expander :: expanders ->
|
|
||||||
expander original >>? function
|
|
||||||
| None -> try_expansions expanders
|
|
||||||
| Some rewritten -> ok rewritten in
|
|
||||||
try_expansions
|
|
||||||
[ expand_caddadr ;
|
|
||||||
expand_set_caddadr ;
|
|
||||||
expand_map_caddadr ;
|
|
||||||
expand_dxiiivp ;
|
|
||||||
expand_paaiair ;
|
|
||||||
expand_unpaaiair ;
|
|
||||||
expand_duuuuup ;
|
|
||||||
expand_compare ;
|
|
||||||
expand_asserts ;
|
|
||||||
expand_if_some ;
|
|
||||||
expand_if_right ]
|
|
||||||
|
|
||||||
let unexpand_caddadr expanded =
|
|
||||||
let rec rsteps acc = function
|
|
||||||
| [] -> Some acc
|
|
||||||
| Prim (_, "CAR" , [], None) :: rest ->
|
|
||||||
rsteps ("A" :: acc) rest
|
|
||||||
| Prim (_, "CDR" , [], None) :: rest ->
|
|
||||||
rsteps ("D" :: acc) rest
|
|
||||||
| _ -> None in
|
|
||||||
match expanded with
|
|
||||||
| Seq (loc, (Prim (_, "CAR" , [], None) :: _ as nodes), None)
|
|
||||||
| Seq (loc, (Prim (_, "CDR" , [], None) :: _ as nodes), None) ->
|
|
||||||
begin match rsteps [] nodes with
|
|
||||||
| Some steps ->
|
|
||||||
let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in
|
|
||||||
Some (Prim (loc, name, [], None))
|
|
||||||
| None -> None
|
|
||||||
end
|
|
||||||
| _ -> None
|
|
||||||
|
|
||||||
let unexpand_set_caddadr expanded =
|
|
||||||
let rec steps acc = function
|
|
||||||
| Seq (loc,
|
|
||||||
[ Prim (_, "CDR", [], None) ;
|
|
||||||
Prim (_, "SWAP", [], None) ;
|
|
||||||
Prim (_, "PAIR", [], None) ], None) ->
|
|
||||||
Some (loc, "A" :: acc)
|
|
||||||
| Seq (loc,
|
|
||||||
[ Prim (_, "CAR", [], None) ;
|
|
||||||
Prim (_, "PAIR", [], None) ], None) ->
|
|
||||||
Some (loc, "D" :: acc)
|
|
||||||
| Seq (_,
|
|
||||||
[ Prim (_, "DUP", [], None) ;
|
|
||||||
Prim (_, "DIP",
|
|
||||||
[ Seq (_,
|
|
||||||
[ Prim (_, "CAR", [], None) ;
|
|
||||||
sub ], None) ], None) ;
|
|
||||||
Prim (_, "CDR", [], None) ;
|
|
||||||
Prim (_, "SWAP", [], None) ;
|
|
||||||
Prim (_, "PAIR", [], None) ], None) ->
|
|
||||||
steps ("A" :: acc) sub
|
|
||||||
| Seq (_,
|
|
||||||
[ Prim (_, "DUP", [], None) ;
|
|
||||||
Prim (_, "DIP",
|
|
||||||
[ Seq (_,
|
|
||||||
[ Prim (_, "CDR", [], None) ;
|
|
||||||
sub ], None) ], None) ;
|
|
||||||
Prim (_, "CAR", [], None) ;
|
|
||||||
Prim (_, "PAIR", [], None) ], None) ->
|
|
||||||
steps ("D" :: acc) sub
|
|
||||||
| _ -> None in
|
|
||||||
match steps [] expanded with
|
|
||||||
| Some (loc, steps) ->
|
|
||||||
let name = String.concat "" ("SET_C" :: List.rev ("R" :: steps)) in
|
|
||||||
Some (Prim (loc, name, [], None))
|
|
||||||
| None -> None
|
|
||||||
|
|
||||||
let unexpand_map_caddadr expanded =
|
|
||||||
let rec steps acc = function
|
|
||||||
| Seq (loc,
|
|
||||||
[ Prim (_, "DUP", [], None) ;
|
|
||||||
Prim (_, "CDR", [], None) ;
|
|
||||||
Prim (_, "SWAP", [], None) ;
|
|
||||||
Prim (_, "CAR", [], None) ;
|
|
||||||
code ;
|
|
||||||
Prim (_, "PAIR", [], None) ], None) ->
|
|
||||||
Some (loc, "A" :: acc, code)
|
|
||||||
| Seq (loc,
|
|
||||||
[ Prim (_, "DUP", [], None) ;
|
|
||||||
Prim (_, "CDR", [], None) ;
|
|
||||||
code ;
|
|
||||||
Prim (_, "SWAP", [], None) ;
|
|
||||||
Prim (_, "CAR", [], None) ;
|
|
||||||
Prim (_, "PAIR", [], None) ], None) ->
|
|
||||||
Some (loc, "D" :: acc, code)
|
|
||||||
| Seq (_,
|
|
||||||
[ Prim (_, "DUP", [], None) ;
|
|
||||||
Prim (_, "DIP",
|
|
||||||
[ Seq (_,
|
|
||||||
[ Prim (_, "CAR", [], None) ;
|
|
||||||
sub ], None) ], None) ;
|
|
||||||
Prim (_, "CDR", [], None) ;
|
|
||||||
Prim (_, "SWAP", [], None) ;
|
|
||||||
Prim (_, "PAIR", [], None) ], None) ->
|
|
||||||
steps ("A" :: acc) sub
|
|
||||||
| Seq (_,
|
|
||||||
[ Prim (_, "DUP", [], None) ;
|
|
||||||
Prim (_, "DIP",
|
|
||||||
[ Seq (_,
|
|
||||||
[ Prim (_, "CDR", [], None) ;
|
|
||||||
sub ], None) ], None) ;
|
|
||||||
Prim (_, "CAR", [], None) ;
|
|
||||||
Prim (_, "PAIR", [], None) ], None) ->
|
|
||||||
steps ("D" :: acc) sub
|
|
||||||
| _ -> None in
|
|
||||||
match steps [] expanded with
|
|
||||||
| Some (loc, steps, code) ->
|
|
||||||
let name = String.concat "" ("MAP_C" :: List.rev ("R" :: steps)) in
|
|
||||||
Some (Prim (loc, name, [ code ], None))
|
|
||||||
| None -> None
|
|
||||||
|
|
||||||
let roman_of_decimal decimal =
|
|
||||||
(* http://rosettacode.org/wiki/Roman_numerals/Encode#OCaml *)
|
|
||||||
let digit x y z = function
|
|
||||||
| 1 -> [ x ]
|
|
||||||
| 2 -> [ x ; x ]
|
|
||||||
| 3 -> [ x ; x ; x ]
|
|
||||||
| 4 -> [ x ; y ]
|
|
||||||
| 5 -> [ y ]
|
|
||||||
| 6 -> [ y ; x ]
|
|
||||||
| 7 -> [ y ; x ; x ]
|
|
||||||
| 8 -> [ y ; x ; x ; x ]
|
|
||||||
| 9 -> [ x ; z ]
|
|
||||||
| _ -> assert false in
|
|
||||||
let rec to_roman x =
|
|
||||||
if x = 0 then []
|
|
||||||
else if x < 0 then
|
|
||||||
invalid_arg "Negative roman numeral"
|
|
||||||
else if x >= 1000 then
|
|
||||||
"M" :: to_roman (x - 1000)
|
|
||||||
else if x >= 100 then
|
|
||||||
digit "C" "D" "M" (x / 100) @ to_roman (x mod 100)
|
|
||||||
else if x >= 10 then
|
|
||||||
digit "X" "L" "C" (x / 10) @ to_roman (x mod 10)
|
|
||||||
else
|
|
||||||
digit "I" "V" "X" x in
|
|
||||||
String.concat "" (to_roman decimal)
|
|
||||||
|
|
||||||
let unexpand_dxiiivp expanded =
|
|
||||||
match expanded with
|
|
||||||
| Seq (loc,
|
|
||||||
[ Prim (_, "DIP",
|
|
||||||
[ Seq (_, [ Prim (_, "DIP", [ _ ], None) ], None) as sub ],
|
|
||||||
None) ],
|
|
||||||
None) ->
|
|
||||||
let rec count acc = function
|
|
||||||
| Seq (_, [ Prim (_, "DIP", [ sub ], None) ], None) -> count (acc + 1) sub
|
|
||||||
| sub -> (acc, sub) in
|
|
||||||
let depth, sub = count 1 sub in
|
|
||||||
let name = "D" ^ roman_of_decimal depth ^ "P" in
|
|
||||||
Some (Prim (loc, name, [ sub ], None))
|
|
||||||
| _ -> None
|
|
||||||
|
|
||||||
let unexpand_duuuuup expanded =
|
|
||||||
let rec help expanded =
|
|
||||||
match expanded with
|
|
||||||
| Seq (loc, [ Prim (_, "DUP", [], None) ], None) -> Some (loc, 1)
|
|
||||||
| Seq (_, [ Prim (_, "DIP", [expanded'], None);
|
|
||||||
Prim (_, "SWAP", [], None) ], None) ->
|
|
||||||
begin
|
|
||||||
match help expanded' with
|
|
||||||
| None -> None
|
|
||||||
| Some (loc, n) -> Some (loc, n + 1)
|
|
||||||
end
|
|
||||||
| _ -> None
|
|
||||||
in let rec dupn = function
|
|
||||||
| 0 -> "P"
|
|
||||||
| n -> "U" ^ (dupn (n - 1)) in
|
|
||||||
match help expanded with
|
|
||||||
| None -> None
|
|
||||||
| Some (loc, n) -> Some (Prim (loc, "D" ^ (dupn n), [], None))
|
|
||||||
|
|
||||||
let unexpand_paaiair expanded =
|
|
||||||
match expanded with
|
|
||||||
| Seq (_, [ Prim (_, "PAIR", [], None) ], None) -> Some expanded
|
|
||||||
| Seq (loc, (_ :: _ as nodes), None) ->
|
|
||||||
let rec destruct acc = function
|
|
||||||
| [] -> Some acc
|
|
||||||
| Prim (_, "DIP", [ Seq (_, [ sub ], None) ], None) :: rest ->
|
|
||||||
destruct ("A" :: acc) (sub :: rest)
|
|
||||||
| Prim (_, "PAIR", [], None) :: rest ->
|
|
||||||
destruct ("AI" :: acc) rest
|
|
||||||
| _ -> None in
|
|
||||||
begin match destruct [] nodes with
|
|
||||||
| None -> None
|
|
||||||
| Some seq ->
|
|
||||||
let name = String.concat "" ("P" :: List.rev ("R" :: seq)) in
|
|
||||||
Some (Prim (loc, name, [], None))
|
|
||||||
end
|
|
||||||
| _ -> None
|
|
||||||
|
|
||||||
let unexpand_unpaaiair expanded =
|
|
||||||
match expanded with
|
|
||||||
| Seq (loc, (_ :: _ as nodes), None) ->
|
|
||||||
let rec destruct sacc acc = function
|
|
||||||
| [] -> Some acc
|
|
||||||
| Prim (_, "DIP", [ Seq (_, [ sub ], None) ], None) :: rest
|
|
||||||
| Prim (_, "DIP", [ Seq (_, _, _) as sub ], None) :: rest ->
|
|
||||||
destruct ("A" :: sacc) acc (sub :: rest)
|
|
||||||
| Seq (_, [ Prim (_, "DUP", [], None) ;
|
|
||||||
Prim (_, "CAR", [], None) ;
|
|
||||||
Prim (_, "DIP",
|
|
||||||
[ Seq (_,
|
|
||||||
[ Prim (_, "CDR", [], None) ], None) ],
|
|
||||||
None) ], None) :: rest ->
|
|
||||||
destruct [] (List.rev ("AI" :: sacc) :: acc) rest
|
|
||||||
| _ -> None in
|
|
||||||
begin match destruct [] [ [ "R" ] ] nodes with
|
|
||||||
| None -> None
|
|
||||||
| Some seq ->
|
|
||||||
let name = String.concat "" ("UNP" :: List.flatten seq) in
|
|
||||||
Some (Prim (loc, name, [], None))
|
|
||||||
end
|
|
||||||
| _ -> None
|
|
||||||
|
|
||||||
let unexpand_compare expanded =
|
|
||||||
match expanded with
|
|
||||||
| Seq (loc, [ Prim (_, "COMPARE", [], None) ;
|
|
||||||
Prim (_, "EQ", [], None) ], None) ->
|
|
||||||
Some (Prim (loc, "CMPEQ", [], None))
|
|
||||||
| Seq (loc, [ Prim (_, "COMPARE", [], None) ;
|
|
||||||
Prim (_, "NEQ", [], None) ], None) ->
|
|
||||||
Some (Prim (loc, "CMPNEQ", [], None))
|
|
||||||
| Seq (loc, [ Prim (_, "COMPARE", [], None) ;
|
|
||||||
Prim (_, "LT", [], None) ], None) ->
|
|
||||||
Some (Prim (loc, "CMPLT", [], None))
|
|
||||||
| Seq (loc, [ Prim (_, "COMPARE", [], None) ;
|
|
||||||
Prim (_, "GT", [], None) ], None) ->
|
|
||||||
Some (Prim (loc, "CMPGT", [], None))
|
|
||||||
| Seq (loc, [ Prim (_, "COMPARE", [], None) ;
|
|
||||||
Prim (_, "LE", [], None) ], None) ->
|
|
||||||
Some (Prim (loc, "CMPLE", [], None))
|
|
||||||
| Seq (loc, [ Prim (_, "COMPARE", [], None) ;
|
|
||||||
Prim (_, "GE", [], None) ], None) ->
|
|
||||||
Some (Prim (loc, "CMPGE", [], None))
|
|
||||||
| Seq (loc, [ Prim (_, "COMPARE", [], None) ;
|
|
||||||
Prim (_, "EQ", [], None) ;
|
|
||||||
Prim (_, "IF", args, None) ], None) ->
|
|
||||||
Some (Prim (loc, "IFCMPEQ", args, None))
|
|
||||||
| Seq (loc, [ Prim (_, "COMPARE", [], None) ;
|
|
||||||
Prim (_, "NEQ", [], None) ;
|
|
||||||
Prim (_, "IF", args, None) ], None) ->
|
|
||||||
Some (Prim (loc, "IFCMPNEQ", args, None))
|
|
||||||
| Seq (loc, [ Prim (_, "COMPARE", [], None) ;
|
|
||||||
Prim (_, "LT", [], None) ;
|
|
||||||
Prim (_, "IF", args, None) ], None) ->
|
|
||||||
Some (Prim (loc, "IFCMPLT", args, None))
|
|
||||||
| Seq (loc, [ Prim (_, "COMPARE", [], None) ;
|
|
||||||
Prim (_, "GT", [], None) ;
|
|
||||||
Prim (_, "IF", args, None) ], None) ->
|
|
||||||
Some (Prim (loc, "IFCMPGT", args, None))
|
|
||||||
| Seq (loc, [ Prim (_, "COMPARE", [], None) ;
|
|
||||||
Prim (_, "LE", [], None) ;
|
|
||||||
Prim (_, "IF", args, None) ], None) ->
|
|
||||||
Some (Prim (loc, "IFCMPLE", args, None))
|
|
||||||
| Seq (loc, [ Prim (_, "COMPARE", [], None) ;
|
|
||||||
Prim (_, "GE", [], None) ;
|
|
||||||
Prim (_, "IF", args, None) ], None) ->
|
|
||||||
Some (Prim (loc, "IFCMPGE", args, None))
|
|
||||||
| Seq (loc, [ Prim (_, "EQ", [], None) ;
|
|
||||||
Prim (_, "IF", args, None) ], None) ->
|
|
||||||
Some (Prim (loc, "IFEQ", args, None))
|
|
||||||
| Seq (loc, [ Prim (_, "NEQ", [], None) ;
|
|
||||||
Prim (_, "IF", args, None) ], None) ->
|
|
||||||
Some (Prim (loc, "IFNEQ", args, None))
|
|
||||||
| Seq (loc, [ Prim (_, "LT", [], None) ;
|
|
||||||
Prim (_, "IF", args, None) ], None) ->
|
|
||||||
Some (Prim (loc, "IFLT", args, None))
|
|
||||||
| Seq (loc, [ Prim (_, "GT", [], None) ;
|
|
||||||
Prim (_, "IF", args, None) ], None) ->
|
|
||||||
Some (Prim (loc, "IFGT", args, None))
|
|
||||||
| Seq (loc, [ Prim (_, "LE", [], None) ;
|
|
||||||
Prim (_, "IF", args, None) ], None) ->
|
|
||||||
Some (Prim (loc, "IFLE", args, None))
|
|
||||||
| Seq (loc, [ Prim (_, "GE", [], None) ;
|
|
||||||
Prim (_, "IF", args, None) ], None) ->
|
|
||||||
Some (Prim (loc, "IFGE", args, None))
|
|
||||||
| _ -> None
|
|
||||||
|
|
||||||
let unexpand_asserts expanded =
|
|
||||||
match expanded with
|
|
||||||
| Seq (loc, [ Prim (_, "IF", [ Seq (_, [ ], None) ;
|
|
||||||
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ],
|
|
||||||
None) ], None) ->
|
|
||||||
Some (Prim (loc, "ASSERT", [], None))
|
|
||||||
| Seq (loc, [ Seq (_, [ Prim(_, "COMPARE", [], None) ; Prim(_, comparison, [], None) ], None) ;
|
|
||||||
Prim (_, "IF", [ Seq (_, [ ], None) ;
|
|
||||||
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ],
|
|
||||||
None) ], None) ->
|
|
||||||
Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], None))
|
|
||||||
| Seq (loc, [ Prim (_, comparison, [], None) ;
|
|
||||||
Prim (_, "IF", [ Seq (_, [ ], None) ;
|
|
||||||
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ],
|
|
||||||
None) ], None) ->
|
|
||||||
Some (Prim (loc, "ASSERT_" ^ comparison, [], None))
|
|
||||||
| Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ ], None) ;
|
|
||||||
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ],
|
|
||||||
None) ], None) ->
|
|
||||||
Some (Prim (loc, "ASSERT_NONE", [], None))
|
|
||||||
| Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Prim(_, "FAIL", [], None) ], None) ;
|
|
||||||
Seq (_, [ ], None)],
|
|
||||||
None) ], None) ->
|
|
||||||
Some (Prim (loc, "ASSERT_SOME", [], None))
|
|
||||||
| Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ ], None) ;
|
|
||||||
Seq (_, [ Prim(_, "FAIL", [], None) ], None) ],
|
|
||||||
None) ], None) ->
|
|
||||||
Some (Prim (loc, "ASSERT_LEFT", [], None))
|
|
||||||
| Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Prim(_, "FAIL", [], None) ], None) ;
|
|
||||||
Seq (_, [ ], None) ],
|
|
||||||
None) ], None) ->
|
|
||||||
Some (Prim (loc, "ASSERT_RIGHT", [], None))
|
|
||||||
| _ -> None
|
|
||||||
|
|
||||||
|
|
||||||
let unexpand_if_some = function
|
|
||||||
| Seq (loc, [ Prim (_, "IF_NONE", [ left ; right ], None) ], None) ->
|
|
||||||
Some (Prim (loc, "IF_SOME", [ right ; left ], None))
|
|
||||||
| _ -> None
|
|
||||||
|
|
||||||
let unexpand_if_right = function
|
|
||||||
| Seq (loc, [ Prim (_, "IF_LEFT", [ left ; right ], None) ], None) ->
|
|
||||||
Some (Prim (loc, "IF_RIGHT", [ right ; left ], None))
|
|
||||||
| _ -> None
|
|
||||||
|
|
||||||
let unexpand original =
|
|
||||||
let try_unexpansions unexpanders =
|
|
||||||
match
|
|
||||||
List.fold_left
|
|
||||||
(fun acc f ->
|
|
||||||
match acc with
|
|
||||||
| None -> f original
|
|
||||||
| Some rewritten -> Some rewritten)
|
|
||||||
None unexpanders with
|
|
||||||
| None -> original
|
|
||||||
| Some rewritten -> rewritten in
|
|
||||||
try_unexpansions
|
|
||||||
[ unexpand_asserts ;
|
|
||||||
unexpand_caddadr ;
|
|
||||||
unexpand_set_caddadr ;
|
|
||||||
unexpand_map_caddadr ;
|
|
||||||
unexpand_dxiiivp ;
|
|
||||||
unexpand_paaiair ;
|
|
||||||
unexpand_unpaaiair ;
|
|
||||||
unexpand_duuuuup ;
|
|
||||||
unexpand_compare ;
|
|
||||||
unexpand_if_some ;
|
|
||||||
unexpand_if_right ]
|
|
||||||
|
|
||||||
let () =
|
|
||||||
let open Data_encoding in
|
|
||||||
register_error_kind
|
|
||||||
`Permanent
|
|
||||||
~id:"michelson.macros.unexpected_annotation"
|
|
||||||
~title:"Unexpected annotation"
|
|
||||||
~description:"A macro had an annotation, but no annotation was permitted on this macro."
|
|
||||||
~pp:(fun ppf ->
|
|
||||||
Format.fprintf ppf
|
|
||||||
"Unexpected annotation on macro %s.")
|
|
||||||
(obj1
|
|
||||||
(req "macro_name" string))
|
|
||||||
(function
|
|
||||||
| Unexpected_macro_annotation str -> Some str
|
|
||||||
| _ -> None)
|
|
||||||
(fun s -> Unexpected_macro_annotation s) ;
|
|
||||||
register_error_kind
|
|
||||||
`Permanent
|
|
||||||
~id:"michelson.macros.sequence_expected"
|
|
||||||
~title:"Macro expects a sequence"
|
|
||||||
~description:"An macro expects a sequence, but a sequence was not provided"
|
|
||||||
~pp:(fun ppf name ->
|
|
||||||
Format.fprintf ppf
|
|
||||||
"Macro %s expects a sequence, but did not receive one." name)
|
|
||||||
(obj1
|
|
||||||
(req "macro_name" string))
|
|
||||||
(function
|
|
||||||
| Sequence_expected name -> Some name
|
|
||||||
| _ -> None)
|
|
||||||
(fun name -> Sequence_expected name) ;
|
|
||||||
register_error_kind
|
|
||||||
`Permanent
|
|
||||||
~id:"michelson.macros.bas_arity"
|
|
||||||
~title:"Wrong number of arguments to macro"
|
|
||||||
~description:"A wrong number of arguments was provided to a macro"
|
|
||||||
~pp:(fun ppf (name, got, exp) ->
|
|
||||||
Format.fprintf ppf
|
|
||||||
"Macro %s expects %d arguments, was given %d." name got exp)
|
|
||||||
(obj3
|
|
||||||
(req "macro_name" string)
|
|
||||||
(req "given_number_of_arguments" uint16)
|
|
||||||
(req "expected_number_of_arguments" uint16))
|
|
||||||
(function
|
|
||||||
| Invalid_arity (name, got, exp) -> Some (name, got, exp)
|
|
||||||
| _ -> None)
|
|
||||||
(fun (name, got, exp) -> Invalid_arity (name, got, exp))
|
|
||||||
@ -0,0 +1 @@
|
|||||||
|
../../../lib_client/michelson_macros.ml
|
||||||
@ -0,0 +1 @@
|
|||||||
|
../../../lib_client/michelson_macros.mli
|
||||||
@ -1,97 +0,0 @@
|
|||||||
(**************************************************************************)
|
|
||||||
(* *)
|
|
||||||
(* Copyright (c) 2014 - 2018. *)
|
|
||||||
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
|
||||||
(* *)
|
|
||||||
(* All rights reserved. No warranty, explicit or implicit, provided. *)
|
|
||||||
(* *)
|
|
||||||
(**************************************************************************)
|
|
||||||
|
|
||||||
open Proto_alpha
|
|
||||||
open Tezos_micheline
|
|
||||||
open Micheline_parser
|
|
||||||
open Micheline
|
|
||||||
|
|
||||||
type parsed =
|
|
||||||
{ source : string ;
|
|
||||||
unexpanded : string canonical ;
|
|
||||||
expanded : Michelson_v1_primitives.prim canonical ;
|
|
||||||
expansion_table : (int * (Micheline_parser.location * int list)) list ;
|
|
||||||
unexpansion_table : (int * int) list }
|
|
||||||
|
|
||||||
(* Unexpanded toplevel expression should be a sequence *)
|
|
||||||
let expand_all source ast errors =
|
|
||||||
let unexpanded, loc_table =
|
|
||||||
extract_locations ast in
|
|
||||||
let rec error_map (expanded, errors) f = function
|
|
||||||
| [] -> (List.rev expanded, List.rev errors)
|
|
||||||
| hd :: tl ->
|
|
||||||
let (new_expanded, new_errors) = f hd in
|
|
||||||
error_map
|
|
||||||
(new_expanded :: expanded, List.rev_append new_errors errors)
|
|
||||||
f tl in
|
|
||||||
let error_map = error_map ([], []) in
|
|
||||||
let rec expand expr =
|
|
||||||
match Michelson_macros.expand expr with
|
|
||||||
| Ok expanded ->
|
|
||||||
begin
|
|
||||||
match expanded with
|
|
||||||
| Seq (loc, items, annot) ->
|
|
||||||
let items, errors = error_map expand items in
|
|
||||||
(Seq (loc, items, annot), errors)
|
|
||||||
| Prim (loc, name, args, annot) ->
|
|
||||||
let args, errors = error_map expand args in
|
|
||||||
(Prim (loc, name, args, annot), errors)
|
|
||||||
| Int _ | String _ as atom -> (atom, []) end
|
|
||||||
| Error errors -> (expr, errors) in
|
|
||||||
let expanded, expansion_errors = expand (root unexpanded) in
|
|
||||||
let expanded, unexpansion_table =
|
|
||||||
extract_locations expanded in
|
|
||||||
let expansion_table =
|
|
||||||
let sorted =
|
|
||||||
List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table in
|
|
||||||
let grouped =
|
|
||||||
let rec group = function
|
|
||||||
| acc, [] -> acc
|
|
||||||
| [], (u, e) :: r ->
|
|
||||||
group ([ (e, [ u ]) ], r)
|
|
||||||
| ((pe, us) :: racc as acc), (u, e) :: r ->
|
|
||||||
if e = pe then
|
|
||||||
group (((e, u :: us) :: racc), r)
|
|
||||||
else
|
|
||||||
group (((e, [ u ]) :: acc), r) in
|
|
||||||
group ([], sorted) in
|
|
||||||
List.map2
|
|
||||||
(fun (l, ploc) (l', elocs) ->
|
|
||||||
assert (l = l') ;
|
|
||||||
(l, (ploc, elocs)))
|
|
||||||
(List.sort compare loc_table)
|
|
||||||
(List.sort compare grouped) in
|
|
||||||
match Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) with
|
|
||||||
| Ok expanded ->
|
|
||||||
{ source ; unexpanded ; expanded ;
|
|
||||||
expansion_table ; unexpansion_table },
|
|
||||||
errors @ expansion_errors
|
|
||||||
| Error errs ->
|
|
||||||
{ source ; unexpanded ;
|
|
||||||
expanded = Micheline.strip_locations (Seq ((), [], None)) ;
|
|
||||||
expansion_table ; unexpansion_table },
|
|
||||||
errs @ errors @ expansion_errors
|
|
||||||
|
|
||||||
let parse_toplevel ?check source =
|
|
||||||
let tokens, lexing_errors = Micheline_parser.tokenize source in
|
|
||||||
let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in
|
|
||||||
let ast = match asts with
|
|
||||||
| [ ast ] -> ast
|
|
||||||
| asts ->
|
|
||||||
let start = min_point asts and stop = max_point asts in
|
|
||||||
Seq ({ start ; stop }, asts, None) in
|
|
||||||
expand_all source ast (lexing_errors @ parsing_errors)
|
|
||||||
|
|
||||||
let parse_expression ?check source =
|
|
||||||
let tokens, lexing_errors = Micheline_parser.tokenize source in
|
|
||||||
let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in
|
|
||||||
expand_all source ast (lexing_errors @ parsing_errors)
|
|
||||||
|
|
||||||
let expand_all ~source ~original =
|
|
||||||
expand_all source original []
|
|
||||||
@ -0,0 +1 @@
|
|||||||
|
../../../lib_client/michelson_v1_parser.ml
|
||||||
@ -0,0 +1 @@
|
|||||||
|
../../../lib_client/michelson_v1_parser.mli
|
||||||
Loading…
Reference in New Issue
Block a user