1177 lines
45 KiB
OCaml
1177 lines
45 KiB
OCaml
|
(*****************************************************************************)
|
||
|
|
(* *)
|
||
|
|
(* Open Source License *)
|
||
|
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.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 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 (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)
|
||
|
|
else
|
||
|
|
let annot = if i = len - 2 then annot else [] in
|
||
|
|
match String.get str i with
|
||
|
|
| 'A' -> parse (i - 1) [] (Prim (loc, "CAR", [], annot) :: acc)
|
||
|
|
| 'D' -> parse (i - 1) [] (Prim (loc, "CDR", [], annot) :: acc)
|
||
|
|
| _ -> assert false in
|
||
|
|
ok (Some (parse (len - 2) annot []))
|
||
|
|
else
|
||
|
|
ok None
|
||
|
|
| _ -> ok None
|
||
|
|
|
||
|
|
let extract_first_annot annot char =
|
||
|
|
let rec extract_first_annot others = function
|
||
|
|
| [] -> None, List.rev others
|
||
|
|
| a :: rest ->
|
||
|
|
try
|
||
|
|
if a.[0] = char
|
||
|
|
then Some a, List.rev_append others rest
|
||
|
|
else extract_first_annot (a :: others) rest
|
||
|
|
with Invalid_argument _ -> extract_first_annot (a :: others) rest
|
||
|
|
in
|
||
|
|
extract_first_annot [] annot
|
||
|
|
|
||
|
|
let extract_first_field_annot annot = extract_first_annot annot '%'
|
||
|
|
let extract_first_var_annot annot = extract_first_annot annot '@'
|
||
|
|
|
||
|
|
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"
|
||
|
|
&& 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 () ->
|
||
|
|
begin match extract_field_annots annot with
|
||
|
|
| [], annot -> ok (None, annot)
|
||
|
|
| [f], annot -> ok (Some f, annot)
|
||
|
|
| _, _ -> error (Unexpected_macro_annotation str)
|
||
|
|
end >>? 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 String.get 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 String.get 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"
|
||
|
|
&& String.get str (len - 1) = 'R'
|
||
|
|
&& check_letters str 5 (len - 2)
|
||
|
|
(function 'A' | 'D' -> true | _ -> false) then
|
||
|
|
begin match args with
|
||
|
|
| [ Seq _ as code ] -> ok code
|
||
|
|
| [ _ ] -> error (Sequence_expected str)
|
||
|
|
| [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))
|
||
|
|
end >>? fun code ->
|
||
|
|
begin match extract_field_annots annot with
|
||
|
|
| [], annot -> ok (None, annot)
|
||
|
|
| [f], annot -> ok (Some f, annot)
|
||
|
|
| _, _ -> error (Unexpected_macro_annotation str)
|
||
|
|
end >>? 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 String.get 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 String.get 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 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) ])) 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 rec dip ~loc depth instr =
|
||
|
|
if depth <= 0
|
||
|
|
then instr
|
||
|
|
else dip ~loc (depth - 1) (Prim (loc, "DIP", [ Seq (loc, [ instr ]) ], []))
|
||
|
|
|
||
|
|
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 String.get 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 String.get str i = 'A' && left = Some true then
|
||
|
|
i + 1, A
|
||
|
|
else if String.get 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
|
||
|
|
&& String.get str 0 = 'P'
|
||
|
|
&& String.get 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 = dip ~loc depth (Prim (loc, "PAIR", [], annot)) :: acc in
|
||
|
|
(depth, acc)
|
||
|
|
|> parse left
|
||
|
|
|> parse right
|
||
|
|
| A | I -> (depth + 1, acc)
|
||
|
|
in
|
||
|
|
let _, expanded = parse ast (0, []) in
|
||
|
|
begin match args with
|
||
|
|
| [] -> ok ()
|
||
|
|
| _ :: _ -> error (Invalid_arity (str, List.length args, 0))
|
||
|
|
end >>? 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"
|
||
|
|
&& String.get 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 (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 = dip ~loc depth (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
|
||
|
|
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 ], []) ;
|
||
|
|
Prim (loc, "SWAP", [], []) ]))
|
||
|
|
else
|
||
|
|
raise_notrace Not_a_dup in
|
||
|
|
ok (Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", [], annot) ]))))
|
||
|
|
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_") ->
|
||
|
|
begin match args with
|
||
|
|
| [] -> ok ()
|
||
|
|
| _ :: _ -> error (Invalid_arity (s, List.length args, 0))
|
||
|
|
end >>? fun () ->
|
||
|
|
begin match annot with
|
||
|
|
| _ :: _ -> (error (Unexpected_macro_annotation s))
|
||
|
|
| [] -> ok ()
|
||
|
|
end >>? fun () ->
|
||
|
|
begin
|
||
|
|
let remaining = String.(sub s 7 (length s - 7)) in
|
||
|
|
let remaining_prim = Prim (loc, remaining, [], []) in
|
||
|
|
match remaining with
|
||
|
|
| "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" ->
|
||
|
|
ok @@ Some (Seq (loc, [ remaining_prim ;
|
||
|
|
Prim (loc, "IF", fail_false loc, []) ]))
|
||
|
|
| _ ->
|
||
|
|
begin
|
||
|
|
expand_compare remaining_prim >|? function
|
||
|
|
| None -> None
|
||
|
|
| Some seq ->
|
||
|
|
Some (Seq (loc, [ seq ;
|
||
|
|
Prim (loc, "IF", fail_false loc, []) ]))
|
||
|
|
end
|
||
|
|
end
|
||
|
|
| _ -> 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_dxiiivp ;
|
||
|
|
(* expand_paaiair ; *)
|
||
|
|
expand_pappaiir ;
|
||
|
|
(* expand_unpaaiair ; *)
|
||
|
|
expand_unpappaiir ;
|
||
|
|
expand_duuuuup ;
|
||
|
|
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 ->
|
||
|
|
begin
|
||
|
|
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, []) end
|
||
|
|
| 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)) ->
|
||
|
|
begin match rsteps [] nodes with
|
||
|
|
| Some steps ->
|
||
|
|
let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in
|
||
|
|
Some (Prim (loc, name, [], []))
|
||
|
|
| None -> None
|
||
|
|
end
|
||
|
|
| _ -> 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 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 dxiiivp_roman_of_decimal decimal =
|
||
|
|
let roman = roman_of_decimal decimal in
|
||
|
|
if String.length roman = 1 then
|
||
|
|
(* too short for D*P, fall back to IIIII... *)
|
||
|
|
String.concat "" (List.init decimal (fun _ -> "I"))
|
||
|
|
else
|
||
|
|
roman
|
||
|
|
|
||
|
|
let unexpand_dxiiivp expanded =
|
||
|
|
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
|
||
|
|
let name = "D" ^ dxiiivp_roman_of_decimal depth ^ "P" in
|
||
|
|
Some (Prim (loc, name, [ sub ], []))
|
||
|
|
| _ -> None
|
||
|
|
|
||
|
|
let unexpand_duuuuup expanded =
|
||
|
|
let rec help expanded =
|
||
|
|
match expanded with
|
||
|
|
| Seq (loc, [ Prim (_, "DUP", [], []) ]) -> Some (loc, 1)
|
||
|
|
| Seq (_, [ Prim (_, "DIP", [expanded'], []);
|
||
|
|
Prim (_, "SWAP", [], []) ]) ->
|
||
|
|
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), [], []))
|
||
|
|
|
||
|
|
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
|
||
|
|
| 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
|
||
|
|
begin 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
|
||
|
|
end
|
||
|
|
| _ -> None
|
||
|
|
|
||
|
|
let unexpand_unpappaiir expanded =
|
||
|
|
match expanded with
|
||
|
|
| Seq (loc, (_ :: _ as nodes)) ->
|
||
|
|
let rec exec stack nodes = match nodes, stack with
|
||
|
|
| [], _ -> stack
|
||
|
|
| 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
|
||
|
|
begin 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
|
||
|
|
end
|
||
|
|
| _ -> 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_dxiiivp ;
|
||
|
|
unexpand_pappaiir ;
|
||
|
|
unexpand_unpappaiir ;
|
||
|
|
unexpand_duuuuup ;
|
||
|
|
unexpand_compare ;
|
||
|
|
unexpand_if_some ;
|
||
|
|
unexpand_if_right ;
|
||
|
|
unexpand_fail ]
|
||
|
|
|
||
|
|
let rec unexpand_rec expr =
|
||
|
|
match unexpand expr with
|
||
|
|
| Seq (loc, items) ->
|
||
|
|
Seq (loc, List.map unexpand_rec items)
|
||
|
|
| Prim (loc, name, args, annot) ->
|
||
|
|
Prim (loc, name, List.map unexpand_rec args, annot)
|
||
|
|
| Int _ | String _ | 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 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))
|