1549 lines
49 KiB
OCaml
1549 lines
49 KiB
OCaml
(*****************************************************************************)
|
|
(* *)
|
|
(* Open Source License *)
|
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
|
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
|
|
(* *)
|
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
|
(* copy of this software and associated documentation files (the "Software"),*)
|
|
(* to deal in the Software without restriction, including without limitation *)
|
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
|
(* Software is furnished to do so, subject to the following conditions: *)
|
|
(* *)
|
|
(* The above copyright notice and this permission notice shall be included *)
|
|
(* in all copies or substantial portions of the Software. *)
|
|
(* *)
|
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
|
(* DEALINGS IN THE SOFTWARE. *)
|
|
(* *)
|
|
(*****************************************************************************)
|
|
|
|
(* open Protocol_client_context *)
|
|
open Tezos_micheline
|
|
open Micheline
|
|
module IntMap = Map.Make (Compare.Int)
|
|
|
|
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 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
|
|
&& str.[0] = 'C'
|
|
&& str.[len - 1] = 'R'
|
|
&& check_letters str 1 (len - 2) (function
|
|
| 'A' | 'D' ->
|
|
true
|
|
| _ ->
|
|
false)
|
|
then
|
|
( match args with
|
|
| [] ->
|
|
ok ()
|
|
| _ :: _ ->
|
|
error (Invalid_arity (str, List.length args, 0)) )
|
|
>>? fun () ->
|
|
let path_annot =
|
|
List.filter (function "@%" | "@%%" -> true | _ -> false) annot
|
|
in
|
|
let rec parse i acc =
|
|
if i = 0 then Seq (loc, acc)
|
|
else
|
|
let annot = if i = len - 2 then annot else path_annot in
|
|
match 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) []))
|
|
else ok None
|
|
| _ ->
|
|
ok None
|
|
|
|
let extract_field_annots annot =
|
|
List.partition
|
|
(fun a ->
|
|
match a.[0] with
|
|
| '%' ->
|
|
true
|
|
| _ ->
|
|
false
|
|
| exception Invalid_argument _ ->
|
|
false)
|
|
annot
|
|
|
|
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"
|
|
&& str.[len - 1] = 'R'
|
|
&& check_letters str 5 (len - 2) (function
|
|
| 'A' | 'D' ->
|
|
true
|
|
| _ ->
|
|
false)
|
|
then
|
|
( match args with
|
|
| [] ->
|
|
ok ()
|
|
| _ :: _ ->
|
|
error (Invalid_arity (str, List.length args, 0)) )
|
|
>>? fun () ->
|
|
( match extract_field_annots annot with
|
|
| ([], annot) ->
|
|
ok (None, annot)
|
|
| ([f], annot) ->
|
|
ok (Some f, annot)
|
|
| (_, _) ->
|
|
error (Unexpected_macro_annotation str) )
|
|
>>? fun (field_annot, annot) ->
|
|
let rec parse i acc =
|
|
if i = 4 then acc
|
|
else
|
|
let annot = if i = 5 then annot else [] in
|
|
match str.[i] with
|
|
| 'A' ->
|
|
let acc =
|
|
Seq
|
|
( loc,
|
|
[ Prim (loc, "DUP", [], []);
|
|
Prim
|
|
( loc,
|
|
"DIP",
|
|
[Seq (loc, [Prim (loc, "CAR", [], ["@%%"]); acc])],
|
|
[] );
|
|
Prim (loc, "CDR", [], ["@%%"]);
|
|
Prim (loc, "SWAP", [], []);
|
|
Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
|
|
in
|
|
parse (i - 1) acc
|
|
| 'D' ->
|
|
let acc =
|
|
Seq
|
|
( loc,
|
|
[ Prim (loc, "DUP", [], []);
|
|
Prim
|
|
( loc,
|
|
"DIP",
|
|
[Seq (loc, [Prim (loc, "CDR", [], ["@%%"]); acc])],
|
|
[] );
|
|
Prim (loc, "CAR", [], ["@%%"]);
|
|
Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
|
|
in
|
|
parse (i - 1) acc
|
|
| _ ->
|
|
assert false
|
|
in
|
|
match str.[len - 2] with
|
|
| 'A' ->
|
|
let access_check =
|
|
match field_annot with
|
|
| None ->
|
|
[]
|
|
| Some f ->
|
|
[ Prim (loc, "DUP", [], []);
|
|
Prim (loc, "CAR", [], [f]);
|
|
Prim (loc, "DROP", [], []) ]
|
|
in
|
|
let encoding =
|
|
[Prim (loc, "CDR", [], ["@%%"]); Prim (loc, "SWAP", [], [])]
|
|
in
|
|
let pair =
|
|
[ Prim
|
|
( loc,
|
|
"PAIR",
|
|
[],
|
|
[Option.unopt field_annot ~default:"%"; "%@"] ) ]
|
|
in
|
|
let init = Seq (loc, access_check @ encoding @ pair) in
|
|
ok (Some (parse (len - 3) init))
|
|
| 'D' ->
|
|
let access_check =
|
|
match field_annot with
|
|
| None ->
|
|
[]
|
|
| Some f ->
|
|
[ Prim (loc, "DUP", [], []);
|
|
Prim (loc, "CDR", [], [f]);
|
|
Prim (loc, "DROP", [], []) ]
|
|
in
|
|
let encoding = [Prim (loc, "CAR", [], ["@%%"])] in
|
|
let pair =
|
|
[ Prim
|
|
( loc,
|
|
"PAIR",
|
|
[],
|
|
["%@"; Option.unopt field_annot ~default:"%"] ) ]
|
|
in
|
|
let init = Seq (loc, access_check @ encoding @ pair) 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"
|
|
&& str.[len - 1] = 'R'
|
|
&& check_letters str 5 (len - 2) (function
|
|
| 'A' | 'D' ->
|
|
true
|
|
| _ ->
|
|
false)
|
|
then
|
|
( match args with
|
|
| [(Seq _ as code)] ->
|
|
ok code
|
|
| [_] ->
|
|
error (Sequence_expected str)
|
|
| [] | _ :: _ :: _ ->
|
|
error (Invalid_arity (str, List.length args, 1)) )
|
|
>>? fun code ->
|
|
( match extract_field_annots annot with
|
|
| ([], annot) ->
|
|
ok (None, annot)
|
|
| ([f], annot) ->
|
|
ok (Some f, annot)
|
|
| (_, _) ->
|
|
error (Unexpected_macro_annotation str) )
|
|
>>? fun (field_annot, annot) ->
|
|
let rec parse i acc =
|
|
if i = 4 then acc
|
|
else
|
|
let annot = if i = 5 then annot else [] in
|
|
match str.[i] with
|
|
| 'A' ->
|
|
let acc =
|
|
Seq
|
|
( loc,
|
|
[ Prim (loc, "DUP", [], []);
|
|
Prim
|
|
( loc,
|
|
"DIP",
|
|
[Seq (loc, [Prim (loc, "CAR", [], ["@%%"]); acc])],
|
|
[] );
|
|
Prim (loc, "CDR", [], ["@%%"]);
|
|
Prim (loc, "SWAP", [], []);
|
|
Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
|
|
in
|
|
parse (i - 1) acc
|
|
| 'D' ->
|
|
let acc =
|
|
Seq
|
|
( loc,
|
|
[ Prim (loc, "DUP", [], []);
|
|
Prim
|
|
( loc,
|
|
"DIP",
|
|
[Seq (loc, [Prim (loc, "CDR", [], ["@%%"]); acc])],
|
|
[] );
|
|
Prim (loc, "CAR", [], ["@%%"]);
|
|
Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
|
|
in
|
|
parse (i - 1) acc
|
|
| _ ->
|
|
assert false
|
|
in
|
|
let cr_annot =
|
|
match field_annot with
|
|
| None ->
|
|
[]
|
|
| Some f ->
|
|
["@" ^ String.sub f 1 (String.length f - 1)]
|
|
in
|
|
match str.[len - 2] with
|
|
| 'A' ->
|
|
let init =
|
|
Seq
|
|
( loc,
|
|
[ Prim (loc, "DUP", [], []);
|
|
Prim (loc, "CDR", [], ["@%%"]);
|
|
Prim
|
|
( loc,
|
|
"DIP",
|
|
[Seq (loc, [Prim (loc, "CAR", [], cr_annot); code])],
|
|
[] );
|
|
Prim (loc, "SWAP", [], []);
|
|
Prim
|
|
( loc,
|
|
"PAIR",
|
|
[],
|
|
[Option.unopt field_annot ~default:"%"; "%@"] ) ] )
|
|
in
|
|
ok (Some (parse (len - 3) init))
|
|
| 'D' ->
|
|
let init =
|
|
Seq
|
|
( loc,
|
|
[ Prim (loc, "DUP", [], []);
|
|
Prim (loc, "CDR", [], cr_annot);
|
|
code;
|
|
Prim (loc, "SWAP", [], []);
|
|
Prim (loc, "CAR", [], ["@%%"]);
|
|
Prim
|
|
( loc,
|
|
"PAIR",
|
|
[],
|
|
["%@"; Option.unopt field_annot ~default:"%"] ) ] )
|
|
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 dip ~loc ?(annot = []) depth instr =
|
|
assert (depth >= 0) ;
|
|
if depth = 1 then Prim (loc, "DIP", [instr], annot)
|
|
else Prim (loc, "DIP", [Int (loc, Z.of_int depth); instr], annot)
|
|
|
|
let expand_deprecated_dxiiivp original =
|
|
(* transparently expands deprecated macro [DI...IP] to instruction [DIP n] *)
|
|
match original with
|
|
| Prim (loc, str, args, annot) ->
|
|
let len = String.length str in
|
|
if len > 3 && str.[0] = 'D' && str.[len - 1] = 'P' then
|
|
try
|
|
let depth = decimal_of_roman (String.sub str 1 (len - 2)) in
|
|
match args with
|
|
| [(Seq (_, _) as arg)] ->
|
|
ok @@ Some (dip ~loc ~annot 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
|
|
|
|
type pair_item = A | I | P of int * pair_item * pair_item
|
|
|
|
let parse_pair_substr str ~len start =
|
|
let rec parse ?left i =
|
|
if i = len - 1 then raise_notrace Not_a_pair
|
|
else if str.[i] = 'P' then
|
|
let (next_i, l) = parse ~left:true (i + 1) in
|
|
let (next_i, r) = parse ~left:false next_i in
|
|
(next_i, P (i, l, r))
|
|
else if str.[i] = 'A' && left = Some true then (i + 1, A)
|
|
else if str.[i] = 'I' && left <> Some true then (i + 1, I)
|
|
else raise_notrace Not_a_pair
|
|
in
|
|
let (last, ast) = parse start in
|
|
if last <> len - 1 then raise_notrace Not_a_pair else ast
|
|
|
|
let unparse_pair_item ast =
|
|
let rec unparse ast acc =
|
|
match ast with
|
|
| P (_, l, r) ->
|
|
unparse r (unparse l ("P" :: acc))
|
|
| A ->
|
|
"A" :: acc
|
|
| I ->
|
|
"I" :: acc
|
|
in
|
|
List.rev ("R" :: unparse ast []) |> String.concat ""
|
|
|
|
let pappaiir_annots_pos ast annot =
|
|
let rec find_annots_pos p_pos ast annots acc =
|
|
match (ast, annots) with
|
|
| (_, []) ->
|
|
(annots, acc)
|
|
| (P (i, left, right), _) ->
|
|
let (annots, acc) = find_annots_pos i left annots acc in
|
|
find_annots_pos i right annots acc
|
|
| (A, a :: annots) ->
|
|
let pos =
|
|
match IntMap.find_opt p_pos acc with
|
|
| None ->
|
|
([a], [])
|
|
| Some (_, cdr) ->
|
|
([a], cdr)
|
|
in
|
|
(annots, IntMap.add p_pos pos acc)
|
|
| (I, a :: annots) ->
|
|
let pos =
|
|
match IntMap.find_opt p_pos acc with
|
|
| None ->
|
|
([], [a])
|
|
| Some (car, _) ->
|
|
(car, [a])
|
|
in
|
|
(annots, IntMap.add p_pos pos acc)
|
|
in
|
|
snd (find_annots_pos 0 ast annot IntMap.empty)
|
|
|
|
let expand_pappaiir original =
|
|
match original with
|
|
| Prim (loc, str, args, annot) ->
|
|
let len = String.length str in
|
|
if
|
|
len > 4
|
|
&& str.[0] = 'P'
|
|
&& str.[len - 1] = 'R'
|
|
&& check_letters str 1 (len - 2) (function
|
|
| 'P' | 'A' | 'I' ->
|
|
true
|
|
| _ ->
|
|
false)
|
|
then
|
|
try
|
|
let (field_annots, annot) = extract_field_annots annot in
|
|
let ast = parse_pair_substr str ~len 0 in
|
|
let field_annots_pos = pappaiir_annots_pos ast field_annots in
|
|
let rec parse p (depth, acc) =
|
|
match p with
|
|
| P (i, left, right) ->
|
|
let annot =
|
|
match (i, IntMap.find_opt i field_annots_pos) with
|
|
| (0, None) ->
|
|
annot
|
|
| (_, None) ->
|
|
[]
|
|
| (0, Some ([], cdr_annot)) ->
|
|
("%" :: cdr_annot) @ annot
|
|
| (_, Some ([], cdr_annot)) ->
|
|
"%" :: cdr_annot
|
|
| (0, Some (car_annot, cdr_annot)) ->
|
|
car_annot @ cdr_annot @ annot
|
|
| (_, Some (car_annot, cdr_annot)) ->
|
|
car_annot @ cdr_annot
|
|
in
|
|
let acc =
|
|
if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc
|
|
else
|
|
dip ~loc depth (Seq (loc, [Prim (loc, "PAIR", [], annot)]))
|
|
:: acc
|
|
in
|
|
(depth, acc) |> parse left |> parse right
|
|
| A | I ->
|
|
(depth + 1, acc)
|
|
in
|
|
let (_, expanded) = parse ast (0, []) in
|
|
( match args with
|
|
| [] ->
|
|
ok ()
|
|
| _ :: _ ->
|
|
error (Invalid_arity (str, List.length args, 0)) )
|
|
>>? fun () -> ok (Some (Seq (loc, expanded)))
|
|
with Not_a_pair -> ok None
|
|
else ok None
|
|
| _ ->
|
|
ok None
|
|
|
|
let expand_unpappaiir original =
|
|
match original with
|
|
| Prim (loc, str, args, annot) ->
|
|
let len = String.length str in
|
|
if
|
|
len >= 6
|
|
&& String.sub str 0 3 = "UNP"
|
|
&& str.[len - 1] = 'R'
|
|
&& check_letters str 3 (len - 2) (function
|
|
| 'P' | 'A' | 'I' ->
|
|
true
|
|
| _ ->
|
|
false)
|
|
then
|
|
try
|
|
let unpair car_annot cdr_annot =
|
|
Seq
|
|
( loc,
|
|
[ Prim (loc, "DUP", [], []);
|
|
Prim (loc, "CAR", [], car_annot);
|
|
dip ~loc 1 (Seq (loc, [Prim (loc, "CDR", [], cdr_annot)])) ]
|
|
)
|
|
in
|
|
let ast = parse_pair_substr str ~len 2 in
|
|
let annots_pos = pappaiir_annots_pos ast annot in
|
|
let rec parse p (depth, acc) =
|
|
match p with
|
|
| P (i, left, right) ->
|
|
let (car_annot, cdr_annot) =
|
|
match IntMap.find_opt i annots_pos with
|
|
| None ->
|
|
([], [])
|
|
| Some (car_annot, cdr_annot) ->
|
|
(car_annot, cdr_annot)
|
|
in
|
|
let acc =
|
|
if depth = 0 then unpair car_annot cdr_annot :: acc
|
|
else
|
|
dip ~loc depth (Seq (loc, [unpair car_annot cdr_annot]))
|
|
:: acc
|
|
in
|
|
(depth, acc) |> parse left |> parse right
|
|
| A | I ->
|
|
(depth + 1, acc)
|
|
in
|
|
let (_, rev_expanded) = parse ast (0, []) in
|
|
let expanded = Seq (loc, List.rev rev_expanded) in
|
|
( match args with
|
|
| [] ->
|
|
ok ()
|
|
| _ :: _ ->
|
|
error (Invalid_arity (str, List.length args, 0)) )
|
|
>>? fun () -> ok (Some expanded)
|
|
with Not_a_pair -> ok None
|
|
else ok None
|
|
| _ ->
|
|
ok None
|
|
|
|
exception Not_a_dup
|
|
|
|
let dupn loc nloc n annot =
|
|
assert (n > 1) ;
|
|
if n = 2 then
|
|
(* keep the old expansion, shorter for [DUP 2] *)
|
|
Seq
|
|
( loc,
|
|
[ Prim (loc, "DIP", [Seq (loc, [Prim (nloc, "DUP", [], annot)])], []);
|
|
Prim (loc, "SWAP", [], []) ] )
|
|
else
|
|
Seq
|
|
( loc,
|
|
[ Prim
|
|
( loc,
|
|
"DIP",
|
|
[ Int (loc, Z.of_int (n - 1));
|
|
Seq (loc, [Prim (loc, "DUP", [], annot)]) ],
|
|
[] );
|
|
Prim (loc, "DIG", [Int (nloc, Z.of_int n)], []) ] )
|
|
|
|
let expand_dupn original =
|
|
match original with
|
|
| Prim (loc, "DUP", [Int (nloc, n)], annot) ->
|
|
ok (Some (dupn loc nloc (Z.to_int n) annot))
|
|
| _ ->
|
|
ok None
|
|
|
|
let expand_deprecated_duuuuup original =
|
|
(* transparently expands deprecated macro [DU...UP] to [{ DIP n { DUP } ; DIG n }] *)
|
|
match original with
|
|
| Prim (loc, str, args, annot) ->
|
|
let len = String.length str in
|
|
if
|
|
len > 3
|
|
&& str.[0] = 'D'
|
|
&& str.[len - 1] = 'P'
|
|
&& check_letters str 1 (len - 2) (( = ) 'U')
|
|
then
|
|
( match args with
|
|
| [] ->
|
|
ok ()
|
|
| _ :: _ ->
|
|
error (Invalid_arity (str, List.length args, 0)) )
|
|
>>? fun () ->
|
|
try
|
|
let rec parse i =
|
|
if i = 1 then dupn loc loc (len - 2) annot
|
|
else if str.[i] = 'U' then parse (i - 1)
|
|
else raise_notrace Not_a_dup
|
|
in
|
|
ok (Some (parse (len - 2)))
|
|
with Not_a_dup -> ok None
|
|
else ok None
|
|
| _ ->
|
|
ok None
|
|
|
|
let expand_compare original =
|
|
let cmp loc is annot =
|
|
let is =
|
|
match List.rev_map (fun i -> Prim (loc, i, [], [])) is with
|
|
| Prim (loc, i, args, _) :: r ->
|
|
List.rev (Prim (loc, i, args, annot) :: r)
|
|
| is ->
|
|
List.rev is
|
|
in
|
|
ok (Some (Seq (loc, is)))
|
|
in
|
|
let ifcmp loc is l r annot =
|
|
let is =
|
|
List.map (fun i -> Prim (loc, i, [], [])) is
|
|
@ [Prim (loc, "IF", [l; r], annot)]
|
|
in
|
|
ok (Some (Seq (loc, is)))
|
|
in
|
|
match original with
|
|
| Prim (loc, "CMPEQ", [], annot) ->
|
|
cmp loc ["COMPARE"; "EQ"] annot
|
|
| Prim (loc, "CMPNEQ", [], annot) ->
|
|
cmp loc ["COMPARE"; "NEQ"] annot
|
|
| Prim (loc, "CMPLT", [], annot) ->
|
|
cmp loc ["COMPARE"; "LT"] annot
|
|
| Prim (loc, "CMPGT", [], annot) ->
|
|
cmp loc ["COMPARE"; "GT"] annot
|
|
| Prim (loc, "CMPLE", [], annot) ->
|
|
cmp loc ["COMPARE"; "LE"] annot
|
|
| Prim (loc, "CMPGE", [], annot) ->
|
|
cmp loc ["COMPARE"; "GE"] annot
|
|
| Prim
|
|
( _,
|
|
(("CMPEQ" | "CMPNEQ" | "CMPLT" | "CMPGT" | "CMPLE" | "CMPGE") as str),
|
|
args,
|
|
[] ) ->
|
|
error (Invalid_arity (str, List.length args, 0))
|
|
| Prim (loc, "IFCMPEQ", [l; r], annot) ->
|
|
ifcmp loc ["COMPARE"; "EQ"] l r annot
|
|
| Prim (loc, "IFCMPNEQ", [l; r], annot) ->
|
|
ifcmp loc ["COMPARE"; "NEQ"] l r annot
|
|
| Prim (loc, "IFCMPLT", [l; r], annot) ->
|
|
ifcmp loc ["COMPARE"; "LT"] l r annot
|
|
| Prim (loc, "IFCMPGT", [l; r], annot) ->
|
|
ifcmp loc ["COMPARE"; "GT"] l r annot
|
|
| Prim (loc, "IFCMPLE", [l; r], annot) ->
|
|
ifcmp loc ["COMPARE"; "LE"] l r annot
|
|
| Prim (loc, "IFCMPGE", [l; r], annot) ->
|
|
ifcmp loc ["COMPARE"; "GE"] l r annot
|
|
| Prim (loc, "IFEQ", [l; r], annot) ->
|
|
ifcmp loc ["EQ"] l r annot
|
|
| Prim (loc, "IFNEQ", [l; r], annot) ->
|
|
ifcmp loc ["NEQ"] l r annot
|
|
| Prim (loc, "IFLT", [l; r], annot) ->
|
|
ifcmp loc ["LT"] l r annot
|
|
| Prim (loc, "IFGT", [l; r], annot) ->
|
|
ifcmp loc ["GT"] l r annot
|
|
| Prim (loc, "IFLE", [l; r], annot) ->
|
|
ifcmp loc ["LE"] l r annot
|
|
| Prim (loc, "IFGE", [l; r], annot) ->
|
|
ifcmp loc ["GE"] l r annot
|
|
| Prim
|
|
( _,
|
|
( ( "IFCMPEQ"
|
|
| "IFCMPNEQ"
|
|
| "IFCMPLT"
|
|
| "IFCMPGT"
|
|
| "IFCMPLE"
|
|
| "IFCMPGE"
|
|
| "IFEQ"
|
|
| "IFNEQ"
|
|
| "IFLT"
|
|
| "IFGT"
|
|
| "IFLE"
|
|
| "IFGE" ) as str ),
|
|
args,
|
|
[] ) ->
|
|
error (Invalid_arity (str, List.length args, 2))
|
|
| Prim
|
|
( _,
|
|
( ( "IFCMPEQ"
|
|
| "IFCMPNEQ"
|
|
| "IFCMPLT"
|
|
| "IFCMPGT"
|
|
| "IFCMPLE"
|
|
| "IFCMPGE"
|
|
| "IFEQ"
|
|
| "IFNEQ"
|
|
| "IFLT"
|
|
| "IFGT"
|
|
| "IFLE"
|
|
| "IFGE" ) as str ),
|
|
[],
|
|
_ :: _ ) ->
|
|
error (Unexpected_macro_annotation str)
|
|
| _ ->
|
|
ok None
|
|
|
|
let expand_asserts original =
|
|
let may_rename loc = function
|
|
| [] ->
|
|
Seq (loc, [])
|
|
| annot ->
|
|
Seq (loc, [Prim (loc, "RENAME", [], annot)])
|
|
in
|
|
let fail_false ?(annot = []) loc =
|
|
[may_rename loc annot; Seq (loc, [Prim (loc, "FAIL", [], [])])]
|
|
in
|
|
let fail_true ?(annot = []) loc =
|
|
[Seq (loc, [Prim (loc, "FAIL", [], [])]); may_rename loc annot]
|
|
in
|
|
match original with
|
|
| Prim (loc, "ASSERT", [], []) ->
|
|
ok @@ Some (Seq (loc, [Prim (loc, "IF", fail_false loc, [])]))
|
|
| Prim (loc, "ASSERT_NONE", [], []) ->
|
|
ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", fail_false loc, [])]))
|
|
| Prim (loc, "ASSERT_SOME", [], annot) ->
|
|
ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", fail_true ~annot loc, [])]))
|
|
| Prim (loc, "ASSERT_LEFT", [], annot) ->
|
|
ok
|
|
@@ Some (Seq (loc, [Prim (loc, "IF_LEFT", fail_false ~annot loc, [])]))
|
|
| Prim (loc, "ASSERT_RIGHT", [], annot) ->
|
|
ok @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", fail_true ~annot loc, [])]))
|
|
| Prim
|
|
( _,
|
|
( ( "ASSERT"
|
|
| "ASSERT_NONE"
|
|
| "ASSERT_SOME"
|
|
| "ASSERT_LEFT"
|
|
| "ASSERT_RIGHT" ) as str ),
|
|
args,
|
|
[] ) ->
|
|
error (Invalid_arity (str, List.length args, 0))
|
|
| Prim (_, (("ASSERT" | "ASSERT_NONE") as str), [], _ :: _) ->
|
|
error (Unexpected_macro_annotation str)
|
|
| Prim (loc, s, args, annot)
|
|
when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") -> (
|
|
( match args with
|
|
| [] ->
|
|
ok ()
|
|
| _ :: _ ->
|
|
error (Invalid_arity (s, List.length args, 0)) )
|
|
>>? fun () ->
|
|
( match annot with
|
|
| _ :: _ ->
|
|
error (Unexpected_macro_annotation s)
|
|
| [] ->
|
|
ok () )
|
|
>>? fun () ->
|
|
let remaining = String.(sub s 7 (length s - 7)) in
|
|
let remaining_prim = Prim (loc, remaining, [], []) in
|
|
match remaining with
|
|
| "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" ->
|
|
ok
|
|
@@ Some
|
|
(Seq
|
|
(loc, [remaining_prim; Prim (loc, "IF", fail_false loc, [])]))
|
|
| _ -> (
|
|
expand_compare remaining_prim
|
|
>|? function
|
|
| None ->
|
|
None
|
|
| Some seq ->
|
|
Some (Seq (loc, [seq; Prim (loc, "IF", fail_false loc, [])])) ) )
|
|
| _ ->
|
|
ok None
|
|
|
|
let expand_if_some = function
|
|
| Prim (loc, "IF_SOME", [right; left], annot) ->
|
|
ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", [left; right], annot)]))
|
|
| Prim (_, "IF_SOME", args, _annot) ->
|
|
error (Invalid_arity ("IF_SOME", List.length args, 2))
|
|
| _ ->
|
|
ok @@ None
|
|
|
|
let expand_if_right = function
|
|
| Prim (loc, "IF_RIGHT", [right; left], annot) ->
|
|
ok @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", [left; right], annot)]))
|
|
| Prim (_, "IF_RIGHT", args, _annot) ->
|
|
error (Invalid_arity ("IF_RIGHT", List.length args, 2))
|
|
| _ ->
|
|
ok @@ None
|
|
|
|
let expand_fail = function
|
|
| Prim (loc, "FAIL", [], []) ->
|
|
ok
|
|
@@ Some
|
|
(Seq
|
|
( loc,
|
|
[Prim (loc, "UNIT", [], []); Prim (loc, "FAILWITH", [], [])] ))
|
|
| _ ->
|
|
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_deprecated_dxiiivp;
|
|
(* expand_paaiair ; *)
|
|
expand_pappaiir;
|
|
(* expand_unpaaiair ; *)
|
|
expand_unpappaiir;
|
|
expand_deprecated_duuuuup;
|
|
expand_dupn;
|
|
expand_compare;
|
|
expand_asserts;
|
|
expand_if_some;
|
|
expand_if_right;
|
|
expand_fail ]
|
|
|
|
let expand_rec expr =
|
|
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_rec expr =
|
|
match expand expr with
|
|
| Ok expanded -> (
|
|
match expanded with
|
|
| Seq (loc, items) ->
|
|
let (items, errors) = error_map expand_rec items in
|
|
(Seq (loc, items), errors)
|
|
| Prim (loc, name, args, annot) ->
|
|
let (args, errors) = error_map expand_rec args in
|
|
(Prim (loc, name, args, annot), errors)
|
|
| (Int _ | String _ | Bytes _) as atom ->
|
|
(atom, []) )
|
|
| Error errors ->
|
|
(expr, errors)
|
|
in
|
|
expand_rec expr
|
|
|
|
let unexpand_caddadr expanded =
|
|
let rec rsteps acc = function
|
|
| [] ->
|
|
Some acc
|
|
| Prim (_, "CAR", [], []) :: rest ->
|
|
rsteps ("A" :: acc) rest
|
|
| Prim (_, "CDR", [], []) :: rest ->
|
|
rsteps ("D" :: acc) rest
|
|
| _ ->
|
|
None
|
|
in
|
|
match expanded with
|
|
| Seq (loc, (Prim (_, "CAR", [], []) :: _ as nodes))
|
|
| Seq (loc, (Prim (_, "CDR", [], []) :: _ as nodes)) -> (
|
|
match rsteps [] nodes with
|
|
| Some steps ->
|
|
let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in
|
|
Some (Prim (loc, name, [], []))
|
|
| None ->
|
|
None )
|
|
| _ ->
|
|
None
|
|
|
|
let unexpand_set_caddadr expanded =
|
|
let rec steps acc annots = function
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "CDR", [], _);
|
|
Prim (_, "SWAP", [], _);
|
|
Prim (_, "PAIR", [], _) ] ) ->
|
|
Some (loc, "A" :: acc, annots)
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "CAR", [], [field_annot]);
|
|
Prim (_, "DROP", [], []);
|
|
Prim (_, "CDR", [], _);
|
|
Prim (_, "SWAP", [], []);
|
|
Prim (_, "PAIR", [], _) ] ) ->
|
|
Some (loc, "A" :: acc, field_annot :: annots)
|
|
| Seq (loc, [Prim (_, "CAR", [], _); Prim (_, "PAIR", [], _)]) ->
|
|
Some (loc, "D" :: acc, annots)
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "CDR", [], [field_annot]);
|
|
Prim (_, "DROP", [], []);
|
|
Prim (_, "CAR", [], _);
|
|
Prim (_, "PAIR", [], _) ] ) ->
|
|
Some (loc, "D" :: acc, field_annot :: annots)
|
|
| Seq
|
|
( _,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], _); sub])], []);
|
|
Prim (_, "CDR", [], _);
|
|
Prim (_, "SWAP", [], []);
|
|
Prim (_, "PAIR", [], pair_annots) ] ) ->
|
|
let (_, pair_annots) = extract_field_annots pair_annots in
|
|
steps ("A" :: acc) (List.rev_append pair_annots annots) sub
|
|
| Seq
|
|
( _,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], _); sub])], []);
|
|
Prim (_, "CAR", [], _);
|
|
Prim (_, "PAIR", [], pair_annots) ] ) ->
|
|
let (_, pair_annots) = extract_field_annots pair_annots in
|
|
steps ("D" :: acc) (List.rev_append pair_annots annots) sub
|
|
| _ ->
|
|
None
|
|
in
|
|
match steps [] [] expanded with
|
|
| Some (loc, steps, annots) ->
|
|
let name = String.concat "" ("SET_C" :: List.rev ("R" :: steps)) in
|
|
Some (Prim (loc, name, [], List.rev annots))
|
|
| None ->
|
|
None
|
|
|
|
let unexpand_map_caddadr expanded =
|
|
let rec steps acc annots = function
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "CDR", [], _);
|
|
Prim (_, "SWAP", [], []);
|
|
Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], []); code])], []);
|
|
Prim (_, "PAIR", [], _) ] ) ->
|
|
Some (loc, "A" :: acc, annots, code)
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "CDR", [], _);
|
|
Prim (_, "SWAP", [], []);
|
|
Prim
|
|
( _,
|
|
"DIP",
|
|
[Seq (_, [Prim (_, "CAR", [], [field_annot]); code])],
|
|
[] );
|
|
Prim (_, "PAIR", [], _) ] ) ->
|
|
Some (loc, "A" :: acc, field_annot :: annots, code)
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "CDR", [], []);
|
|
code;
|
|
Prim (_, "SWAP", [], []);
|
|
Prim (_, "CAR", [], _);
|
|
Prim (_, "PAIR", [], _) ] ) ->
|
|
Some (loc, "D" :: acc, annots, code)
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "CDR", [], [field_annot]);
|
|
code;
|
|
Prim (_, "SWAP", [], []);
|
|
Prim (_, "CAR", [], _);
|
|
Prim (_, "PAIR", [], _) ] ) ->
|
|
Some (loc, "D" :: acc, field_annot :: annots, code)
|
|
| Seq
|
|
( _,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], _); sub])], []);
|
|
Prim (_, "CDR", [], _);
|
|
Prim (_, "SWAP", [], []);
|
|
Prim (_, "PAIR", [], pair_annots) ] ) ->
|
|
let (_, pair_annots) = extract_field_annots pair_annots in
|
|
steps ("A" :: acc) (List.rev_append pair_annots annots) sub
|
|
| Seq
|
|
( _,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], []); sub])], []);
|
|
Prim (_, "CAR", [], []);
|
|
Prim (_, "PAIR", [], pair_annots) ] ) ->
|
|
let (_, pair_annots) = extract_field_annots pair_annots in
|
|
steps ("D" :: acc) (List.rev_append pair_annots annots) sub
|
|
| _ ->
|
|
None
|
|
in
|
|
match steps [] [] expanded with
|
|
| Some (loc, steps, annots, code) ->
|
|
let name = String.concat "" ("MAP_C" :: List.rev ("R" :: steps)) in
|
|
Some (Prim (loc, name, [code], List.rev annots))
|
|
| None ->
|
|
None
|
|
|
|
let unexpand_deprecated_dxiiivp expanded =
|
|
(* transparently turn the old expansion of deprecated [DI...IP] to [DIP n] *)
|
|
match expanded with
|
|
| Seq
|
|
( loc,
|
|
[Prim (_, "DIP", [(Seq (_, [Prim (_, "DIP", [_], [])]) as sub)], [])]
|
|
) ->
|
|
let rec count acc = function
|
|
| Seq (_, [Prim (_, "DIP", [sub], [])]) ->
|
|
count (acc + 1) sub
|
|
| sub ->
|
|
(acc, sub)
|
|
in
|
|
let (depth, sub) = count 1 sub in
|
|
Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], []))
|
|
| _ ->
|
|
None
|
|
|
|
let unexpand_dupn expanded =
|
|
match expanded with
|
|
| Seq
|
|
( loc,
|
|
[ Prim
|
|
(_, "DIP", [Int (_, np); Seq (_, [Prim (_, "DUP", [], annot)])], []);
|
|
Prim (_, "DIG", [Int (nloc, ng)], []) ] )
|
|
when Z.equal np (Z.pred ng) ->
|
|
Some (Prim (loc, "DUP", [Int (nloc, ng)], annot))
|
|
| _ ->
|
|
None
|
|
|
|
let unexpand_deprecated_duuuuup expanded =
|
|
(* transparently turn the old expansion of deprecated [DU...UP] to [DUP n] *)
|
|
let rec expand n = function
|
|
| Seq (loc, [Prim (nloc, "DUP", [], annot)]) ->
|
|
if n = 1 then None
|
|
else Some (Prim (loc, "DUP", [Int (nloc, Z.of_int n)], annot))
|
|
| Seq (_, [Prim (_, "DIP", [expanded'], []); Prim (_, "SWAP", [], [])]) ->
|
|
expand (n + 1) expanded'
|
|
| _ ->
|
|
None
|
|
in
|
|
expand 1 expanded
|
|
|
|
let rec normalize_pair_item ?(right = false) = function
|
|
| P (i, a, b) ->
|
|
P (i, normalize_pair_item a, normalize_pair_item ~right:true b)
|
|
| A when right ->
|
|
I
|
|
| A ->
|
|
A
|
|
| I ->
|
|
I
|
|
|
|
let unexpand_pappaiir expanded =
|
|
match expanded with
|
|
| Seq (_, [Prim (_, "PAIR", [], [])]) ->
|
|
Some expanded
|
|
| Seq (loc, (_ :: _ as nodes)) -> (
|
|
let rec exec stack nodes =
|
|
match (nodes, stack) with
|
|
| ([], _) ->
|
|
stack
|
|
(* support new expansion using [DIP n] *)
|
|
| ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest,
|
|
a :: rstack )
|
|
when Z.to_int n > 1 ->
|
|
exec
|
|
( a
|
|
:: exec
|
|
rstack
|
|
[ Prim
|
|
(ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
|
|
] )
|
|
rest
|
|
| (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack)
|
|
when Z.to_int n = 1 ->
|
|
exec (a :: exec rstack sub) rest
|
|
| (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [])
|
|
when Z.to_int n > 1 ->
|
|
exec
|
|
( A
|
|
:: exec
|
|
[]
|
|
[ Prim
|
|
(ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
|
|
] )
|
|
rest
|
|
| (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [])
|
|
when Z.to_int n = 1 ->
|
|
exec (A :: exec [] sub) rest
|
|
(* support old expansion using [DIP] *)
|
|
| (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) ->
|
|
exec (a :: exec rstack sub) rest
|
|
| (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) ->
|
|
exec (A :: exec [] sub) rest
|
|
| (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) ->
|
|
exec (P (0, a, b) :: rstack) rest
|
|
| (Prim (_, "PAIR", [], []) :: rest, [a]) ->
|
|
exec [P (0, a, I)] rest
|
|
| (Prim (_, "PAIR", [], []) :: rest, []) ->
|
|
exec [P (0, A, I)] rest
|
|
| _ ->
|
|
raise_notrace Not_a_pair
|
|
in
|
|
match exec [] nodes with
|
|
| [] ->
|
|
None
|
|
| res :: _ ->
|
|
let res = normalize_pair_item res in
|
|
let name = unparse_pair_item res in
|
|
Some (Prim (loc, name, [], []))
|
|
| exception Not_a_pair ->
|
|
None )
|
|
| _ ->
|
|
None
|
|
|
|
let unexpand_unpappaiir expanded =
|
|
match expanded with
|
|
| Seq (loc, (_ :: _ as nodes)) -> (
|
|
let rec exec stack nodes =
|
|
match (nodes, stack) with
|
|
| ([], _) ->
|
|
stack
|
|
(* support new expansion using [DIP n] *)
|
|
| ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest,
|
|
a :: rstack )
|
|
when Z.to_int n > 1 ->
|
|
exec
|
|
( a
|
|
:: exec
|
|
rstack
|
|
[ Prim
|
|
(ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
|
|
] )
|
|
rest
|
|
| (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack)
|
|
when Z.to_int n = 1 ->
|
|
exec (a :: exec rstack sub) rest
|
|
| (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [])
|
|
when Z.to_int n > 1 ->
|
|
exec
|
|
( A
|
|
:: exec
|
|
[]
|
|
[ Prim
|
|
(ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
|
|
] )
|
|
rest
|
|
| (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [])
|
|
when Z.to_int n = 1 ->
|
|
exec (A :: exec [] sub) rest
|
|
(* support old expansion using [DIP] *)
|
|
| (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) ->
|
|
exec (a :: exec rstack sub) rest
|
|
| (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) ->
|
|
exec (A :: exec [] sub) rest
|
|
| ( Seq
|
|
( _,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "CAR", [], []);
|
|
Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ]
|
|
)
|
|
:: rest,
|
|
a :: b :: rstack ) ->
|
|
exec (P (0, a, b) :: rstack) rest
|
|
| ( Seq
|
|
( _,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "CAR", [], []);
|
|
Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ]
|
|
)
|
|
:: rest,
|
|
[a] ) ->
|
|
exec [P (0, a, I)] rest
|
|
| ( Seq
|
|
( _,
|
|
[ Prim (_, "DUP", [], []);
|
|
Prim (_, "CAR", [], []);
|
|
Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ]
|
|
)
|
|
:: rest,
|
|
[] ) ->
|
|
exec [P (0, A, I)] rest
|
|
| _ ->
|
|
raise_notrace Not_a_pair
|
|
in
|
|
match exec [] (List.rev nodes) with
|
|
| [] ->
|
|
None
|
|
| res :: _ ->
|
|
let res = normalize_pair_item res in
|
|
let name = "UN" ^ unparse_pair_item res in
|
|
Some (Prim (loc, name, [], []))
|
|
| exception Not_a_pair ->
|
|
None )
|
|
| _ ->
|
|
None
|
|
|
|
let unexpand_compare expanded =
|
|
match expanded with
|
|
| Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "EQ", [], annot)]) ->
|
|
Some (Prim (loc, "CMPEQ", [], annot))
|
|
| Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "NEQ", [], annot)]) ->
|
|
Some (Prim (loc, "CMPNEQ", [], annot))
|
|
| Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "LT", [], annot)]) ->
|
|
Some (Prim (loc, "CMPLT", [], annot))
|
|
| Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "GT", [], annot)]) ->
|
|
Some (Prim (loc, "CMPGT", [], annot))
|
|
| Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "LE", [], annot)]) ->
|
|
Some (Prim (loc, "CMPLE", [], annot))
|
|
| Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "GE", [], annot)]) ->
|
|
Some (Prim (loc, "CMPGE", [], annot))
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "COMPARE", [], _);
|
|
Prim (_, "EQ", [], _);
|
|
Prim (_, "IF", args, annot) ] ) ->
|
|
Some (Prim (loc, "IFCMPEQ", args, annot))
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "COMPARE", [], _);
|
|
Prim (_, "NEQ", [], _);
|
|
Prim (_, "IF", args, annot) ] ) ->
|
|
Some (Prim (loc, "IFCMPNEQ", args, annot))
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "COMPARE", [], _);
|
|
Prim (_, "LT", [], _);
|
|
Prim (_, "IF", args, annot) ] ) ->
|
|
Some (Prim (loc, "IFCMPLT", args, annot))
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "COMPARE", [], _);
|
|
Prim (_, "GT", [], _);
|
|
Prim (_, "IF", args, annot) ] ) ->
|
|
Some (Prim (loc, "IFCMPGT", args, annot))
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "COMPARE", [], _);
|
|
Prim (_, "LE", [], _);
|
|
Prim (_, "IF", args, annot) ] ) ->
|
|
Some (Prim (loc, "IFCMPLE", args, annot))
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, "COMPARE", [], _);
|
|
Prim (_, "GE", [], _);
|
|
Prim (_, "IF", args, annot) ] ) ->
|
|
Some (Prim (loc, "IFCMPGE", args, annot))
|
|
| Seq (loc, [Prim (_, "EQ", [], _); Prim (_, "IF", args, annot)]) ->
|
|
Some (Prim (loc, "IFEQ", args, annot))
|
|
| Seq (loc, [Prim (_, "NEQ", [], _); Prim (_, "IF", args, annot)]) ->
|
|
Some (Prim (loc, "IFNEQ", args, annot))
|
|
| Seq (loc, [Prim (_, "LT", [], _); Prim (_, "IF", args, annot)]) ->
|
|
Some (Prim (loc, "IFLT", args, annot))
|
|
| Seq (loc, [Prim (_, "GT", [], _); Prim (_, "IF", args, annot)]) ->
|
|
Some (Prim (loc, "IFGT", args, annot))
|
|
| Seq (loc, [Prim (_, "LE", [], _); Prim (_, "IF", args, annot)]) ->
|
|
Some (Prim (loc, "IFLE", args, annot))
|
|
| Seq (loc, [Prim (_, "GE", [], _); Prim (_, "IF", args, annot)]) ->
|
|
Some (Prim (loc, "IFGE", args, annot))
|
|
| _ ->
|
|
None
|
|
|
|
let unexpand_asserts expanded =
|
|
match expanded with
|
|
| Seq
|
|
( loc,
|
|
[ Prim
|
|
( _,
|
|
"IF",
|
|
[ Seq (_, []);
|
|
Seq
|
|
( _,
|
|
[ Seq
|
|
( _,
|
|
[ Prim (_, "UNIT", [], []);
|
|
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
|
|
[] ) ] ) ->
|
|
Some (Prim (loc, "ASSERT", [], []))
|
|
| Seq
|
|
( loc,
|
|
[ Seq (_, [Prim (_, "COMPARE", [], []); Prim (_, comparison, [], [])]);
|
|
Prim
|
|
( _,
|
|
"IF",
|
|
[ Seq (_, []);
|
|
Seq
|
|
( _,
|
|
[ Seq
|
|
( _,
|
|
[ Prim (_, "UNIT", [], []);
|
|
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
|
|
[] ) ] ) ->
|
|
Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], []))
|
|
| Seq
|
|
( loc,
|
|
[ Prim (_, comparison, [], []);
|
|
Prim
|
|
( _,
|
|
"IF",
|
|
[ Seq (_, []);
|
|
Seq
|
|
( _,
|
|
[ Seq
|
|
( _,
|
|
[ Prim (_, "UNIT", [], []);
|
|
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
|
|
[] ) ] ) ->
|
|
Some (Prim (loc, "ASSERT_" ^ comparison, [], []))
|
|
| Seq
|
|
( loc,
|
|
[ Prim
|
|
( _,
|
|
"IF_NONE",
|
|
[ Seq (_, [Prim (_, "RENAME", [], annot)]);
|
|
Seq
|
|
( _,
|
|
[ Seq
|
|
( _,
|
|
[ Prim (_, "UNIT", [], []);
|
|
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
|
|
[] ) ] ) ->
|
|
Some (Prim (loc, "ASSERT_NONE", [], annot))
|
|
| Seq
|
|
( loc,
|
|
[ Prim
|
|
( _,
|
|
"IF_NONE",
|
|
[ Seq (_, []);
|
|
Seq
|
|
( _,
|
|
[ Seq
|
|
( _,
|
|
[ Prim (_, "UNIT", [], []);
|
|
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
|
|
[] ) ] ) ->
|
|
Some (Prim (loc, "ASSERT_NONE", [], []))
|
|
| Seq
|
|
( loc,
|
|
[ Prim
|
|
( _,
|
|
"IF_NONE",
|
|
[ Seq
|
|
( _,
|
|
[ Seq
|
|
( _,
|
|
[ Prim (_, "UNIT", [], []);
|
|
Prim (_, "FAILWITH", [], []) ] ) ] );
|
|
Seq (_, []) ],
|
|
[] ) ] ) ->
|
|
Some (Prim (loc, "ASSERT_SOME", [], []))
|
|
| Seq
|
|
( loc,
|
|
[ Prim
|
|
( _,
|
|
"IF_NONE",
|
|
[ Seq
|
|
( _,
|
|
[ Seq
|
|
( _,
|
|
[ Prim (_, "UNIT", [], []);
|
|
Prim (_, "FAILWITH", [], []) ] ) ] );
|
|
Seq (_, [Prim (_, "RENAME", [], annot)]) ],
|
|
[] ) ] ) ->
|
|
Some (Prim (loc, "ASSERT_SOME", [], annot))
|
|
| Seq
|
|
( loc,
|
|
[ Prim
|
|
( _,
|
|
"IF_LEFT",
|
|
[ Seq (_, []);
|
|
Seq
|
|
( _,
|
|
[ Seq
|
|
( _,
|
|
[ Prim (_, "UNIT", [], []);
|
|
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
|
|
[] ) ] ) ->
|
|
Some (Prim (loc, "ASSERT_LEFT", [], []))
|
|
| Seq
|
|
( loc,
|
|
[ Prim
|
|
( _,
|
|
"IF_LEFT",
|
|
[ Seq (_, [Prim (_, "RENAME", [], annot)]);
|
|
Seq
|
|
( _,
|
|
[ Seq
|
|
( _,
|
|
[ Prim (_, "UNIT", [], []);
|
|
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
|
|
[] ) ] ) ->
|
|
Some (Prim (loc, "ASSERT_LEFT", [], annot))
|
|
| Seq
|
|
( loc,
|
|
[ Prim
|
|
( _,
|
|
"IF_LEFT",
|
|
[ Seq
|
|
( _,
|
|
[ Seq
|
|
( _,
|
|
[ Prim (_, "UNIT", [], []);
|
|
Prim (_, "FAILWITH", [], []) ] ) ] );
|
|
Seq (_, []) ],
|
|
[] ) ] ) ->
|
|
Some (Prim (loc, "ASSERT_RIGHT", [], []))
|
|
| Seq
|
|
( loc,
|
|
[ Prim
|
|
( _,
|
|
"IF_LEFT",
|
|
[ Seq
|
|
( _,
|
|
[ Seq
|
|
( _,
|
|
[ Prim (_, "UNIT", [], []);
|
|
Prim (_, "FAILWITH", [], []) ] ) ] );
|
|
Seq (_, [Prim (_, "RENAME", [], annot)]) ],
|
|
[] ) ] ) ->
|
|
Some (Prim (loc, "ASSERT_RIGHT", [], annot))
|
|
| _ ->
|
|
None
|
|
|
|
let unexpand_if_some = function
|
|
| Seq (loc, [Prim (_, "IF_NONE", [left; right], annot)]) ->
|
|
Some (Prim (loc, "IF_SOME", [right; left], annot))
|
|
| _ ->
|
|
None
|
|
|
|
let unexpand_if_right = function
|
|
| Seq (loc, [Prim (_, "IF_LEFT", [left; right], annot)]) ->
|
|
Some (Prim (loc, "IF_RIGHT", [right; left], annot))
|
|
| _ ->
|
|
None
|
|
|
|
let unexpand_fail = function
|
|
| Seq (loc, [Prim (_, "UNIT", [], []); Prim (_, "FAILWITH", [], [])]) ->
|
|
Some (Prim (loc, "FAIL", [], []))
|
|
| _ ->
|
|
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_deprecated_dxiiivp;
|
|
unexpand_pappaiir;
|
|
unexpand_unpappaiir;
|
|
unexpand_deprecated_duuuuup;
|
|
unexpand_dupn;
|
|
unexpand_compare;
|
|
unexpand_if_some;
|
|
unexpand_if_right;
|
|
unexpand_fail ]
|
|
|
|
(*
|
|
If an argument of Prim is a sequence, we do not want to unexpand
|
|
its root in case the source already contains an expanded macro. In
|
|
which case unexpansion would remove surrounding braces and generate
|
|
ill-formed code.
|
|
|
|
For example, DIIP { DIP { DUP }; SWAP } is not unexpandable but
|
|
DIIP {{ DIP { DUP }; SWAP }} (note the double braces) is unexpanded
|
|
to DIIP { DUUP }.
|
|
|
|
unexpand_rec_but_root is the same as unexpand_rec but does not try
|
|
to unexpand at root *)
|
|
|
|
let rec unexpand_rec expr = unexpand_rec_but_root (unexpand expr)
|
|
|
|
and unexpand_rec_but_root = function
|
|
| Seq (loc, items) ->
|
|
Seq (loc, List.map unexpand_rec items)
|
|
| Prim (loc, name, args, annot) ->
|
|
Prim (loc, name, List.map unexpand_rec_but_root args, annot)
|
|
| (Int _ | String _ | Bytes _) as atom ->
|
|
atom
|
|
|
|
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
|
|
exp
|
|
got)
|
|
(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))
|