diff --git a/dune-project b/dune-project index effd9a3..b64a6e1 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.8) +(lang dune 3.15) (name lltz) @@ -19,10 +19,10 @@ "A common compiler IR for targetting Michelson, the stack-based language of the Tezos blockchain.") (depends (ocaml - (= 4.14.2)) + (>= 4.14.1)) dune core ppx_jane - tezos-micheline + octez-libs ppxlib grace)) diff --git a/lib/lltz_codegen/config.ml b/lib/lltz_codegen/config.ml index 2014f51..9b5c53d 100644 --- a/lib/lltz_codegen/config.ml +++ b/lib/lltz_codegen/config.ml @@ -1,4 +1,4 @@ -module I = Michelson.Ast.Instruction +module I = Lltz_michelson.Ast.Instruction module ExtStack = struct type t = diff --git a/lib/lltz_codegen/instruction.ml b/lib/lltz_codegen/instruction.ml index 47fcb41..f9013cb 100644 --- a/lib/lltz_codegen/instruction.ml +++ b/lib/lltz_codegen/instruction.ml @@ -5,7 +5,7 @@ does not match instruction requirements. *) -module M = Michelson.Ast +module M = Lltz_michelson.Ast module I = M.Instruction module T = M.Type @@ -697,7 +697,7 @@ let next_trace_point = ref (-1) (* Directly using michelson specified via micheline. Can take arbitrary number of args and return a single value. *) let rec micheline_fails - (node : (unit, Michelson.Ast.Prim.t) Tezos_micheline.Micheline.node) + (node : (unit, Lltz_michelson.Ast.Prim.t) Tezos_micheline.Micheline.node) = match node with | Prim (_, I Failwith, _, _) -> true diff --git a/lib/lltz_codegen/lltz_codegen.ml b/lib/lltz_codegen/lltz_codegen.ml index 8ed3649..f9d6e52 100644 --- a/lib/lltz_codegen/lltz_codegen.ml +++ b/lib/lltz_codegen/lltz_codegen.ml @@ -21,8 +21,8 @@ module LLTZ = struct end module Michelson = struct - module Ast = Michelson.Ast - module T = Michelson.Ast.Type + module Ast = Lltz_michelson.Ast + module T = Lltz_michelson.Ast.Type end open Instruction @@ -359,17 +359,30 @@ and compile_const constant = (* Compile a primitive by compiling its arguments, then applying the primitive to the arguments. *) and compile_prim primitive args = - trace ~flag:((Sexp.to_string_hum (LLTZ.P.sexp_of_t primitive))) ( - let args_instrs = List.map ~f:(compile ) args in - match primitive with - | LLTZ.P.Failwith -> - seq (List.rev_append args_instrs [ Instruction.failwith ]) - | LLTZ.P.Never -> seq (List.rev_append args_instrs [ Instruction.never ]) - | LLTZ.P.Sub -> - (seq (List.rev(args_instrs) @ [ prim ~message:(Sexp.to_string_hum (LLTZ.P.sexp_of_t primitive)) (List.length args) 1 (convert_primitive primitive) ])) - | _ -> - (seq (List.rev(args_instrs) @ [ prim ~message:(Sexp.to_string_hum (LLTZ.P.sexp_of_t primitive)) (List.length args) 1 (convert_primitive primitive) ])) - ) + trace + ~flag:(Sexp.to_string_hum (LLTZ.P.sexp_of_t primitive)) + (let args_instrs = List.map ~f:compile args in + match primitive with + | LLTZ.P.Failwith -> seq (List.rev_append args_instrs [ Instruction.failwith ]) + | LLTZ.P.Never -> seq (List.rev_append args_instrs [ Instruction.never ]) + | LLTZ.P.Sub -> + seq + (List.rev args_instrs + @ [ prim + ~message:(Sexp.to_string_hum (LLTZ.P.sexp_of_t primitive)) + (List.length args) + 1 + (convert_primitive primitive) + ]) + | _ -> + seq + (List.rev args_instrs + @ [ prim + ~message:(Sexp.to_string_hum (LLTZ.P.sexp_of_t primitive)) + (List.length args) + 1 + (convert_primitive primitive) + ])) (* Compile a dereference by duplicating the value of the mutable variable on the stack. *) and compile_deref name type_ annotations = diff --git a/lib/lltz_codegen/type.ml b/lib/lltz_codegen/type.ml index eb5c059..db72c78 100644 --- a/lib/lltz_codegen/type.ml +++ b/lib/lltz_codegen/type.ml @@ -1,4 +1,4 @@ -module M = Michelson.Ast +module M = Lltz_michelson.Ast module T = M.Type let tuple ?(annot = None) types = diff --git a/lib/lltz_ir/ast_builder.ml b/lib/lltz_ir/ast_builder.ml index 9aa129f..33fb4da 100644 --- a/lib/lltz_ir/ast_builder.ml +++ b/lib/lltz_ir/ast_builder.ml @@ -32,15 +32,15 @@ let rec get_proj_type (row : LLTZ.T.t LLTZ.R.t) (path : int list) : LLTZ.T.t = match path with | i :: path_tail -> (match row with - | LLTZ.R.Leaf (_, _) -> raise_s [%message "Invalid path" (path : int list)] + | LLTZ.R.Leaf (_, _) -> raise_s [%message "Invalid path: unexpected leaf" (path : int list)] | LLTZ.R.Node row_list -> (match List.nth row_list i with | Some expr -> get_proj_type expr path_tail - | None -> raise_s [%message "Invalid path" (path : int list)])) + | None -> raise_s [%message "Invalid path: out of bounds" (path : int list)])) | [] -> (match row with | LLTZ.R.Leaf (_, ty) -> ty - | LLTZ.R.Node _ -> raise_s [%message "Invalid path" (path : int list)]) + | LLTZ.R.Node _ -> raise_s [%message "Invalid path: unexpected node" (path : int list)]) ;; let get_inj_type (context : LLTZ.T.t LLTZ.R.Context.t) : LLTZ.T.desc = @@ -903,16 +903,17 @@ module Default = struct ;; let concat1 ~range val_list = - create ~range (LLTZ.E.Prim (LLTZ.P.Concat1, [val_list])) - ( - match val_list.LLTZ.E.type_.LLTZ.T.desc with - | LLTZ.T.List ty -> ty - | _ -> raise_s [%message "Expected list or bytes type"] - ) + create + ~range + (LLTZ.E.Prim (LLTZ.P.Concat1, [ val_list ])) + (match val_list.LLTZ.E.type_.LLTZ.T.desc with + | LLTZ.T.List ty -> ty + | _ -> raise_s [%message "Expected list or bytes type"]) + ;; let concat2 ~range val1 val2 = - create ~range (LLTZ.E.Prim (LLTZ.P.Concat2, [val1; val2])) - val1.LLTZ.E.type_ + create ~range (LLTZ.E.Prim (LLTZ.P.Concat2, [ val1; val2 ])) val1.LLTZ.E.type_ + ;; let get ~range key collection = create diff --git a/lib/michelson/ast.ml b/lib/lltz_michelson/ast.ml similarity index 100% rename from lib/michelson/ast.ml rename to lib/lltz_michelson/ast.ml diff --git a/lib/michelson/dune b/lib/lltz_michelson/dune similarity index 72% rename from lib/michelson/dune rename to lib/lltz_michelson/dune index 74abe44..8f2005d 100644 --- a/lib/michelson/dune +++ b/lib/lltz_michelson/dune @@ -1,5 +1,5 @@ (library - (name michelson) + (name lltz_michelson) (public_name lltz.michelson) (inline_tests) (libraries @@ -7,4 +7,4 @@ octez-libs.micheline ) (preprocess - (pps ppx_jane))) \ No newline at end of file + (pps ppx_jane))) diff --git a/lib/lltz_michelson/lltz_michelson.ml b/lib/lltz_michelson/lltz_michelson.ml deleted file mode 100644 index 146362f..0000000 --- a/lib/lltz_michelson/lltz_michelson.ml +++ /dev/null @@ -1,580 +0,0 @@ -(* - lltz_michelson.ml - Compiles types, constants, primitives and expressions from LLTZ-IR to Michelson Ast. -*) - -module Stack = Stack -module Type = Type -module Instruction = Instruction -module Slot = Slot -open Core - -module LLTZ = struct - module E = Lltz_ir.Expr - module T = Lltz_ir.Type - module R = Lltz_ir.Row - module P = Lltz_ir.Primitive - module Dsl = Lltz_ir.Dsl -end - -module Michelson = struct - module Ast = Michelson.Ast - module T = Michelson.Ast.Type -end - -open Instruction - -(* Creates corresponding tuple type from a row of types *) -let rec compile_row_types row = - match row with - | LLTZ.R.Node nodes -> Type.tuple (List.map nodes ~f:compile_row_types) - | LLTZ.R.Leaf (_, value) -> convert_type value - -(* Creates corresponding or type from a row of types *) -and compile_row_types_for_or row = - match row with - | LLTZ.R.Node nodes -> - let converted_types = List.map nodes ~f:compile_row_types in - Type.ors converted_types - | LLTZ.R.Leaf (_, value) -> convert_type value - -and convert_type (ty : LLTZ.T.t) : Michelson.Ast.t = - match ty.desc with - | Tuple row -> compile_row_types row - | Or row -> compile_row_types_for_or row - | Option ty -> Michelson.T.option (convert_type ty) - | List ty -> Michelson.T.list (convert_type ty) - | Set ty -> Michelson.T.set (convert_type ty) - | Contract ty -> Michelson.T.contract (convert_type ty) - | Ticket ty -> Michelson.T.ticket (convert_type ty) - | Function (param, ret) -> Michelson.T.lambda (convert_type param) (convert_type ret) - | Map (key, value) -> Michelson.T.map (convert_type key) (convert_type value) - | Big_map (key, value) -> Michelson.T.big_map (convert_type key) (convert_type value) - | Unit -> Michelson.T.unit - | Bool -> Michelson.T.bool - | Nat -> Michelson.T.nat - | Int -> Michelson.T.int - | Mutez -> Michelson.T.mutez - | String -> Michelson.T.string - | Bytes -> Michelson.T.bytes - | Chain_id -> Michelson.T.chain_id - | Timestamp -> Michelson.T.timestamp - | Address -> Michelson.T.address - | Keys -> Michelson.T.key - | Key_hash -> Michelson.T.key_hash - | Signature -> Michelson.T.signature - | Operation -> Michelson.T.operation - | Sapling_state { memo } -> Michelson.T.sampling_state (Michelson.Ast.int memo) - | Sapling_transaction { memo } -> - Michelson.T.sapling_transaction (Michelson.Ast.int memo) - | Never -> Michelson.T.never - | Bls12_381_g1 -> Michelson.T.bls12_381_g1 - | Bls12_381_g2 -> Michelson.T.bls12_381_g2 - | Bls12_381_fr -> Michelson.T.bls12_381_fr - | Chest_key -> Michelson.T.chest_key - | Chest -> Michelson.T.chest - -and convert_constant (const : LLTZ.E.constant) : Michelson.Ast.t = - match const with - | Unit -> Michelson.Ast.Instruction.unit - | Bool b -> if b then Michelson.Ast.true_ else Michelson.Ast.false_ - | Nat n -> Michelson.Ast.int (Z.to_int n) - | Int n -> Michelson.Ast.int (Z.to_int n) - | Mutez n -> Michelson.Ast.int (Z.to_int n) - | String s -> Michelson.Ast.string s - | Key s -> Michelson.Ast.string s - | Key_hash s -> Michelson.Ast.string s - | Bytes s -> Michelson.Ast.(bytes (Bytes.of_string s)) - | Chain_id s -> Michelson.Ast.string s - | Address s -> Michelson.Ast.string s - | Timestamp s -> Michelson.Ast.string s - | Bls12_381_g1 s -> Michelson.Ast.string s - | Bls12_381_g2 s -> Michelson.Ast.string s - | Bls12_381_fr s -> Michelson.Ast.string s - | Signature s -> Michelson.Ast.string s -;; - -let get_const_type (const : LLTZ.E.constant) : Michelson.Ast.t = - match const with - | Unit -> Michelson.T.unit - | Bool _ -> Michelson.T.bool - | Nat _ -> Michelson.T.nat - | Int _ -> Michelson.T.int - | Mutez _ -> Michelson.T.mutez - | String _ -> Michelson.T.string - | Key _ -> Michelson.T.key - | Key_hash _ -> Michelson.T.key_hash - | Bytes _ -> Michelson.T.bytes - | Chain_id _ -> Michelson.T.chain_id - | Address _ -> Michelson.T.address - | Timestamp _ -> Michelson.T.timestamp - | Bls12_381_g1 _ -> Michelson.T.bls12_381_g1 - | Bls12_381_g2 _ -> Michelson.T.bls12_381_g2 - | Bls12_381_fr _ -> Michelson.T.bls12_381_fr - | Signature _ -> Michelson.T.signature -;; - -let convert_primitive (prim : LLTZ.P.t) : Michelson.Ast.t = - let open Michelson.Ast.Instruction in - match prim with - | Amount -> amount - | Balance -> balance - | Chain_id -> chain_id - | Level -> level - | Now -> now - | Self opt -> self opt - | Self_address -> self_address - | Sender -> sender - | Source -> source - | Total_voting_power -> total_voting_power - | Empty_bigmap (ty1, ty2) -> empty_big_map (convert_type ty1) (convert_type ty2) - | Empty_map (ty1, ty2) -> empty_map (convert_type ty1) (convert_type ty2) - | Empty_set cty -> empty_set (convert_type cty) - | Nil ty -> nil (convert_type ty) - | None ty -> none (convert_type ty) - | Sapling_empty_state { memo } -> sapling_empty_state (Michelson.Ast.int memo) - | Unit -> unit - | Car -> car - | Cdr -> cdr - | Left (opt1, opt2, ty) -> left (convert_type ty) (* TODO: resolve tag options *) - | Right (opt1, opt2, ty) -> right (convert_type ty) (* TODO: resolve tag options *) - | Some -> some - | Eq -> eq - | Abs -> abs - | Neg -> neg - | Nat -> int - | Int -> int - | Bytes -> pack (* Assuming pack handles bytes conversion *) - | Is_nat -> is_nat - | Neq -> neq - | Le -> le - | Lt -> lt - | Ge -> ge - | Gt -> gt - | Not -> not - | Size -> size - | Address -> address - | Implicit_account -> implicit_account - | Is_implicit_account -> is_implicit_account - | Contract (opt, ty) -> contract (convert_type ty) (* TODO: resolve tag option*) - | Pack -> pack - | Unpack ty -> unpack (convert_type ty) - | Hash_key -> hash_key - | Blake2b -> blake2b - | Sha256 -> sha256 - | Sha512 -> sha512 - | Keccak -> keccak - | Sha3 -> sha3 - | Set_delegate -> set_delegate - | Read_ticket -> read_ticket - | Join_tickets -> join_tickets - | Pairing_check -> pairing_check - | Voting_power -> voting_power - | Get_n n -> get_n n - | Cast ty -> cast (convert_type ty) - | Rename opt -> failwith (* TODO: Check why the instruction does not exist. *) - | Emit (opt, ty_opt) -> emit opt (Option.map ~f:convert_type ty_opt) - | Failwith -> failwith - | Never -> never - | Pair (opt1, opt2) -> pair (* TODO: resolve tag options*) - | Add -> add - | Mul -> mul - | Sub -> sub - | Sub_mutez -> sub - | Lsr -> lsr_ - | Lsl -> lsl_ - | Xor -> xor - | Ediv -> ediv - | And -> and_ - | Or -> or_ - | Cons -> cons - | Compare -> compare - | Concat1 -> concat - | Concat2 -> concat - | Get -> get - | Mem -> mem - | Exec -> exec - | Apply -> apply - | Sapling_verify_update -> sapling_verify_update - | Ticket -> ticket - | Ticket_deprecated -> ticket_deprecated - | Split_ticket -> split_ticket - | Update_n n -> update_n n - | View (name, ty) -> view name (convert_type ty) - | Slice -> slice - | Update -> update - | Get_and_update -> get_and_update - | Transfer_tokens -> transfer_tokens - | Check_signature -> check_signature - | Open_chest -> open_chest -;; - -let rec compile : LLTZ.E.t -> t = - fun expr -> - seq - [ (match expr.desc with - | Variable (Var name) -> compile_variable name - | Let_in { let_var = Var var; rhs; in_ } -> compile_let_in var rhs in_ - | Lambda { lam_var = Var var, lam_var_type; body } -> - compile_lambda var lam_var_type body - | Lambda_rec - { mu_var = Var mu, mu_type - ; lambda = { lam_var = Var var, lam_var_type; body } - } -> compile_lambda_rec var lam_var_type mu body - | App { abs; arg } -> compile_app abs arg - | Const constant -> compile_const constant - | Prim (primitive, args) -> compile_prim primitive args - | Let_mut_in { let_var = Mut_var var; rhs; in_ } -> assert false - | Deref (Mut_var var) -> compile_deref var - | Assign (Mut_var var, value) -> compile_assign var value - | If_bool { condition; if_true; if_false } -> - compile_if_bool condition if_true if_false - | If_none - { subject; if_none; if_some = { lam_var = Var var, var_type; body = some } } -> - compile_if_none subject if_none (var, some) - | If_cons - { subject - ; if_empty - ; if_nonempty = - { lam_var1 = Var hd, var1_ty; lam_var2 = Var tl, var2_ty; body = nonempty } - } -> compile_if_cons subject if_empty (hd, tl, nonempty) - | If_left - { subject - ; if_left = { lam_var = Var left, left_ty; body = l } - ; if_right = { lam_var = Var right, right_ty; body = r } - } -> compile_if_left subject (left, l) (right, r) - | While { cond; body } -> compile_while cond body - | While_left { cond; body = { lam_var = Var var, var_ty; body = body_lambda } } -> - compile_while_left cond var body_lambda - | For { index = Mut_var var; init; cond; update; body } -> - compile_for var init cond update body - | For_each { collection; body = { lam_var = Var var, var_ty; body = lambda_body } } - -> compile_for_each collection var lambda_body - | Map { collection; map = { lam_var = Var var, var_ty; body = lam_body } } -> - compile_map collection var lam_body - | Fold_left - { collection - ; init = init_body - ; fold = { lam_var = Var var, var_ty; body = fold_body } - } -> compile_fold_left collection init_body var fold_body - | Fold_right - { collection - ; init = init_body - ; fold = { lam_var = Var var, var_ty; body = fold_body } - } -> compile_fold_right collection init_body var fold_body - | Let_tuple_in { components; rhs; in_ } -> compile_let_tuple_in components rhs in_ - | Tuple row -> compile_tuple row - | Proj (tuple, path) -> compile_proj tuple path - | Update { tuple; component; update } -> compile_update tuple component update - | Inj (path, expr) -> compile_inj path expr - | Match (subject, cases) -> compile_match subject cases - | Raw_michelson node -> assert false - | Create_contract - { storage - ; code = { lam_var = Var param_var, param_ty; body = code_body } - ; delegate - ; initial_balance - ; initial_storage - } -> - compile_create_contract - storage - param_var - param_ty - code_body - delegate - initial_balance - initial_storage - | Global_constant hash -> assert false) - ] - -(* Compile a variable by duplicating its value on the stack. *) -and compile_variable (name : string) = Slot.dup (`Ident name) - -(* Compile a let-in expression by compiling the right-hand side, then binding the result to the variable in the inner expression. *) -and compile_let_in (var : string) (rhs : LLTZ.E.t) (in_ : LLTZ.E.t) = - seq [ compile rhs; Slot.let_ (`Ident var) ~in_:(compile in_) ] - -(* Compile a constant by pushing its value onto the stack. *) -and compile_const constant = - seq [ push (get_const_type constant) (convert_constant constant) ] - -(* Compile a primitive by compiling its arguments, then applying the primitive to the arguments. *) -(* TODO: READ_TICKET, *) -and compile_prim primitive args = - let args_instrs = List.map ~f:compile args in - seq (args_instrs @ [ prim (List.length args) 1 (convert_primitive primitive) ]) - -(* Compile a dereference by duplicating the value of the mutable variable on the stack. *) -and compile_deref (var : string) = Slot.dup (`Ident var) - -(* Compile an assignment by compiling the value to be assigned, then assigning it to the slot corresponding to the mutable variable. *) -and compile_assign (var : string) value = - trace (seq [ trace (compile value); Slot.set (`Ident var) ]) - -(* Compile an if-bool expression by compiling the condition, then applying the if-bool instruction to the condition and the true and false branches. *) -and compile_if_bool condition if_true if_false = - seq [ compile condition; if_ ~then_:(compile if_true) ~else_:(compile if_false) ] - -(* Compile an if-none expression by compiling the subject, then applying the if-none instruction to the subject and the none and some branches. *) -and compile_if_none subject if_none_clause (var, some_clause) = - seq - [ compile subject - ; if_none - ~none:(compile if_none_clause) - ~some:(Slot.let_ (`Ident var) ~in_:(compile some_clause)) - ] - -(* Compile an if-cons expression by compiling the subject, then applying the if-cons instruction to the subject and the empty and nonempty branches. *) -and compile_if_cons subject if_empty (hd, tl, nonempty) = - trace - (seq - [ compile subject - ; if_cons - ~empty:(compile if_empty) - ~nonempty:(Slot.let_all [ `Ident hd; `Ident tl ] ~in_:(compile nonempty)) - ]) - -(* Compile an if-left expression by compiling the subject, then applying the if-left instruction to the subject and the left and right branches. *) -and compile_if_left subject (left, l) (right, r) = - seq - [ compile subject - ; if_left - ~left:(Slot.let_ (`Ident left) ~in_:(compile l)) - ~right:(Slot.let_ (`Ident right) ~in_:(compile r)) - ] - -(* Compile a while expression by compiling the invariant, then applying the loop instruction to the body and invariant. *) -and compile_while invariant body = - seq [ compile invariant; loop (seq [ compile body; compile invariant ]) ] - -(* Compile a while-left expression by compiling the invariant, then applying the loop-left instruction to the body and invariant. *) -and compile_while_left invariant var body_lambda = - seq - [ compile invariant - ; loop_left - (seq [ Slot.let_ (`Ident var) ~in_:(compile body_lambda); compile invariant ]) - ] - -(* Compile a for expression by compiling the initial value, invariant, variant, and body, - then applying the loop to the sequence of body, variant, and invariant. *) -and compile_for index init invariant variant body = - let init_instr = compile init in - let inv_instr = compile invariant in - seq - [ init_instr - ; inv_instr - ; loop - (seq [ Slot.let_ (`Ident index) ~in_:(compile body); compile variant; inv_instr ]) - ; drop 1 (*drop initial value*) - ] - -(* Compile a tuple expression by compiling each component and pairing them together. *) -and compile_tuple row = - match row with - | LLTZ.R.Node nodes -> - let compiled_nodes = List.map ~f:compile_tuple nodes in - seq (compiled_nodes @ [ pair_n (List.length compiled_nodes) ]) - | LLTZ.R.Leaf (_, value) -> compile value - -(* Compile a projection expression by compiling the tuple and then getting the nth element. *) -and compile_proj tuple path = - let _, gets, tuple_expanded_instr = expand_tuple tuple path in - trace - (seq - ([ tuple_expanded_instr ] - @ [ (* Keep the last value, drop the intermediate ones and the tuple *) - trace (dip 1 (drop (List.length gets - 1))) - ])) - -(* Compile an update expression by compiling the tuple row, getting the nth element, compiling the update value, and combining the values back together into tuple. *) -and compile_update tuple component update = - let lengths, gets, tuple_expanded_instr = expand_tuple tuple component in - let updates = - List.rev - (match component with - | LLTZ.R.Path.Here list -> - List.mapi list ~f:(fun i num -> - match List.nth lengths i with - | Some length -> update_n num ~length - | None -> - raise_s - [%message - "compile_update: index out of bounds in updates" - (i : int) - (lengths : int list)])) - in - seq ([ compile tuple ] @ gets @ [ compile update ] @ updates) - -and get_lengths_inner row path_list = - match row with - | LLTZ.R.Node nodes -> - (match path_list with - | hd :: tl -> - (match List.nth nodes hd with - | Some node -> List.length nodes :: get_lengths_inner node tl - | None -> - raise_s - [%message - "get_lengths: index out of bounds" - (hd : int) - (nodes : LLTZ.E.t LLTZ.R.t list)]) - | [] -> []) - | LLTZ.R.Leaf (_, _) -> [ 1 ] - -(* Get the number of children for each node on the path *) -and get_tuple_lengths tuple path = - match LLTZ.E.(tuple.desc), path with - | LLTZ.E.Tuple row, LLTZ.R.Path.Here list -> get_lengths_inner row list - | _ -> raise_s [%message "Tuple expected"] - -(* Expand a tuple expression to a sequence of instructions that get the nth element *) -and expand_tuple tuple path = - let lengths = get_tuple_lengths tuple path in - let gets = - let (LLTZ.R.Path.Here list) = path in - List.mapi list ~f:(fun i num -> - match List.nth lengths i with - | Some length -> get_n num ~length - | None -> raise_s [%message "Index out of bounds" (i : int) (lengths : int list)]) - in - lengths, gets, seq ([ compile tuple ] @ gets) - -(* Compile let-tuple-in expression by compiling the right-hand side with the tuple, then binding the components to the variables in the inner expression. *) -and compile_let_tuple_in components rhs in_ = - let rhs_instr = compile rhs in - let new_env = List.map components ~f:(fun (Var var) -> `Ident var) in - seq - [ rhs_instr - ; unpair_n (List.length components) - ; trace (Slot.let_all new_env ~in_:(compile in_)) - ] - -(* Compile lambda expression by compiling the body and creating a lambda instruction. *) -and compile_lambda var lam_var_type body = - let lam_var = var, convert_type lam_var_type in - let return_type = convert_type body.type_ in - Instruction.seq [ Instruction.lambda ~lam_var ~return_type (compile body) ] - -(* Compile lambda-rec expression by compiling the body and creating a lambda-rec instruction. *) -and compile_lambda_rec var lam_var_type mu body = - let lam_var = var, convert_type lam_var_type in - let return_type = convert_type body.type_ in - Instruction.seq [ Instruction.lambda_rec ~lam_var ~mu ~return_type (compile body) ] - -(* Compile an application by compiling a lambda and argument, then applying the EXEC instruction. *) -and compile_app abs arg = - trace (Instruction.seq [ trace (compile abs); trace (compile arg); exec ]) - -(* Compile contract creation expression by compiling the delegate, initial balance, and initial storage, applying CREATE_CONTRACT instruction. *) -and compile_create_contract - storage - param_var - param_ty - code_body - delegate - initial_balance - initial_storage - = - let storage_ty = convert_type storage in - let param_ty = convert_type param_ty in - let code_instr = seq [ Slot.let_ (`Ident param_var) ~in_:(compile code_body) ] in - seq - [ compile delegate (*TODO possibly needs triple lambda*) - ; compile initial_balance - ; compile initial_storage - ; create_contract ~storage:storage_ty ~parameter:param_ty ~code:(fun stack -> - M.seq (code_instr stack).instructions) - ; pair - ] - -(* Compile for-each expression by compiling the collection, then applying the ITER instruction that iterates over the collection and binds the values to the variables in the body. *) -and compile_for_each collection var body = - let coll_instr = compile collection in - seq [ coll_instr; iter (seq [ Slot.let_ (`Ident var) ~in_:(compile body) ]) ] - -(* Compile map expression by compiling the collection, then applying the MAP instruction that maps over the collection and binds the values to the variables in the function body. *) -and compile_map collection var lam_body = - let coll_instr = compile collection in - seq [ coll_instr; map_ (seq [ Slot.let_ (`Ident var) ~in_:(compile lam_body) ]) ] - -(* Compile fold-left expression by compiling the collection, initial value, and body, then applying the ITER instruction that iterates over the collection and binds the values to the variables in the function body. *) -and compile_fold_left collection init_body var fold_body = - let coll_instr = compile collection in - let init_instr = compile init_body in - seq - [ init_instr - ; coll_instr - ; iter - (seq - [ pair - ; (* Creates pair (acc, val) *) - Slot.let_ (`Ident var) ~in_:(compile fold_body) - ]) - ] - -(* Compile fold-right expression by compiling the collection, initial value, and body, then applying the ITER instruction that iterates over the collection and binds the values to the variables in the function body. *) -and compile_fold_right collection init_body var fold_body = - let coll_instr = compile collection in - let init_instr = compile init_body in - seq - [ init_instr - ; coll_instr - ; (*TODO: reverse the collection - once rest of the code is validated, it is easily done with dsl*) - iter (seq [ pair; Slot.let_ (`Ident var) ~in_:(compile fold_body) ]) - ] - -and compile_inj context expr = - (* Wraps expr into or-type of shape RIGHT(RIGHT(...RIGHT(LEFT(expr)))) *) - match context with - | LLTZ.R.Context.Hole ty -> - let mid_ty = convert_type ty in - seq [ compile expr; left mid_ty ] - | LLTZ.R.Context.Node (left_val, mid, right_val) -> - let right_ty = Type.ors (List.map ~f:compile_row_types_for_or right_val) in - let mid_ty = Type.ors (List.map ~f:compile_row_types_for_or [ mid ]) in - (* Go(fold) through all elements in left part of the context (<- direction) and iteratively merge them - into a larger right-comb or type, record each intermediate merge *) - let right_instrs_types = - List.fold_right - left_val - ~f:(fun x lst -> - match lst with - | hd :: tl -> Type.ors [ compile_row_types_for_or x; hd ] :: hd :: tl - | [] -> raise_s [%message "Empty list"]) - ~init:[ Type.ors [ mid_ty; right_ty ] ] - in - seq - ([ compile expr; left mid_ty ] - (* Rights - traverses all right_instrs_types in reverse order except last and makes right instructions*) - @ - match right_instrs_types with - | hd :: tl -> List.map (List.rev tl) ~f:(fun ty -> right ty) - | [] -> []) - -and compile_row_of_lambdas row = - match row with - | LLTZ.R.Node nodes -> - let compiled_nodes = List.map nodes ~f:compile_row_of_lambdas in - Instruction.seq (compiled_nodes @ [ Instruction.pair_n (List.length compiled_nodes) ]) - | LLTZ.R.Leaf (_, LLTZ.E.{ lam_var = Var var, var_type; body }) -> - compile (LLTZ.Dsl.lambda (Var var, var_type) ~body) - -and compile_match subject cases = - (* Subject is a result of Inj *) - let subject_instr = compile subject in - (* Compile subject, then unwrap it and apply corresponding lambda *) - seq ([ subject_instr ] @ [ compile_matching cases ]) - -and compile_matching cases = - (* Recursively create a decision tree that finds the corresponding lambda*) - match cases with - | LLTZ.R.Node nodes -> - (match nodes with - | hd :: tl -> - seq - [ if_left ~left:(compile_matching hd) ~right:(compile_matching (LLTZ.R.Node tl)) - ] - | [] -> seq []) - | LLTZ.R.Leaf (_, { lam_var = Var var, var_type; body }) -> - seq [ compile (LLTZ.Dsl.lambda (Var var, var_type) ~body); exec ] -;; diff --git a/lib/michelson/optimisations/dune b/lib/lltz_michelson/optimisations/dune similarity index 60% rename from lib/michelson/optimisations/dune rename to lib/lltz_michelson/optimisations/dune index 2b1fa44..19ed038 100644 --- a/lib/michelson/optimisations/dune +++ b/lib/lltz_michelson/optimisations/dune @@ -4,10 +4,10 @@ (libraries core octez-libs.micheline - michelson - lltz.michelson.optimisations.utils - lltz.michelson.optimisations.michelson_base - lltz.michelson.optimisations.oasis_core + lltz.michelson + lltz.michelson.optimisations.smartpy_utils + lltz.michelson.optimisations.smartpy_michelson_base + lltz.michelson.optimisations.smartpy_core ) (preprocess (pps @@ -18,4 +18,4 @@ ppx_deriving.map ppx_deriving.fold ppx_sexp_conv - ppx_yojson_conv))) \ No newline at end of file + ppx_yojson_conv))) diff --git a/lib/michelson/optimisations/if_suffix_rewriter.ml b/lib/lltz_michelson/optimisations/if_suffix_rewriter.ml similarity index 100% rename from lib/michelson/optimisations/if_suffix_rewriter.ml rename to lib/lltz_michelson/optimisations/if_suffix_rewriter.ml diff --git a/lib/michelson/optimisations/rewriter.ml b/lib/lltz_michelson/optimisations/rewriter.ml similarity index 98% rename from lib/michelson/optimisations/rewriter.ml rename to lib/lltz_michelson/optimisations/rewriter.ml index b23f0ed..ecde642 100644 --- a/lib/michelson/optimisations/rewriter.ml +++ b/lib/lltz_michelson/optimisations/rewriter.ml @@ -1,6 +1,6 @@ module Tezos_micheline = Tezos_micheline -module Michelson = Michelson -module Oasis_core = Oasis_core +module Michelson = Lltz_michelson +module Oasis_core = Smartpy_core module If_suffix_rewriter = If_suffix_rewriter open Core diff --git a/lib/michelson/optimisations/oasis_core/dune b/lib/lltz_michelson/optimisations/smartpy_core/dune similarity index 56% rename from lib/michelson/optimisations/oasis_core/dune rename to lib/lltz_michelson/optimisations/smartpy_core/dune index b43eb84..03f8c72 100644 --- a/lib/michelson/optimisations/oasis_core/dune +++ b/lib/lltz_michelson/optimisations/smartpy_core/dune @@ -1,12 +1,12 @@ (library - (name oasis_core) - (public_name lltz.michelson.optimisations.oasis_core) + (name smartpy_core) + (public_name lltz.michelson.optimisations.smartpy_core) (libraries core octez-libs.micheline - michelson - lltz.michelson.optimisations.utils - lltz.michelson.optimisations.michelson_base) + lltz.michelson + lltz.michelson.optimisations.smartpy_utils + lltz.michelson.optimisations.smartpy_michelson_base) (flags (:standard -w -9)) (preprocess diff --git a/lib/michelson/optimisations/oasis_core/micheline.ml b/lib/lltz_michelson/optimisations/smartpy_core/micheline.ml similarity index 100% rename from lib/michelson/optimisations/oasis_core/micheline.ml rename to lib/lltz_michelson/optimisations/smartpy_core/micheline.ml diff --git a/lib/michelson/optimisations/oasis_core/michelson.ml b/lib/lltz_michelson/optimisations/smartpy_core/michelson.ml similarity index 99% rename from lib/michelson/optimisations/oasis_core/michelson.ml rename to lib/lltz_michelson/optimisations/smartpy_core/michelson.ml index 314d066..b2ad733 100644 --- a/lib/michelson/optimisations/oasis_core/michelson.ml +++ b/lib/lltz_michelson/optimisations/smartpy_core/michelson.ml @@ -2,11 +2,11 @@ module Big_int = Big_int module Option = Core.Option module List = Core.List -include Michelson_base.Primitive -include Michelson_base.Typing -include Michelson_base.Type +include Smartpy_michelson_base.Primitive +include Smartpy_michelson_base.Typing +include Smartpy_michelson_base.Type open Printf -open Utils.Control +open Smartpy_utils.Control (*List operations*) let rec map_some f = function @@ -195,7 +195,7 @@ type ('instr, 'literal) literal_f = let sequence_literal_f = let open Result in - let open Utils.Control in + let open Smartpy_utils.Control in function | (Int _ | Bool _ | String _ | Bytes _ | Unit | None_ | Constant _) as l -> Ok l | Pair (x, y) -> map2 (fun x y -> Pair (x, y)) x y @@ -1452,7 +1452,7 @@ let mi_create_contract = let spec_of_prim0 p = let mk name = - let t = Michelson_base.Typing.type_prim0 p in + let t = Smartpy_michelson_base.Typing.type_prim0 p in mk_spec_const name t in match p with @@ -1478,7 +1478,7 @@ let spec_of_prim0 p = let spec_of_prim1 p = let mk name = - let t1, t = Michelson_base.Typing.type_prim1 p in + let t1, t = Smartpy_michelson_base.Typing.type_prim1 p in let f = function | x :: _ when unifiable_types x t1 -> Some [ t ] | _ -> None @@ -1530,7 +1530,7 @@ let spec_of_prim1 p = let spec_of_prim2 p = let mk ?commutative name = - match Michelson_base.Typing.type_prim2 p with + match Smartpy_michelson_base.Typing.type_prim2 p with | [ ((t1, t2), t) ] -> let f = function | x1 :: x2 :: _ when unifiable_types x1 t1 && unifiable_types x2 t2 -> Some [ t ] @@ -1576,7 +1576,7 @@ let spec_of_prim2 p = let spec_of_prim3 p = let mk name = - let t1, t2, t3, t = Michelson_base.Typing.type_prim3 p in + let t1, t2, t3, t = Smartpy_michelson_base.Typing.type_prim3 p in let f = function | x1 :: x2 :: x3 :: _ when unifiable_types x1 t1 && unifiable_types x2 t2 && unifiable_types x3 t3 -> @@ -2628,7 +2628,9 @@ let profile = | MIlambda _ -> return (0, Some 1) | MIlambda_rec _ -> return (0, Some 1) | MIconcat_unresolved -> error "profile: CONCAT arity undetermined" - | MIConstant _ -> assert false (* We don't need to profile constants as in that case has_arity returns false *) + | MIConstant _ -> + assert false + (* We don't need to profile constants as in that case has_arity returns false *) | MIerror _ -> return (0, Some 0) | i -> (match spec_of_instr i with @@ -2640,9 +2642,11 @@ let profile = let has_profile pr instr = Ok pr = profile { instr } -let has_arity a instr = - if is_constant {instr} then false - else - match profile {instr} with +let has_arity a instr = + if is_constant { instr } + then false + else ( + match profile { instr } with | Ok pr -> pr = profile_of_arity a - | Error _ -> false + | Error _ -> false) +;; diff --git a/lib/michelson/optimisations/oasis_core/michelson_rewriter.ml b/lib/lltz_michelson/optimisations/smartpy_core/michelson_rewriter.ml similarity index 97% rename from lib/michelson/optimisations/oasis_core/michelson_rewriter.ml rename to lib/lltz_michelson/optimisations/smartpy_core/michelson_rewriter.ml index 8839998..2360fdd 100644 --- a/lib/michelson/optimisations/oasis_core/michelson_rewriter.ml +++ b/lib/lltz_michelson/optimisations/smartpy_core/michelson_rewriter.ml @@ -2,7 +2,7 @@ (** Michelson-to-michelson code simplification. *) -module Control = Utils.Control +module Control = Smartpy_utils.Control module Big_int = Big_int open Michelson @@ -1043,20 +1043,27 @@ let lltz_specific (expr : instr_list) : (instr_list * instr_list) option = match expr with (*| MIpush (t, l) :: MI1 Some_ :: rest -> [MIpush (mt_option t, MLiteral.some l)] $ rest*) - | MIpush ({mt = MT1 (Option, t)}, {literal = Some_ x}) :: rest -> - [push_instr t x; MI1 Some_] $ rest - | MIpush ({mt = MT1 (Option, t)}, {literal = None_}) :: rest -> - [MI0 (None_ t)] $ rest + | MIpush ({ mt = MT1 (Option, t) }, { literal = Some_ x }) :: rest -> + [ push_instr t x; MI1 Some_ ] $ rest + | MIpush ({ mt = MT1 (Option, t) }, { literal = None_ }) :: rest -> + [ MI0 (None_ t) ] $ rest (* Create list directly using NIL and CONS if it has just one element, instead of PUSH list ... *) - | MIpush ({mt = MT1 (List, t)}, {literal = Seq xs}) :: rest when List.length xs = 1 -> - [MI0 (Nil t)] @ List.concat (List.map ~f:(fun x -> [push_instr t x; MI2 Cons] ) (List.rev xs)) $ rest + | MIpush ({ mt = MT1 (List, t) }, { literal = Seq xs }) :: rest when List.length xs = 1 + -> + [ MI0 (Nil t) ] + @ List.concat (List.map ~f:(fun x -> [ push_instr t x; MI2 Cons ]) (List.rev xs)) + $ rest (* LAMBDA int int { constant "hash..."} -> PUSH (lambda int int) (constant "hash...") *) - | MIlambda ({mt = MT0 Int}, {mt = MT0 Int}, {instr = MIConstant {literal = String hash}}) :: rest -> - [MIpush (mt_lambda mt_int mt_int, MLiteral.constant hash)] $ rest - | MIpush ({mt = MT2 (Or {annot_left; annot_right}, tl, tr)}, {literal = Left x}) :: rest -> - [push_instr tl x; MI1 (Left (annot_left, annot_right, tr))] $ rest - | MIpush ({mt = MT2 (Or {annot_left; annot_right}, tl, tr)}, {literal = Right x}) :: rest -> - [push_instr tr x; MI1 (Right (annot_left, annot_right, tl))] $ rest + | MIlambda + ( { mt = MT0 Int } + , { mt = MT0 Int } + , { instr = MIConstant { literal = String hash } } ) + :: rest -> [ MIpush (mt_lambda mt_int mt_int, MLiteral.constant hash) ] $ rest + | MIpush ({ mt = MT2 (Or { annot_left; annot_right }, tl, tr) }, { literal = Left x }) + :: rest -> [ push_instr tl x; MI1 (Left (annot_left, annot_right, tr)) ] $ rest + | MIpush ({ mt = MT2 (Or { annot_left; annot_right }, tl, tr) }, { literal = Right x }) + :: rest -> + [ push_instr tr x; MI1 (Right (annot_left, annot_right, tl)) ] $ rest (*| MIpush (t2, l2) :: MIpush (t1, l1) :: MI2 (Pair (annot_fst, annot_snd)) diff --git a/lib/michelson/optimisations/michelson_base/dune b/lib/lltz_michelson/optimisations/smartpy_michelson_base/dune similarity index 50% rename from lib/michelson/optimisations/michelson_base/dune rename to lib/lltz_michelson/optimisations/smartpy_michelson_base/dune index 8b6508b..78b90ff 100644 --- a/lib/michelson/optimisations/michelson_base/dune +++ b/lib/lltz_michelson/optimisations/smartpy_michelson_base/dune @@ -1,5 +1,5 @@ (library - (name michelson_base) - (public_name lltz.michelson.optimisations.michelson_base) + (name smartpy_michelson_base) + (public_name lltz.michelson.optimisations.smartpy_michelson_base) (preprocess (pps ppx_deriving.eq ppx_deriving.ord ppx_deriving.show ppx_deriving.map ppx_deriving.fold ppx_sexp_conv ppx_yojson_conv)) - (libraries num sexplib utils)) + (libraries num sexplib smartpy_utils)) diff --git a/lib/michelson/optimisations/michelson_base/primitive.ml b/lib/lltz_michelson/optimisations/smartpy_michelson_base/primitive.ml similarity index 100% rename from lib/michelson/optimisations/michelson_base/primitive.ml rename to lib/lltz_michelson/optimisations/smartpy_michelson_base/primitive.ml diff --git a/lib/michelson/optimisations/michelson_base/primitive.mli b/lib/lltz_michelson/optimisations/smartpy_michelson_base/primitive.mli similarity index 100% rename from lib/michelson/optimisations/michelson_base/primitive.mli rename to lib/lltz_michelson/optimisations/smartpy_michelson_base/primitive.mli diff --git a/lib/michelson/optimisations/michelson_base/type.ml b/lib/lltz_michelson/optimisations/smartpy_michelson_base/type.ml similarity index 100% rename from lib/michelson/optimisations/michelson_base/type.ml rename to lib/lltz_michelson/optimisations/smartpy_michelson_base/type.ml diff --git a/lib/michelson/optimisations/michelson_base/type.mli b/lib/lltz_michelson/optimisations/smartpy_michelson_base/type.mli similarity index 100% rename from lib/michelson/optimisations/michelson_base/type.mli rename to lib/lltz_michelson/optimisations/smartpy_michelson_base/type.mli diff --git a/lib/michelson/optimisations/michelson_base/typing.ml b/lib/lltz_michelson/optimisations/smartpy_michelson_base/typing.ml similarity index 99% rename from lib/michelson/optimisations/michelson_base/typing.ml rename to lib/lltz_michelson/optimisations/smartpy_michelson_base/typing.ml index 7854514..b65d55b 100644 --- a/lib/michelson/optimisations/michelson_base/typing.ml +++ b/lib/lltz_michelson/optimisations/smartpy_michelson_base/typing.ml @@ -14,7 +14,7 @@ let unify_annots pref ?tolerant a b = ;; let rec unify_types ?tolerant t u = - let open Utils.Control in + let open Smartpy_utils.Control in let unify_types = unify_types ?tolerant in let mk { mt; _ } = match diff --git a/lib/michelson/optimisations/michelson_base/typing.mli b/lib/lltz_michelson/optimisations/smartpy_michelson_base/typing.mli similarity index 93% rename from lib/michelson/optimisations/michelson_base/typing.mli rename to lib/lltz_michelson/optimisations/smartpy_michelson_base/typing.mli index 27dde46..c9ccb4c 100644 --- a/lib/michelson/optimisations/michelson_base/typing.mli +++ b/lib/lltz_michelson/optimisations/smartpy_michelson_base/typing.mli @@ -1,5 +1,5 @@ (* Copyright 2022-2023 Morum LLC, 2019-2022 Smart Chain Arena LLC *) -open Utils.Control +open Smartpy_utils.Control open Type open Primitive diff --git a/lib/michelson/optimisations/utils/control.ml b/lib/lltz_michelson/optimisations/smartpy_utils/control.ml similarity index 100% rename from lib/michelson/optimisations/utils/control.ml rename to lib/lltz_michelson/optimisations/smartpy_utils/control.ml diff --git a/lib/michelson/optimisations/utils/control.mli b/lib/lltz_michelson/optimisations/smartpy_utils/control.mli similarity index 100% rename from lib/michelson/optimisations/utils/control.mli rename to lib/lltz_michelson/optimisations/smartpy_utils/control.mli diff --git a/lib/michelson/optimisations/utils/dune b/lib/lltz_michelson/optimisations/smartpy_utils/dune similarity index 76% rename from lib/michelson/optimisations/utils/dune rename to lib/lltz_michelson/optimisations/smartpy_utils/dune index 54dfd80..3a0ac03 100644 --- a/lib/michelson/optimisations/utils/dune +++ b/lib/lltz_michelson/optimisations/smartpy_utils/dune @@ -1,5 +1,5 @@ (library - (name utils) - (public_name lltz.michelson.optimisations.utils) + (name smartpy_utils) + (public_name lltz.michelson.optimisations.smartpy_utils) (preprocess (pps ppx_deriving.eq ppx_deriving.ord ppx_deriving.show ppx_deriving.map ppx_deriving.fold ppx_sexp_conv ppx_compare)) (libraries core zarith digestif.ocaml yojson fmt hex base num unix sexplib cmdliner fmt.tty fmt.cli logs logs.cli logs.fmt)) diff --git a/lltz.opam b/lltz.opam index 0beb9d9..92226dd 100644 --- a/lltz.opam +++ b/lltz.opam @@ -8,11 +8,11 @@ license: "MIT" homepage: "https://github.com/trilitech/lltz" bug-reports: "https://github.com/trilitech/lltz/issues" depends: [ - "ocaml" {= "4.14.2"} - "dune" {>= "3.8"} + "ocaml" {>= "4.14.1"} + "dune" {>= "3.15"} "core" "ppx_jane" - "tezos-micheline" + "octez-libs" "ppxlib" "grace" "odoc" {with-doc} diff --git a/test/README.md b/test/README.md new file mode 100644 index 0000000..ad93afd --- /dev/null +++ b/test/README.md @@ -0,0 +1,35 @@ +# Testing Strategies + +A summary of testing strategies for Ligo and SmartPy as Lltz changes over time. + +## Ligo + +TODO + +## SmartPy + +SmartPy testing consists of unit tests and regression tests (the regressions are referred to as baselines). Whilst the unit test coverage is pretty sparse the baselines' regression coverage is very wide and thorough. + +Baseline testing covers all aspects of the compiler pipeline (parsing, typechecking, compilation and simulation) for local SmartPy installations of native code execution and Javascript code execution via node. The native code regressions also test both the SmartPy simulator and the Octez mockup simulator. These tests are run automatically as part of the SmartPy CI process on every push to the SmartPy code repository. Any changes to the baseline output files are considered an error. + +### SmartPy - output based regression testing + +The intention for SmartPy testing with Lltz would be to add a new set of baselines that run the compiler pipeline but using Lltz to generate the final Michelson code. This can then be run through the SmartPy mockup simulator, which uses Octez to run Michelson code directly. The output of these tests can be compared to the current mockup results by comparing e.g. the serialised contract storage data, simulated gas usage and serialised input parameter values. Intermediate scenario values could also be serialised and compared. + +### SmartPy - can we compare compilation of small expressions directly? + +It may also be possible to compare some round trip small-expression compilations too. We currently have tooling for doing + +SmartPy syntax -> Michelson -> SmartPy Michel (an intermediate language) -> LLTZ + +which could be compared to the direct compilation: + +SmartPy syntax -> LLTZ + +### SmartPy - add to CI + +These approaches would be added to the SmartPy CI and run on every push, then when Lltz gets updated we can + +* update the `opam pin` +* rerun the baselines +* investigate any changes. diff --git a/test/test_all_vars.ml b/test/test_all_vars.ml index a6d2230..162bab0 100644 --- a/test/test_all_vars.ml +++ b/test/test_all_vars.ml @@ -2,10 +2,10 @@ (* This function collects all the variables that appear in the given expression, doesn't matter whether they are used/read or not. *) (* We test it on various expressions to check if it works correctly on all types of LLTZ nodes. *) (* - The concrete syntaxes are written with a OCaml-like syntax. - In LLTZ, we can only copy the value of variables not their reference, - therefore even for mutable variable we don't use 'ref' which is present in OCaml - to simplify the syntax. Assignments are done with the '<-' operator. + The concrete syntaxes are written with a OCaml-like syntax. + In LLTZ, we can only copy the value of variables not their reference, + therefore even for mutable variable we don't use 'ref' which is present in OCaml + to simplify the syntax. Assignments are done with the '<-' operator. *) open Core @@ -14,7 +14,11 @@ module Ast_builder = Lltz_ir.Ast_builder open Lltz_ir.Ast_builder.With_dummy let print_vars expr = - Last_vars.collect_all_vars expr |> Set.to_list |> String.concat ~sep:", " |> print_endline + Last_vars.collect_all_vars expr + |> Set.to_list + |> String.concat ~sep:", " + |> print_endline +;; let v_x_nat = var "x" let v_y_nat = var "y" @@ -36,6 +40,7 @@ let%expect_test "vars simple overshadowing" = [%expect {| z |}] +;; (* let a = 99 in fun (a : nat) -> a + a *) let%expect_test "vars lambda overshadow outer" = @@ -52,10 +57,11 @@ let%expect_test "vars lambda overshadow outer" = [%expect {| a |}] +;; (* let rec fact (n: nat) = - if n <= 1 then 1 else n * fact(n-1) - *) + if n <= 1 then 1 else n * fact(n-1) +*) let%expect_test "vars lambda_rec" = let expr = lambda_rec @@ -76,13 +82,14 @@ let%expect_test "vars lambda_rec" = [%expect {| fact, n |}] +;; (* - let outer = 10 in - let rec f (x : int) = - if x < outer - then f(x+1) - else outer + let outer = 10 in + let rec f (x : int) = + if x < outer + then f(x+1) + else outer *) let%expect_test "vars lambda_rec + outer" = let expr = @@ -106,6 +113,7 @@ let%expect_test "vars lambda_rec + outer" = [%expect {| f, outer, x |}] +;; (* (fun (y : nat) -> let y=99 in y) x *) let%expect_test "vars app overshadow in function" = @@ -119,6 +127,7 @@ let%expect_test "vars app overshadow in function" = [%expect {| x, y |}] +;; (* (fun (t : int) -> t+1) (let t=100 in t) *) let%expect_test "vars app overshadow in argument" = @@ -131,16 +140,18 @@ let%expect_test "vars app overshadow in argument" = [%expect {| t |}] +;; (* 42 *) let%expect_test "vars const int 42" = let expr = int 42 in print_vars expr; [%expect {| |}] +;; (* - let x=5 in - let x=10 in x + let x=5 in + let x=10 in x *) let%expect_test "vars const overshadow in let_in" = let expr = @@ -153,9 +164,10 @@ let%expect_test "vars const overshadow in let_in" = [%expect {| x |}] +;; (* - eq (let z=5 in z) z + eq (let z=5 in z) z *) let%expect_test "vars prim eq overshadow" = let shadow_z = let_in (var "z") ~rhs:(int 5) ~in_:(variable (var "z") int_ty) in @@ -164,9 +176,10 @@ let%expect_test "vars prim eq overshadow" = [%expect {| z |}] +;; (* - add (let a=1 in a) (let a=2 in a) + add (let a=1 in a) (let a=2 in a) *) let%expect_test "vars prim add overshadow in both arguments" = let lhs = let_in (var "a") ~rhs:(nat 1) ~in_:(variable (var "a") nat_ty) in @@ -176,11 +189,12 @@ let%expect_test "vars prim add overshadow in both arguments" = [%expect {| a |}] +;; (* - let_mut m=0 in - let dummy = m <- (m + z) in - m + let_mut m=0 in + let dummy = m <- (m + z) in + m *) let%expect_test "vars let_mut_in deref assign" = let expr = @@ -200,6 +214,7 @@ let%expect_test "vars let_mut_in deref assign" = [%expect {| dummy, m, z |}] +;; (* m *) let%expect_test "vars deref alone free" = @@ -208,9 +223,10 @@ let%expect_test "vars deref alone free" = [%expect {| m |}] +;; (* - let_mut m=10 in m + let_mut m=10 in m *) let%expect_test "vars deref overshadow" = let expr = let_mut_in (mut_var "m") ~rhs:(nat 10) ~in_:(deref (mut_var "m") nat_ty) in @@ -218,9 +234,10 @@ let%expect_test "vars deref overshadow" = [%expect {| m |}] +;; (* - if (let c=5 in c) then (let c=10 in c) else (let c=20 in c) + if (let c=5 in c) then (let c=10 in c) else (let c=20 in c) *) let%expect_test "vars if_bool overshadow in condition" = let cond_expr = let_in (var "c") ~rhs:(int 5) ~in_:(variable (var "c") int_ty) in @@ -231,9 +248,10 @@ let%expect_test "vars if_bool overshadow in condition" = [%expect {| c |}] +;; (* - if condX=1 then thY+2 else elZ-3 + if condX=1 then thY+2 else elZ-3 *) let%expect_test "vars if_bool referencing one free var in cond, different in then, else" = let cond_expr = eq (variable (var "condX") int_ty) (int 1) in @@ -244,11 +262,12 @@ let%expect_test "vars if_bool referencing one free var in cond, different in the [%expect {| condX, elZ, thY |}] +;; (* - match some(5) with - None -> 999 - | Some k -> k + c + match some(5) with + None -> 999 + | Some k -> k + c *) let%expect_test "vars if_none" = let expr = @@ -264,11 +283,12 @@ let%expect_test "vars if_none" = [%expect {| c, k |}] +;; (* - match [] with - [] -> 0 - | hd::hd -> hd + 1 + match [] with + [] -> 0 + | hd::hd -> hd + 1 *) let%expect_test "vars if_cons overshadow in nonempty" = let expr = @@ -285,11 +305,12 @@ let%expect_test "vars if_cons overshadow in nonempty" = [%expect {| hd |}] +;; (* - match Left false with - Left lf -> true - | Right lf -> lf + match Left false with + Left lf -> true + | Right lf -> lf *) let%expect_test "vars if_left overshadow in right" = let left_expr = left (None, None, bool_ty) (bool false) in @@ -303,11 +324,12 @@ let%expect_test "vars if_left overshadow in right" = [%expect {| lf |}] +;; (* - while x=0 do - m <- m + y - done + while x=0 do + m <- m + y + done *) let%expect_test "vars while referencing multiple var" = let expr = @@ -322,10 +344,11 @@ let%expect_test "vars while referencing multiple var" = [%expect {| m, x, y |}] +;; (* - while_left (Left 10) do - let lv=999 in Right(42) + while_left (Left 10) do + let lv=999 in Right(42) *) let%expect_test "vars while_left overshadow var in body" = let expr = @@ -339,10 +362,11 @@ let%expect_test "vars while_left overshadow var in body" = in print_vars expr; [%expect {| lv |}] +;; (* - while_left (Left outerW) do - let v=false in Right(v) + while_left (Left outerW) do + let v=false in Right(v) *) let%expect_test "vars while_left referencing outer var" = let left_cond = left (None, None, bool_ty) (variable (var "outerW") bool_ty) in @@ -360,12 +384,13 @@ let%expect_test "vars while_left referencing outer var" = in print_vars expr; [%expect {| outerW, v |}] +;; (* - for i=0 while i<5 do - x <- i - i <- i+1 - done + for i=0 while i<5 do + x <- i + i <- i+1 + done *) let%expect_test "vars for" = let expr = @@ -380,9 +405,10 @@ let%expect_test "vars for" = [%expect {| i, x |}] +;; (* - for_each [1] (elem -> let elem=999 in elem) + for_each [1] (elem -> let elem=999 in elem) *) let%expect_test "vars for_each overshadow lam_var" = let items = cons (int 1) (nil int_ty) in @@ -398,10 +424,11 @@ let%expect_test "vars for_each overshadow lam_var" = [%expect {| elem |}] +;; (* - let outer="S" in - map ["a"] (v -> v ^ outer) + let outer="S" in + map ["a"] (v -> v ^ outer) *) let%expect_test "vars map referencing outer var inside lam" = let list_expr = cons (string "a") (nil string_ty) in @@ -422,9 +449,10 @@ let%expect_test "vars map referencing outer var inside lam" = [%expect {| outer, v |}] +;; (* - fold_left [1;2] init=0 (pairAcc -> let pairAcc=999 in 100) + fold_left [1;2] init=0 (pairAcc -> let pairAcc=999 in 100) *) let%expect_test "vars fold_left overshadow lam var" = let list_expr = cons (nat 1) (cons (nat 2) (nil nat_ty)) in @@ -442,10 +470,11 @@ let%expect_test "vars fold_left overshadow lam var" = [%expect {| pairAcc |}] +;; (* - let outer_f=10 in - fold_right [1] init=0 do ea -> fst ea + snd ea + outer_f + let outer_f=10 in + fold_right [1] init=0 do ea -> fst ea + snd ea + outer_f *) let%expect_test "vars fold_right with outside ref" = let lst = cons (int 1) (nil int_ty) in @@ -472,9 +501,10 @@ let%expect_test "vars fold_right with outside ref" = [%expect {| ea, outer_f |}] +;; (* - (t, let t=22 in 33) + (t, let t=22 in 33) *) let%expect_test "vars tuple overshadow" = let expr = @@ -488,17 +518,18 @@ let%expect_test "vars tuple overshadow" = [%expect {| t |}] +;; (* - let triple=(alpha,2,3) in triple[0] + let triple=(alpha,2,3) in triple[0] *) let%expect_test "vars proj referencing var" = let triple = tuple (mk_row [ Leaf (None, variable (var "alpha") nat_ty) - ; Leaf (None, nat 2) - ; Leaf (None, nat 3) + ; Leaf (None, nat 2) + ; Leaf (None, nat 3) ]) in let expr = proj triple ~path:(Here [ 0 ]) in @@ -506,9 +537,10 @@ let%expect_test "vars proj referencing var" = [%expect {| alpha |}] +;; (* - update ( (1,2), index=1, let u=10 in u ) + update ( (1,2), index=1, let u=10 in u ) *) let%expect_test "vars update overshadow" = let original = tuple (mk_row [ Leaf (None, int 1); Leaf (None, int 2) ]) in @@ -522,8 +554,9 @@ let%expect_test "vars update overshadow" = [%expect {| u |}] +;; -module MA = Michelson.Ast +module MA = Lltz_michelson.Ast let push_int n = Tezos_micheline.Micheline.Prim @@ -531,9 +564,10 @@ let push_int n = , "PUSH" , [ Tezos_micheline.Micheline.Int (Ast_builder.Dummy_range.v, Z.of_int n) ] , [] ) +;; (* - raw_michelson { PUSH 42 } [ x, let x=10 in 20 ] : int + raw_michelson { PUSH 42 } [ x, let x=10 in 20 ] : int *) let%expect_test "vars raw_michelson overshadow" = let code_ast = @@ -549,15 +583,16 @@ let%expect_test "vars raw_michelson overshadow" = [%expect {| x |}] +;; (* - create_contract - storage=nat - code= fun(args:(nat*nat)) -> - let_tuple (p,s)=args in p + s - delegate=none - initial_balance=1000mutez - initial_storage= let args=5 in 6 + create_contract + storage=nat + code= fun(args:(nat*nat)) -> + let_tuple (p,s)=args in p + s + delegate=none + initial_balance=1000mutez + initial_storage= let args=5 in 6 *) let%expect_test "vars create_contract overshadow binder_var" = let param_storage_ty = mk_tuple_ty [ nat_ty; nat_ty ] in @@ -579,9 +614,10 @@ let%expect_test "vars create_contract overshadow binder_var" = [%expect {| args, p, s |}] +;; (* - global_constant "hashQ" [ let x=1 in 2, x ] : nat + global_constant "hashQ" [ let x=1 in 2, x ] : nat *) let%expect_test "vars global_constant overshadow args" = let expr = @@ -594,12 +630,13 @@ let%expect_test "vars global_constant overshadow args" = [%expect {| x |}] +;; (* - let_mut x=0 in - while_left (Left ( x > 0 )) do - let flg = not flg in - Right ( overshadowZ( x = let overshadowZ=5 in overshadowZ ) ) + let_mut x=0 in + while_left (Left ( x > 0 )) do + let flg = not flg in + Right ( overshadowZ( x = let overshadowZ=5 in overshadowZ ) ) *) let%expect_test "vars combined scenario spot-check" = let cond_expr = left (None, None, bool_ty) (gt (deref (mut_var "x") int_ty) (int 0)) in @@ -625,3 +662,4 @@ let%expect_test "vars combined scenario spot-check" = let expr = let_mut_in (mut_var "x") ~rhs:(int 0) ~in_:while_left_expr in print_vars expr; [%expect {| flg, overshadowZ, x |}] +;; diff --git a/test/test_free_vars.ml b/test/test_free_vars.ml index f29512c..7faed7f 100644 --- a/test/test_free_vars.ml +++ b/test/test_free_vars.ml @@ -1,9 +1,9 @@ -(* In this file, we test the free_vars function that computes the free variables of an expression for each LLTZ node type and interesting cases. +(* In this file, we test the free_vars function that computes the free variables of an expression for each LLTZ node type and interesting cases. - The concrete syntaxes are written with a OCaml-like syntax. - In LLTZ, we can only copy the value of variables not their reference, - therefore even for mutable variable we don't use 'ref' which is present in OCaml - to simplify the syntax. Assignments are done with the '<-' operator. + The concrete syntaxes are written with a OCaml-like syntax. + In LLTZ, we can only copy the value of variables not their reference, + therefore even for mutable variable we don't use 'ref' which is present in OCaml + to simplify the syntax. Assignments are done with the '<-' operator. *) open Core open Lltz_ir.Ast_builder.With_dummy @@ -16,16 +16,15 @@ module Ast_builder = Lltz_ir.Ast_builder let print_map_str_ty map = Map.to_alist map |> List.map ~f:(fun (k, v) -> - Printf.sprintf - "%s : %s" - k - (Sexplib.Sexp.to_string_hum (Lltz_ir.Type.sexp_of_t v))) + Printf.sprintf "%s : %s" k (Sexplib.Sexp.to_string_hum (Lltz_ir.Type.sexp_of_t v))) |> String.concat ~sep:", " +;; let print_free_vars expr = let fv_map = FV.free_vars_with_types expr in print_string (print_map_str_ty fv_map); Format.print_newline () +;; (* let x = 10 in x + (-5) *) let%expect_test "fv simple var + constant (no free vars)" = @@ -35,6 +34,7 @@ let%expect_test "fv simple var + constant (no free vars)" = print_free_vars expr; [%expect {| |}] +;; (* x + 5 *) let%expect_test "fv simple var + constant (one free var)" = @@ -45,6 +45,7 @@ let%expect_test "fv simple var + constant (one free var)" = x : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let z = 5 in let z = 99 in z + z *) let%expect_test "fv overshadowed variable (no free var)" = @@ -61,6 +62,7 @@ let%expect_test "fv overshadowed variable (no free var)" = print_free_vars expr; [%expect {| |}] +;; (* let z = 5 in z + unboundZ *) let%expect_test "fv overshadowed variable (one free var)" = @@ -76,6 +78,7 @@ let%expect_test "fv overshadowed variable (one free var)" = unboundZ : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let a = 10 in fun (x: nat) -> x + a *) let%expect_test "fv lambda capturing outer var (no free var)" = @@ -91,6 +94,7 @@ let%expect_test "fv lambda capturing outer var (no free var)" = print_free_vars expr; [%expect {| |}] +;; (* fun (x: nat) -> x + b *) let%expect_test "fv lambda referencing free var (one free var)" = @@ -105,6 +109,7 @@ let%expect_test "fv lambda referencing free var (one free var)" = b : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let rec fact n = if n <= 1 then 1 else n * fact(n-1) *) let%expect_test "fv lambda_rec no free var" = @@ -126,6 +131,7 @@ let%expect_test "fv lambda_rec no free var" = print_free_vars expr; [%expect {| |}] +;; (* let rec f n = if n <= 0 then outer_val else f(n-1) *) let%expect_test "fv lambda_rec referencing a free var" = @@ -148,27 +154,41 @@ let%expect_test "fv lambda_rec referencing a free var" = outer_val : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let x = (fun y -> y * x) in x *) let%expect_test "fv lambda with outside var overshadowing" = (* let x = (fun y -> y x)*) - let lam_expr = lambda (var "y", nat_ty) ~body:(mul (variable (var "y") nat_ty) (variable (var "x") nat_ty)) in - let let_expr = let_in (var "x") ~rhs:lam_expr ~in_:(variable (var "x") (function_ty nat_ty nat_ty)) in + let lam_expr = + lambda + (var "y", nat_ty) + ~body:(mul (variable (var "y") nat_ty) (variable (var "x") nat_ty)) + in + let let_expr = + let_in (var "x") ~rhs:lam_expr ~in_:(variable (var "x") (function_ty nat_ty nat_ty)) + in print_free_vars let_expr; [%expect {| x : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let x = (fun y -> y) y in x *) let%expect_test "fv app self applied lambda overshadowing" = let lam_expr = lambda (var "y", nat_ty) ~body:(variable (var "y") nat_ty) in - let let_expr = let_in (var "x") ~rhs:(app lam_expr (variable (var "y") nat_ty)) ~in_:(variable (var "x") nat_ty) in + let let_expr = + let_in + (var "x") + ~rhs:(app lam_expr (variable (var "y") nat_ty)) + ~in_:(variable (var "x") nat_ty) + in print_free_vars let_expr; [%expect {| y : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let f = fun (x: nat) -> x+1 in f 42 *) let%expect_test "fv app no free var" = @@ -183,6 +203,7 @@ let%expect_test "fv app no free var" = in print_free_vars expr; [%expect {||}] +;; (* (fun x -> x + glo) 100 *) let%expect_test "fv app with free var in abs" = @@ -198,6 +219,7 @@ let%expect_test "fv app with free var in abs" = glo : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* lam_expr = fun x -> x*2 in lam_expr argFree *) let%expect_test "fv app with free var in arg" = @@ -211,18 +233,21 @@ let%expect_test "fv app with free var in arg" = argFree : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* 42 *) let%expect_test "fv const no free var" = let expr = int 42 in print_free_vars expr; [%expect {||}] +;; (* 1 + 2 *) let%expect_test "fv prim no free var (e.g. Add of 2 constants)" = let expr = add (int 1) (int 2) in print_free_vars expr; [%expect {||}] +;; (* x == 3 *) let%expect_test "fv prim with one free var in arg" = @@ -233,6 +258,7 @@ let%expect_test "fv prim with one free var in arg" = x : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* x + y *) let%expect_test "fv prim with multiple free vars in args" = @@ -244,6 +270,7 @@ let%expect_test "fv prim with multiple free vars in args" = (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))), y : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let mut m=10 in m <- m + 1 *) let%expect_test "fv let_mut_in no free var" = @@ -255,6 +282,7 @@ let%expect_test "fv let_mut_in no free var" = in print_free_vars expr; [%expect {||}] +;; (* let mut mm=1 in mm <- mm + z *) let%expect_test "fv let_mut_in free var in body" = @@ -273,6 +301,7 @@ let%expect_test "fv let_mut_in free var in body" = z : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let mut mm = x in mm *) let%expect_test "fv let_mut_in free var in rhs" = @@ -288,12 +317,14 @@ let%expect_test "fv let_mut_in free var in rhs" = x : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let mut mm=3 in mm *) let%expect_test "fv deref no free var" = let expr = let_mut_in (mut_var "mm") ~rhs:(nat 3) ~in_:(deref (mut_var "mm") nat_ty) in print_free_vars expr; [%expect {||}] +;; (* mm *) let%expect_test "fv deref is free" = @@ -304,6 +335,7 @@ let%expect_test "fv deref is free" = mm : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let mut m=99 in m <- m + x *) let%expect_test "fv mutable var assignment (one free var)" = @@ -322,6 +354,7 @@ let%expect_test "fv mutable var assignment (one free var)" = x : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let outer=2 in let mut m=99 in m <- m + outer *) let%expect_test "fv mutable var assignment no free var" = @@ -341,12 +374,13 @@ let%expect_test "fv mutable var assignment no free var" = print_free_vars expr; [%expect {| |}] +;; -(* let c=999 in - match some(5) - with - None->0 - | Some(k)->k + c *) +(* let c=999 in + match some(5) + with + None->0 + | Some(k)->k + c *) let%expect_test "fv if_none capturing var in some branch (no free var)" = let expr = let_in @@ -364,10 +398,11 @@ let%expect_test "fv if_none capturing var in some branch (no free var)" = print_free_vars expr; [%expect {| |}] +;; -(* match some(5) with - None->0+unb - | Some(k)->999 *) +(* match some(5) with + None->0+unb + | Some(k)->999 *) let%expect_test "fv if_none referencing free var in none branch" = let expr = if_none @@ -381,10 +416,11 @@ let%expect_test "fv if_none referencing free var in none branch" = unb : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; -(* match 2::4::[] with - []->0 - | hd::tl-> hd + some_free_var *) +(* match 2::4::[] with + []->0 + | hd::tl-> hd + some_free_var *) let%expect_test "fv if_cons referencing an unbound var" = let lst = cons (nat 2) (cons (nat 4) (nil nat_ty)) in let expr = @@ -403,10 +439,11 @@ let%expect_test "fv if_cons referencing an unbound var" = some_free_var : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; -(* match [] with - []->999 - | hd::tl-> hd + 1 *) +(* match [] with + []->999 + | hd::tl-> hd + 1 *) let%expect_test "fv if_cons no free var" = let lst = nil nat_ty in let expr = @@ -422,11 +459,12 @@ let%expect_test "fv if_cons no free var" = print_free_vars expr; [%expect {| |}] +;; (* match Left true with - Left flag -> let flag=false in flag + Left flag -> let flag=false in flag | Right x -> false - *) +*) let%expect_test "fv if_left overshadow var (no free var)" = let left_expr = left (None, None, bool_ty) (bool true) in let expr = @@ -442,11 +480,12 @@ let%expect_test "fv if_left overshadow var (no free var)" = print_free_vars expr; [%expect {| |}] +;; (* match Left true with - Left flag -> true + Left flag -> true | Right x -> 0 + unbound_ifleft - *) +*) let%expect_test "fv if_left right branch free var" = let left_expr = left (None, None, bool_ty) (bool true) in let expr = @@ -464,6 +503,7 @@ let%expect_test "fv if_left right branch free var" = unbound_ifleft : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* if x>0 then x+1 else x-1 *) let%expect_test "fv if_bool same free var in both branches" = @@ -480,6 +520,7 @@ let%expect_test "fv if_bool same free var in both branches" = x : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* if true then varA+10 else varB*2 *) let%expect_test "fv if_bool with distinct free vars in each branch" = @@ -497,10 +538,11 @@ let%expect_test "fv if_bool with distinct free vars in each branch" = (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))), varB : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let x=1 in if x=1 then let x=2 in x + outer - else x + outer2 + else x + outer2 *) let%expect_test "fv nested if_bool overshadow" = let expr = @@ -524,11 +566,12 @@ let%expect_test "fv nested if_bool overshadow" = (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))), outer2 : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let mut x=10 in for i from freeVarInit while i < freeCond do - x <- x + (i + freeBody); - i <- i + 1 + x <- x + (i + freeBody); + i <- i + 1 done *) let%expect_test "fv for with multiple free vars" = @@ -558,6 +601,7 @@ let%expect_test "fv for with multiple free vars" = (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))), freeVarInit : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let mut x=0 in for i=1 while i<3 do x<-x+i; i<-i+1 done @@ -579,6 +623,7 @@ let%expect_test "fv for no free vars" = print_free_vars expr; [%expect {| |}] +;; (* let outer=10 in for_each [1;2] do elem-> elem + outer @@ -600,6 +645,7 @@ let%expect_test "fv for_each referencing outer var" = print_free_vars expr; [%expect {| |}] +;; (* for_each [1] do el-> el+unboundFe *) let%expect_test "fv for_each body free var" = @@ -618,6 +664,7 @@ let%expect_test "fv for_each body free var" = unboundFe : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let s="outerS" in map ["a";"b"] (s-> s^s) *) let%expect_test "fv map overshadowing var (no free var)" = @@ -638,6 +685,7 @@ let%expect_test "fv map overshadowing var (no free var)" = print_free_vars expr; [%expect {| |}] +;; (* map [1;2] (n -> n + unboundMap) *) let%expect_test "fv map body free var" = @@ -656,6 +704,7 @@ let%expect_test "fv map body free var" = unboundMap : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* fold_right [1;2] init=0 (fun elem_acc -> (car elem_acc) + (cdr elem_acc) + unbound) *) let%expect_test "fv fold_right referencing an unbound var in fold body" = @@ -687,6 +736,7 @@ let%expect_test "fv fold_right referencing an unbound var in fold body" = unbound : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* fold_right [1] init=0 do (fun pair -> (car pair) + (cdr pair)) *) let%expect_test "fv fold_right no free var" = @@ -707,6 +757,7 @@ let%expect_test "fv fold_right no free var" = print_free_vars expr; [%expect {| |}] +;; (* fold_left [1;2] init=0 do (fun acc_x -> car acc_x + cdr acc_x ) *) let%expect_test "fv fold_left no free var" = @@ -733,6 +784,7 @@ let%expect_test "fv fold_left no free var" = print_free_vars expr; [%expect {| |}] +;; (* fold_left [1;2] init=0 (fun acc_x -> car acc_x + cdr acc_x + freeFold) *) let%expect_test "fv fold_left free var in body" = @@ -758,6 +810,7 @@ let%expect_test "fv fold_left free var in body" = freeFold : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let x=999 in let (x,y,z)=(1,2,3) in x + x *) let%expect_test "fv let_tuple_in overshadow (no free var)" = @@ -777,6 +830,7 @@ let%expect_test "fv let_tuple_in overshadow (no free var)" = print_free_vars expr; [%expect {| |}] +;; (* let (a,b,c)=(10,20,30) in c + notBound *) let%expect_test "fv let_tuple_in body free var" = @@ -795,6 +849,7 @@ let%expect_test "fv let_tuple_in body free var" = notBound : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* ( (1,2,3)[1] ) + outer *) let%expect_test "fv proj referencing free var" = @@ -809,6 +864,7 @@ let%expect_test "fv proj referencing free var" = outer : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let a=10 in let triple=(a,11,12) in triple[1] + 100 *) let%expect_test "fv proj fully bound, no free var" = @@ -829,6 +885,7 @@ let%expect_test "fv proj fully bound, no free var" = print_free_vars expr; [%expect {| |}] +;; (* let big_val=9999 in create_contract param=(nat,nat) code=fun (p,s)-> ([], p + big_val) *) let%expect_test "fv create_contract referencing outer var (no free var leftover)" = @@ -861,6 +918,7 @@ let%expect_test "fv create_contract referencing outer var (no free var leftover) print_free_vars expr; [%expect {| |}] +;; (* create_contract param=(int,nat) code=fun (p,s)-> ([], p + freeU) *) let%expect_test "fv create_contract referencing unbound var in code" = @@ -892,7 +950,7 @@ let%expect_test "fv create_contract referencing unbound var in code" = freeU : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] - +;; let michelson_push_int n = Tezos_micheline.Micheline.Prim @@ -900,6 +958,7 @@ let michelson_push_int n = , "PUSH" , [ Tezos_micheline.Micheline.Int (Ast_builder.Dummy_range.v, Z.of_int n) ] , [] ) +;; (* raw_michelson { PUSH 42 } [] : int *) let%expect_test "fv raw_michelson no arguments" = @@ -910,6 +969,7 @@ let%expect_test "fv raw_michelson no arguments" = print_free_vars expr; [%expect {| |}] +;; (* raw_michelson { PUSH 100 } [freeArg] : int *) let%expect_test "fv raw_michelson single free var in argument" = @@ -923,6 +983,7 @@ let%expect_test "fv raw_michelson single free var in argument" = freeArg : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let x=123 in raw_michelson { PUSH 999 } [x, unboundVar] : int *) let%expect_test "fv raw_michelson mixed arguments" = @@ -945,6 +1006,7 @@ let%expect_test "fv raw_michelson mixed arguments" = unboundVar : ((desc Int) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; (* let a=10, b=20 in raw_michelson { PUSH 1 } [a,b] : int *) let%expect_test "fv raw_michelson all bound arguments" = @@ -968,6 +1030,7 @@ let%expect_test "fv raw_michelson all bound arguments" = print_free_vars expr; [%expect {| |}] +;; (* global_constant "someHash" [10] : int *) let%expect_test "fv global_constant no free var" = @@ -975,6 +1038,7 @@ let%expect_test "fv global_constant no free var" = print_free_vars expr; [%expect {| |}] +;; (* let outer=42 in global_constant "expruHash" [outer] : int *) let%expect_test "fv global_constant referencing outer var" = @@ -987,6 +1051,7 @@ let%expect_test "fv global_constant referencing outer var" = print_free_vars expr; [%expect {| |}] +;; (* global_constant "hashX" [unG, 9] : nat *) let%expect_test "fv global_constant unbound var" = @@ -997,3 +1062,4 @@ let%expect_test "fv global_constant unbound var" = unG : ((desc Nat) (range ((start 0) (stop 0) (source (String ((name ("")) (content ""))))))) |}] +;; diff --git a/test/test_last_vars.ml b/test/test_last_vars.ml index 52cebf7..fbbec31 100644 --- a/test/test_last_vars.ml +++ b/test/test_last_vars.ml @@ -4,7 +4,7 @@ open Core open Lltz_ir open Ast_builder.With_dummy module LV = Lltz_codegen.Last_vars -module Michelson_base = Michelson_base +module Michelson_base = Smartpy_michelson_base let rec print_annotations ?(indent = 0) (e : Expr.t) = let pad = String.make indent ' ' in @@ -226,6 +226,7 @@ let rec print_annotations ?(indent = 0) (e : Expr.t) = Printf.printf "%s var=%s\n" pad v | Expr.Inj _ -> print_intro "Inj (skipped printing details)" | Expr.Match _ -> print_intro "Match (skipped printing details)" +;; let test_and_print title expr = Printf.printf "\n--- %s ---\n" title; @@ -233,14 +234,15 @@ let test_and_print title expr = print_annotations result; Printf.printf "\n"; Test_nodes.test_expr expr +;; (* -------------------------------------------------------------------- *) -(* - let mut x = 100 in - if (x = 100) then - x <- x - 50 - else - x <- x - 10 +(* + let mut x = 100 in + if (x = 100) then + x <- x - 50 + else + x <- x - 10 *) let%expect_test "assign same var multiple branches" = let mut_x = mut_var "x" in @@ -321,15 +323,14 @@ let%expect_test "assign same var multiple branches" = EQ ; IF { PUSH int -50 ; ADD ; DROP } { PUSH int -10 ; ADD ; DROP } ; UNIT } |}] +;; (* - let x = 10 in - x + let x = 10 in + x *) let%expect_test "test_variable" = - let expr = - let_in (var "x") ~rhs:(int 10) ~in_: - (variable (var "x") int_ty) in + let expr = let_in (var "x") ~rhs:(int 10) ~in_:(variable (var "x") int_ty) in test_and_print "test_variable" expr; [%expect {| @@ -349,26 +350,34 @@ let%expect_test "test_variable" = Optimised: { PUSH int 10 } |}] +;; (* - let unused = 10 in - let x = 20 in - let x = 10 in - let x = x + 1 in - x + unused + let unused = 10 in + let x = 20 in + let x = 10 in + let x = x + 1 in + x + unused *) let%expect_test "test_let_in" = let expr = - let_in (var "unused") ~rhs:(int 10) ~in_:( - let_in (var "x") ~rhs:(int 20) ~in_:( - (let_in - (var "x") + let_in + (var "unused") ~rhs:(int 10) ~in_: (let_in (var "x") - ~rhs:(add (variable (var "x") int_ty) (int 1)) - ~in_:(add (variable (var "x") int_ty) (variable (var "unused") int_ty)))))) + ~rhs:(int 20) + ~in_: + (let_in + (var "x") + ~rhs:(int 10) + ~in_: + (let_in + (var "x") + ~rhs:(add (variable (var "x") int_ty) (int 1)) + ~in_: + (add (variable (var "x") int_ty) (variable (var "unused") int_ty))))) in test_and_print "test_let_in" expr; [%expect @@ -434,11 +443,12 @@ let%expect_test "test_let_in" = Optimised: { PUSH int 21 } |}] +;; (* - let varA = 10 in - let varB = 5 in - (varA + varB) + varA + let varA = 10 in + let varB = 5 in + (varA + varB) + varA *) let%expect_test "let_in multiple references no overshadow" = let expr = @@ -492,10 +502,11 @@ let%expect_test "let_in multiple references no overshadow" = Optimised: { PUSH int 10 ; PUSH int 5 ; DUP 2 ; SWAP ; DIG 2 ; ADD ; ADD } |}] +;; (* - let outerVar = 7 in - fun (a:int) -> a + outerVar + let outerVar = 7 in + fun (a:int) -> a + outerVar *) let%expect_test "test_lambda" = let expr = @@ -539,14 +550,15 @@ let%expect_test "test_lambda" = Optimised: { LAMBDA (pair int int) int { UNPAIR ; ADD } ; PUSH int 7 ; APPLY } |}] +;; (* - let y = 99 in - let f = fun (a:int) -> a + y in - let g = fun (a:int) -> - (f (a * 2)) + y - in - g(10) + let y = 99 in + let f = fun (a:int) -> a + y in + let g = fun (a:int) -> + (f (a * 2)) + y + in + g(10) *) let%expect_test "multiple lambdas referencing external vars" = let expr = @@ -675,11 +687,12 @@ let%expect_test "multiple lambdas referencing external vars" = APPLY ; PUSH int 10 ; EXEC } |}] +;; (* - let a = 1 in - let b = 2 in - fun (x:int) -> x + (a + b) + let a = 1 in + let b = 2 in + fun (x:int) -> x + (a + b) *) let%expect_test "lambda referencing multiple distinct outside vars" = let expr = @@ -755,14 +768,15 @@ let%expect_test "lambda referencing multiple distinct outside vars" = APPLY ; SWAP ; APPLY } |}] +;; (* - let outer = 1 in - let rec f (n:int) = - if n > 0 then - f (n - 1) - else - outer + let outer = 1 in + let rec f (n:int) = + if n > 0 then + f (n - 1) + else + outer *) let%expect_test "test_lambda_rec" = let body_expr = @@ -861,12 +875,13 @@ let%expect_test "test_lambda_rec" = IF { DROP ; PUSH int -1 ; ADD ; EXEC } { DUG 2 ; DROP 2 } } ; PUSH int 1 ; APPLY } |}] +;; (* - let unusedArg = 7 in - let z = 10 in - (fun (z:int) -> z + unusedArg) - ( let z = 999 in 5 ) + let unusedArg = 7 in + let z = 10 in + (fun (z:int) -> z + unusedArg) + ( let z = 999 in 5 ) *) let%expect_test "test_app" = let lam = @@ -875,10 +890,12 @@ let%expect_test "test_app" = ~body:(add (variable (var "z") int_ty) (variable (var "unusedArg") int_ty)) in let arg = let_in (var "z") ~rhs:(int 999) ~in_:(int 5) in - let expr = - let_in (var "unusedArg") ~rhs:(int 7) ~in_:( - let_in (var "z") ~rhs:(int 10) ~in_:( - app lam arg)) in + let expr = + let_in + (var "unusedArg") + ~rhs:(int 7) + ~in_:(let_in (var "z") ~rhs:(int 10) ~in_:(app lam arg)) + in test_and_print "test_app" expr; [%expect {| @@ -946,12 +963,13 @@ let%expect_test "test_app" = APPLY ; SWAP ; EXEC } |}] +;; (* - let f = fun (p:(int * int)) -> fst(p) - snd(p) in - let g = f(3) in - let f = 999 in - g(7) + let f = fun (p:(int * int)) -> fst(p) - snd(p) in + let g = f(3) in + let f = 999 in + g(7) *) let%expect_test "partial apply overshadow f/g" = let pair_ty = Ast_builder.With_dummy.mk_tuple_ty [ int_ty; int_ty ] in @@ -1050,14 +1068,15 @@ let%expect_test "partial apply overshadow f/g" = APPLY ; PUSH int 7 ; EXEC } |}] +;; (* - let outerZ = 999 in - let funF = fun (p:(int * int)) -> - fst(p) + snd(p) + outerZ - in - let partial = funF(3) in - partial(7) + let outerZ = 999 in + let funF = fun (p:(int * int)) -> + fst(p) + snd(p) + outerZ + in + let partial = funF(3) in + partial(7) *) let%expect_test "partial apply referencing outer var" = let pair_ty = Ast_builder.With_dummy.mk_tuple_ty [ int_ty; int_ty ] in @@ -1169,19 +1188,20 @@ let%expect_test "partial apply referencing outer var" = APPLY ; PUSH int 7 ; EXEC } |}] +;; (* - let outer = 10 in - let mut x = 0 in - let ignore1 = x <- x + outer in - let f = fun (n:int) -> - let g = fun (z:int) -> - let ignore_g = x <- x + z in - x - in - g(n + outer) - in - f(5) + let outer = 10 in + let mut x = 0 in + let ignore1 = x <- x + outer in + let f = fun (n:int) -> + let g = fun (z:int) -> + let ignore_g = x <- x + z in + x + in + g(n + outer) + in + f(5) *) let%expect_test "mixed let_in, let_mut_in, nested lambdas referencing overshadow" = let mut_x = mut_var "x" in @@ -1385,9 +1405,10 @@ let%expect_test "mixed let_in, let_mut_in, nested lambdas referencing overshadow APPLY ; PUSH int 5 ; EXEC } |}] +;; (* - 42 + 42 *) let%expect_test "test_const" = let expr = int 42 in @@ -1402,19 +1423,22 @@ let%expect_test "test_const" = Optimised: { PUSH int 42 } |}] +;; (* - let x = 20 in - let y = 30 in - (let x = 10 in x) + y + let x = 20 in + let y = 30 in + (let x = 10 in x) + y *) let%expect_test "test_prim_add" = let lhs = let_in (var "x") ~rhs:(int 10) ~in_:(variable (var "x") int_ty) in let rhs = variable (var "y") int_ty in - let expr = - let_in (var "x") ~rhs:(int 20) ~in_:( - let_in (var "y") ~rhs:(int 30) ~in_:( - add lhs rhs)) in + let expr = + let_in + (var "x") + ~rhs:(int 20) + ~in_:(let_in (var "y") ~rhs:(int 30) ~in_:(add lhs rhs)) + in test_and_print "test_prim_add" expr; [%expect {| @@ -1454,11 +1478,12 @@ let%expect_test "test_prim_add" = Optimised: { PUSH int 40 } |}] +;; (* - let mut m = 100 in - let m = 999 in - m <- 1 + let mut m = 100 in + let m = 999 in + m <- 1 *) let%expect_test "test_let_mut_in" = let expr = @@ -1496,28 +1521,32 @@ let%expect_test "test_let_mut_in" = Optimised: { UNIT } |}] +;; (* - let varX = 1 in - let mut varM = 0 in - let temp1 = varM <- (varM + 1) in - let temp2 = varM <- (varM + varX) in - varM + let varX = 1 in + let mut varM = 0 in + let temp1 = varM <- (varM + 1) in + let temp2 = varM <- (varM + varX) in + varM *) let%expect_test "let_mut_in basic multiple assignment" = let mutM = mut_var "varM" in let assign1 = assign mutM (add (deref mutM int_ty) (int 1)) in let assign2 = assign mutM (add (deref mutM int_ty) (variable (var "varX") int_ty)) in let expr = - let_in (var "varX") ~rhs:(int 1) ~in_: - (let_mut_in - mutM - ~rhs:(int 0) + let_in + (var "varX") + ~rhs:(int 1) ~in_: - (let_in - (var "temp1") - ~rhs:assign1 - ~in_:(let_in (var "temp2") ~rhs:assign2 ~in_:(deref mutM int_ty)))) + (let_mut_in + mutM + ~rhs:(int 0) + ~in_: + (let_in + (var "temp1") + ~rhs:assign1 + ~in_:(let_in (var "temp2") ~rhs:assign2 ~in_:(deref mutM int_ty)))) in test_and_print "let_mut_in basic multiple assignment" expr; [%expect @@ -1597,11 +1626,12 @@ let%expect_test "let_mut_in basic multiple assignment" = Optimised: { PUSH int 2 } |}] +;; (* - let mut x = 7 in - let x = 100 in - x + let mut x = 7 in + let x = 100 in + x *) let%expect_test "test_deref" = let expr = @@ -1636,24 +1666,27 @@ let%expect_test "test_deref" = Optimised: { PUSH int 100 } |}] +;; (* - assign referencing overshadow var + unused var: - let unused = 1 in - let mut m = 0 in - m <- (unused + m) + assign referencing overshadow var + unused var: + let unused = 1 in + let mut m = 0 in + m <- (unused + m) *) let%expect_test "test_assign" = let expr = - let_in (var "unused") ~rhs:(int 1) ~in_: - ( - let_mut_in - (mut_var "m") - ~rhs:(int 0) + let_in + (var "unused") + ~rhs:(int 1) ~in_: - (assign + (let_mut_in (mut_var "m") - (add (variable (var "unused") int_ty) (deref (mut_var "m") int_ty)))) + ~rhs:(int 0) + ~in_: + (assign + (mut_var "m") + (add (variable (var "unused") int_ty) (deref (mut_var "m") int_ty)))) in test_and_print "test_assign" expr; [%expect @@ -1691,18 +1724,19 @@ let%expect_test "test_assign" = Optimised: { UNIT } |}] +;; (* - let mut x = 0 in - let ignore1 = x <- ( - let ignore = - let_mut y = 999 in - x <- (y + 1); - in - x - ) in - let ignore2 = x <- (x + 5) in - x + let mut x = 0 in + let ignore1 = x <- ( + let ignore = + let_mut y = 999 in + x <- (y + 1); + in + x + ) in + let ignore2 = x <- (x + 5) in + x *) let%expect_test "nested assigns inside assigns" = let mut_x = mut_var "x" in @@ -1823,23 +1857,29 @@ let%expect_test "nested assigns inside assigns" = Optimised: { PUSH int 1005 } |}] +;; (* - if_bool referencing distinct vars in branches: - let c = false in - let x = 10 in - let y = 20 in - if (c < 10) then x else y + if_bool referencing distinct vars in branches: + let c = false in + let x = 10 in + let y = 20 in + if (c < 10) then x else y *) let%expect_test "test_if_bool" = let cond = lt (variable (var "c") int_ty) (int 10) in let then_ = variable (var "x") int_ty in let else_ = variable (var "y") int_ty in - let expr = - let_in (var "c") ~rhs:(bool false) ~in_: - (let_in (var "x") ~rhs:(int 10) ~in_: - (let_in (var "y") ~rhs:(int 20) ~in_: - (if_bool cond ~then_ ~else_))) in + let expr = + let_in + (var "c") + ~rhs:(bool false) + ~in_: + (let_in + (var "x") + ~rhs:(int 10) + ~in_:(let_in (var "y") ~rhs:(int 20) ~in_:(if_bool cond ~then_ ~else_))) + in test_and_print "test_if_bool" expr; [%expect {| @@ -1906,22 +1946,29 @@ let%expect_test "test_if_bool" = COMPARE ; LT ; IF { DROP } { SWAP ; DROP } } |}] +;; (* - let condVar = 0 in - let thenVar = 10 in - let elseVar = 20 in - if (condVar = 0) then thenVar + 100 else elseVar + 200 + let condVar = 0 in + let thenVar = 10 in + let elseVar = 20 in + if (condVar = 0) then thenVar + 100 else elseVar + 200 *) let%expect_test "if_bool distinct var usage, no overshadow" = let condition = eq (variable (var "condVar") int_ty) (int 0) in let then_ = add (variable (var "thenVar") int_ty) (int 100) in let else_ = add (variable (var "elseVar") int_ty) (int 200) in - let expr = - let_in (var "condVar") ~rhs:(int 0) ~in_: - (let_in (var "thenVar") ~rhs:(int 10) ~in_: - (let_in (var "elseVar") ~rhs:(int 20) ~in_: - (if_bool condition ~then_ ~else_))) in + let expr = + let_in + (var "condVar") + ~rhs:(int 0) + ~in_: + (let_in + (var "thenVar") + ~rhs:(int 10) + ~in_: + (let_in (var "elseVar") ~rhs:(int 20) ~in_:(if_bool condition ~then_ ~else_))) + in test_and_print "if_bool distinct var usage, no overshadow" expr; [%expect {| @@ -1997,18 +2044,19 @@ let%expect_test "if_bool distinct var usage, no overshadow" = DIG 2 ; EQ ; IF { DROP ; PUSH int 100 ; ADD } { SWAP ; DROP ; PUSH int 200 ; ADD } } |}] +;; (* - let x = 1 in - if (x < 10) then - if (x = 5) then - let x = 999 in - x - else - let mut x = 2 in - x <- (x + 100) - else - x + let x = 1 in + if (x < 10) then + if (x = 5) then + let x = 999 in + x + else + let mut x = 2 in + x <- (x + 100) + else + x *) let%expect_test "complex nested if_bool overshadow" = let condition1 = lt (variable (var "x") int_ty) (int 10) in @@ -2126,17 +2174,18 @@ let%expect_test "complex nested if_bool overshadow" = COMPARE ; LT ; IF { PUSH int 5 ; COMPARE ; EQ ; IF { PUSH int 999 } { UNIT } } {} } |}] +;; (* - complicated if_bool + while + deref + overshadow: - let mut counter = 0 in - while (counter < 3) do - if (counter = 1) then - let x = counter in x - else - counter <- (counter + 10) - done; - let x = counter in x + 1 + complicated if_bool + while + deref + overshadow: + let mut counter = 0 in + while (counter < 3) do + if (counter = 1) then + let x = counter in x + else + counter <- (counter + 10) + done; + let x = counter in x + 1 *) let%expect_test "complicated if_bool + while + deref + overshadow" = let mut_counter = mut_var "counter" in @@ -2288,29 +2337,33 @@ let%expect_test "complicated if_bool + while + deref + overshadow" = LT } ; PUSH int 1 ; ADD } |}] +;; (* - if_none overshadow in none branch, overshadow in some: - let maybeVal = 0 in - let outer = 100 in - match maybeVal with - None -> ( let tmpVal = 999 in 1 ) - | Some v -> outer + v + if_none overshadow in none branch, overshadow in some: + let maybeVal = 0 in + let outer = 100 in + match maybeVal with + None -> ( let tmpVal = 999 in 1 ) + | Some v -> outer + v *) let%expect_test "test_if_none" = let subject = variable (var "maybeVal") (option_ty int_ty) in let none_ = let_in (var "tmpVal") ~rhs:(int 999) ~in_:(int 1) in let some_body = add (variable (var "outer") int_ty) (variable (var "v") int_ty) in let expr = - let_in (var "maybeVal") ~rhs:(int 0) ~in_: - (let_in - (var "outer") - ~rhs:(int 100) + let_in + (var "maybeVal") + ~rhs:(int 0) ~in_: - (if_none - subject - ~none:none_ - ~some:{ lam_var = var "v", int_ty; body = some_body })) + (let_in + (var "outer") + ~rhs:(int 100) + ~in_: + (if_none + subject + ~none:none_ + ~some:{ lam_var = var "v", int_ty; body = some_body })) in test_and_print "test_if_none" expr; [%expect @@ -2365,33 +2418,42 @@ let%expect_test "test_if_none" = Optimised: { PUSH int 100 ; PUSH int 0 ; IF_NONE { DROP ; PUSH int 1 } { ADD } } |}] +;; (* - if_cons overshadow lam_var1 lam_var2: - let lst = 0::[] in - let hd = 1 in - let hd2 = 2 in - match lst with - [] -> 999 - | hd::hd2 -> hd + hd2 + if_cons overshadow lam_var1 lam_var2: + let lst = 0::[] in + let hd = 1 in + let hd2 = 2 in + match lst with + [] -> 999 + | hd::hd2 -> hd + hd2 *) let%expect_test "test_if_cons" = let lst = variable (var "lst") (list_ty nat_ty) in let empty_expr = int 999 in let nonempty_body = add (variable (var "hd") nat_ty) (variable (var "hd2") nat_ty) in let expr = - let_in (var "lst") ~rhs:(cons (int 0) (nil nat_ty)) ~in_: - (let_in (var "hd") ~rhs:(int 1) ~in_: - (let_in (var "hd2") ~rhs:(int 2) ~in_: - ( - if_cons - lst - ~empty:empty_expr - ~nonempty: - { lam_var1 = var "hd", nat_ty - ; lam_var2 = var "hd2", list_ty nat_ty - ; body = nonempty_body - }))) + let_in + (var "lst") + ~rhs:(cons (int 0) (nil nat_ty)) + ~in_: + (let_in + (var "hd") + ~rhs:(int 1) + ~in_: + (let_in + (var "hd2") + ~rhs:(int 2) + ~in_: + (if_cons + lst + ~empty:empty_expr + ~nonempty: + { lam_var1 = var "hd", nat_ty + ; lam_var2 = var "hd2", list_ty nat_ty + ; body = nonempty_body + }))) in test_and_print "test_if_cons" expr; [%expect @@ -2457,16 +2519,17 @@ let%expect_test "test_if_cons" = Optimised: { NIL nat ; PUSH nat 0 ; CONS ; IF_CONS { ADD } { PUSH int 999 } } |}] +;; (* - if_left overshadow lam_var in left or right: - let s = Left(0 : nat) in - match s with - Left(l : int) -> - let t = 999 in - l - | Right(r : nat) -> - r + 1 + if_left overshadow lam_var in left or right: + let s = Left(0 : nat) in + match s with + Left(l : int) -> + let t = 999 in + l + | Right(r : nat) -> + r + 1 *) let%expect_test "test_if_left" = let or_val = @@ -2477,11 +2540,14 @@ let%expect_test "test_if_left" = let left_body = let_in (var "t") ~rhs:(int 999) ~in_:(variable (var "l") int_ty) in let right_body = add (variable (var "r") nat_ty) (int 1) in let expr = - let_in (var "s") ~rhs:(left (None, None, nat_ty) (int 0)) ~in_: - (if_left - or_val - ~left:{ lam_var = var "l", int_ty; body = left_body } - ~right:{ lam_var = var "r", nat_ty; body = right_body }) + let_in + (var "s") + ~rhs:(left (None, None, nat_ty) (int 0)) + ~in_: + (if_left + or_val + ~left:{ lam_var = var "l", int_ty; body = left_body } + ~right:{ lam_var = var "r", nat_ty; body = right_body }) in test_and_print "test_if_left" expr; [%expect @@ -2530,14 +2596,15 @@ let%expect_test "test_if_left" = Optimised: { PUSH int 0 ; LEFT nat ; IF_LEFT {} { PUSH int 1 ; ADD } } |}] +;; (* - while referencing overshadow var + nested let_in: - let mut m = 0 in - while (m < 5) do - let q = 123 in - m <- q - done + while referencing overshadow var + nested let_in: + let mut m = 0 in + while (m < 5) do + let q = 123 in + m <- q + done *) let%expect_test "test_while" = let body_expr = @@ -2620,14 +2687,15 @@ let%expect_test "test_while" = LOOP { DROP ; PUSH int 123 ; PUSH int 5 ; DUP 2 ; COMPARE ; LT } ; DROP ; UNIT } |}] +;; (* - let limit = 10 in - let step = 2 in - let mut i = 0 in - while (i < limit) do - i <- i + step - done + let limit = 10 in + let step = 2 in + let mut i = 0 in + while (i < limit) do + i <- i + step + done *) let%expect_test "while referencing outside variables" = let mutI = mut_var "i" in @@ -2635,13 +2703,18 @@ let%expect_test "while referencing outside variables" = let stepVar = variable (var "step") int_ty in let body_expr = assign mutI (add (deref mutI int_ty) stepVar) in let expr = - let_in (var "limit") ~rhs:(int 10) ~in_: - (let_in (var "step") ~rhs:(int 2) ~in_: - ( - let_mut_in - mutI - ~rhs:(int 0) - ~in_:(while_ (lt (deref mutI int_ty) limitVar) ~body:body_expr))) + let_in + (var "limit") + ~rhs:(int 10) + ~in_: + (let_in + (var "step") + ~rhs:(int 2) + ~in_: + (let_mut_in + mutI + ~rhs:(int 0) + ~in_:(while_ (lt (deref mutI int_ty) limitVar) ~body:body_expr))) in test_and_print "while referencing outside variables" expr; [%expect @@ -2734,12 +2807,13 @@ let%expect_test "while referencing outside variables" = LOOP { DUP 2 ; ADD ; DUP 3 ; DUP 2 ; COMPARE ; LT } ; DROP 3 ; UNIT } |}] +;; (* - while_left (Left 10) - (flag : int) -> - let flag = 999 in - Right(123) + while_left (Left 10) + (flag : int) -> + let flag = 999 in + Right(123) *) let%expect_test "test_while_left" = let start_val = left (None, None, int_ty) (int 10) in @@ -2789,19 +2863,19 @@ let%expect_test "test_while_left" = LEFT int ; LEFT int ; LOOP_LEFT { DROP ; PUSH int 123 ; RIGHT int } } |}] +;; (* - for referencing index overshadow body var + outer var: - let mut acc = 0 in - for i from 0 while i<5 do - acc <- i - i <- i+1 - done + for referencing index overshadow body var + outer var: + let mut acc = 0 in + for i from 0 while i<5 do + acc <- i + i <- i+1 + done *) let%expect_test "test_for" = let idx = mut_var "i" in - let body_expr = (assign (mut_var "acc") (variable (var "i") int_ty)) - in + let body_expr = assign (mut_var "acc") (variable (var "i") int_ty) in let expr = let_mut_in (mut_var "acc") @@ -2900,15 +2974,16 @@ let%expect_test "test_for" = LOOP { PUSH int 1 ; ADD ; PUSH int 5 ; DUP 2 ; COMPARE ; LT } ; DROP ; UNIT } |}] +;; (* - let mut i = 0 in - let f = (fun (p : (int,int)) -> fst(p) + snd(p) + i ) in - for i from i while i<4 do - let partial = f(2) in - partial(3) - i <- i+1 - done + let mut i = 0 in + let f = (fun (p : (int,int)) -> fst(p) + snd(p) + i ) in + for i from i while i<4 do + let partial = f(2) in + partial(3) + i <- i+1 + done *) let%expect_test "for_ partial apply overshadow in body" = let idx = mut_var "i" in @@ -3129,14 +3204,15 @@ let%expect_test "for_ partial apply overshadow in body" = LT } ; DROP ; UNIT } |}] +;; (* - for_each overshadow lam_var, referencing outer var: - let outer = 100 in - for_each [1;2] - (elem : int) -> - let elem = 999 in - elem + outer + for_each overshadow lam_var, referencing outer var: + let outer = 100 in + for_each [1;2] + (elem : int) -> + let elem = 999 in + elem + outer *) let%expect_test "test_for_each" = let collection = cons (int 1) (cons (int 2) (nil int_ty)) in @@ -3214,13 +3290,14 @@ let%expect_test "test_for_each" = ITER { DROP ; PUSH int 999 ; DUP 2 ; ADD ; DROP } ; DROP ; UNIT } |}] +;; (* - map overshadow lam_var, referencing outer var - let outer = 10 in - map [1;2] (x : nat) -> - let x=999 in - x + outer + map overshadow lam_var, referencing outer var + let outer = 10 in + map [1;2] (x : nat) -> + let x=999 in + x + outer *) let%expect_test "test_map" = let collection = cons (nat 1) (cons (nat 2) (nil nat_ty)) in @@ -3298,11 +3375,12 @@ let%expect_test "test_map" = MAP { DROP ; PUSH nat 999 ; DUP 2 ; ADD } ; SWAP ; DROP } |}] +;; (* - let x=999 in - map [10;20] (v:int) -> - ( let x=v in x+1 ) + x + let x=999 in + map [10;20] (v:int) -> + ( let x=v in x+1 ) + x *) let%expect_test "map overshadow partial usage" = let list_expr = cons (int 10) (cons (int 20) (nil int_ty)) in @@ -3388,11 +3466,12 @@ let%expect_test "map overshadow partial usage" = MAP { PUSH int 1 ; ADD ; ADD } ; SWAP ; DROP } |}] +;; (* - let factor = 3 in - map [10;20] (item:int) -> - item + item + factor + let factor = 3 in + map [10;20] (item:int) -> + item + item + factor *) let%expect_test "map usage referencing outside var, multiple item usage" = let list_expr = cons (int 10) (cons (int 20) (nil int_ty)) in @@ -3468,14 +3547,15 @@ let%expect_test "map usage referencing outside var, multiple item usage" = MAP { DUP 2 ; DUP 2 ; ADD ; ADD } ; SWAP ; DROP } |}] +;; (* - fold_left overshadow lam_var + referencing init: - fold_left [1;2] - init=0 - (acc:(int*int)) -> - let acc=999 in - fst(acc) + snd(acc) + fold_left overshadow lam_var + referencing init: + fold_left [1;2] + init=0 + (acc:(int*int)) -> + let acc=999 in + fst(acc) + snd(acc) *) let%expect_test "test_fold_left" = let coll = cons (int 1) (cons (int 2) (nil int_ty)) in @@ -3564,13 +3644,14 @@ let%expect_test "test_fold_left" = { PUSH int 0 ; PUSH (list int) { 1 ; 2 } ; ITER { DROP 2 ; PUSH int 999 ; UNPAIR ; ADD } } |}] +;; (* - let outside=7 in - fold_left [1;2;3] init=0 - (acc,x) -> - let x = fst(acc) + outside in - x + x + let outside=7 in + fold_left [1;2;3] init=0 + (acc,x) -> + let x = fst(acc) + outside in + x + x *) let%expect_test "fold_left overshadow inside body" = let coll = cons (int 1) (cons (int 2) (cons (int 3) (nil int_ty))) in @@ -3677,12 +3758,13 @@ let%expect_test "fold_left overshadow inside body" = ITER { SWAP ; PAIR ; DUP 2 ; SWAP ; CAR ; ADD ; DUP ; ADD } ; SWAP ; DROP } |}] +;; (* - let outside=5 in - fold_left [1;2] init=0 - (acc,x) -> - (fst(acc) + outside) + snd(acc) + let outside=5 in + fold_left [1;2] init=0 + (acc,x) -> + (fst(acc) + outside) + snd(acc) *) let%expect_test "fold_left referencing outside var" = let coll = cons (int 1) (cons (int 2) (nil int_ty)) in @@ -3775,15 +3857,16 @@ let%expect_test "fold_left referencing outside var" = ITER { SWAP ; PAIR ; DUP ; CDR ; DUP 3 ; DIG 2 ; CAR ; ADD ; ADD } ; SWAP ; DROP } |}] +;; (* - fold_right overshadow lam_var + referencing outer var: - let unused=666 in - fold_right [1;2] - init=0 - (acc:(int*int)) -> - let acc=999 in - snd(acc) - fst(acc) + fold_right overshadow lam_var + referencing outer var: + let unused=666 in + fold_right [1;2] + init=0 + (acc:(int*int)) -> + let acc=999 in + snd(acc) - fst(acc) *) let%expect_test "test_fold_right" = let coll = cons (int 1) (cons (int 2) (nil int_ty)) in @@ -3881,11 +3964,12 @@ let%expect_test "test_fold_right" = PUSH (list int) { 1 ; 2 } ; ITER { CONS } ; ITER { DROP 2 ; PUSH int 999 ; UNPAIR ; SWAP ; SUB } } |}] +;; (* - let_tuple_in overshadow many components, referencing only some: - let_tuple_in [a,b,a] = (1,2,3) in - a + b + let_tuple_in overshadow many components, referencing only some: + let_tuple_in [a,b,a] = (1,2,3) in + a + b *) let%expect_test "test_let_tuple_in" = let triple = @@ -3941,12 +4025,13 @@ let%expect_test "test_let_tuple_in" = Optimised: { PUSH int 3 ; PUSH int 2 ; PUSH int 1 ; DIG 2 ; DROP ; ADD } |}] +;; (* - let triple = (1,2,3) in - let_tuple_in [a,b,c] = triple in - let unused=999 in - a + b + c + let triple = (1,2,3) in + let_tuple_in [a,b,c] = triple in + let unused=999 in + a + b + c *) let%expect_test "let_tuple_in referencing multiple times, plus an unused" = let triple_expr = @@ -4036,21 +4121,26 @@ let%expect_test "let_tuple_in referencing multiple times, plus an unused" = Optimised: { PUSH int 3 ; PUSH int 2 ; PUSH int 1 ; DUG 2 ; ADD ; ADD } |}] +;; (* - tuple referencing multiple overshadow variables: - let unused=999 in - ( let x=10 in x, - unused ) + tuple referencing multiple overshadow variables: + let unused=999 in + ( let x=10 in x, + unused ) *) let%expect_test "test_tuple" = let expr = - let_in (var "unused") ~rhs:(int 999) ~in_: - (tuple - (Row.Node - [ Row.Leaf (None, let_in (var "x") ~rhs:(int 10) ~in_:(variable (var "x") int_ty)) - ; Row.Leaf (None, variable (var "unused") int_ty) - ])) + let_in + (var "unused") + ~rhs:(int 999) + ~in_: + (tuple + (Row.Node + [ Row.Leaf + (None, let_in (var "x") ~rhs:(int 10) ~in_:(variable (var "x") int_ty)) + ; Row.Leaf (None, variable (var "unused") int_ty) + ])) in test_and_print "test_tuple" expr; [%expect @@ -4085,22 +4175,25 @@ let%expect_test "test_tuple" = Optimised: { PUSH int 999 ; PUSH int 10 ; PAIR } |}] +;; -(* - proj overshadow referencing outer var + partial usage: - let alpha=999 in - (alpha, 999, 123).[0] +(* + proj overshadow referencing outer var + partial usage: + let alpha=999 in + (alpha, 999, 123).[0] *) let%expect_test "test_proj" = let triple = - let_in (var "alpha") ~rhs:(int 999) ~in_: - ( - tuple - (Row.Node - [ Row.Leaf (None, variable (var "alpha") int_ty) - ; Row.Leaf (None, int 999) - ; Row.Leaf (None, int 123) - ])) + let_in + (var "alpha") + ~rhs:(int 999) + ~in_: + (tuple + (Row.Node + [ Row.Leaf (None, variable (var "alpha") int_ty) + ; Row.Leaf (None, int 999) + ; Row.Leaf (None, int 123) + ])) in let expr = proj triple ~path:(Row.Path.Here [ 0 ]) in test_and_print "test_proj" expr; @@ -4133,11 +4226,12 @@ let%expect_test "test_proj" = Optimised: { PUSH int 999 ; PUSH int 123 ; PUSH int 999 ; DIG 2 ; PAIR 3 ; CAR } |}] +;; (* - update overshadow with let_in on update value: - update (10,20) index=1 with - let u=999 in u + update overshadow with let_in on update value: + update (10,20) index=1 with + let u=999 in u *) let%expect_test "test_update" = let pair_expr = tuple (Row.Node [ Row.Leaf (None, int 10); Row.Leaf (None, int 20) ]) in @@ -4181,11 +4275,12 @@ let%expect_test "test_update" = Optimised: { PUSH int 20 ; PUSH int 10 ; PAIR ; PUSH int 999 ; UPDATE 2 } |}] +;; (* - let outsideU=100 in - update (10,20) index=1 with - let tmp=9 in tmp + outsideU + let outsideU=100 in + update (10,20) index=1 with + let tmp=9 in tmp + outsideU *) let%expect_test "update_tuple referencing multiple outside vars in update" = let pair_expr = tuple (Row.Node [ Row.Leaf (None, int 10); Row.Leaf (None, int 20) ]) in @@ -4263,8 +4358,9 @@ let%expect_test "update_tuple referencing multiple outside vars in update" = DIG 2 ; ADD ; UPDATE 2 } |}] +;; -module MA = Michelson.Ast +module MA = Lltz_michelson.Ast let push_int n = Tezos_micheline.Micheline.Prim @@ -4274,9 +4370,10 @@ let push_int n = ; Tezos_micheline.Micheline.Int (Ast_builder.Dummy_range.v, Z.of_int n) ] , [] ) +;; (* - RAW_MICHELSON overshadow in args + RAW_MICHELSON overshadow in args let x=10 in raw_michelson { PUSH int 42 } [ let unusedR=7 in unusedR, @@ -4289,9 +4386,9 @@ let%expect_test "test_raw_michelson" = in let arg1 = let_in (var "unusedR") ~rhs:(int 7) ~in_:(variable (var "unusedR") int_ty) in let arg2 = variable (var "x") int_ty in - let expr = - let_in (var "x") ~rhs:(int 10) ~in_: - (raw_michelson code_ast [ arg1; arg2 ] int_ty) in + let expr = + let_in (var "x") ~rhs:(int 10) ~in_:(raw_michelson code_ast [ arg1; arg2 ] int_ty) + in test_and_print "test_raw_michelson" expr; [%expect {| @@ -4324,9 +4421,10 @@ let%expect_test "test_raw_michelson" = Optimised: { PUSH int 10 ; PUSH int 7 ; PUSH int 42 } |}] +;; (* - raw_michelson { PUSH int 42 } [ + raw_michelson { PUSH int 42 } [ let x=10 in x, let x=999 in x ] : int @@ -4370,23 +4468,24 @@ let%expect_test "raw_michelson overshadow multiple args" = Optimised: { PUSH int 999 ; PUSH int 10 ; PUSH int 42 } |}] +;; (* - CREATE_CONTRACT overshadow code var, referencing multiple unused: - let args=(1,2) in - let bal=100mutez in - let del=None in - let unusedCC="no use" in - create_contract - storage=nat - code = fun(args:(nat*nat)) -> - let (p,s)=args in - p + s - delegate=del - initial_balance=bal - initial_storage= - let args=99 in - 100 + CREATE_CONTRACT overshadow code var, referencing multiple unused: + let args=(1,2) in + let bal=100mutez in + let del=None in + let unusedCC="no use" in + create_contract + storage=nat + code = fun(args:(nat*nat)) -> + let (p,s)=args in + p + s + delegate=del + initial_balance=bal + initial_storage= + let args=99 in + 100 *) let%expect_test "test_create_contract" = let param_storage_ty = mk_tuple_ty [ nat_ty; nat_ty ] in @@ -4397,20 +4496,30 @@ let%expect_test "test_create_contract" = ~in_:(add (variable (var "p") nat_ty) (variable (var "s") nat_ty)) in let expr = - let_in (var "args") ~rhs:(tuple (Row.Node [ Row.Leaf (None, int 1); Row.Leaf (None, int 2) ])) ~in_: - (let_in (var "bal") ~rhs:(mutez 100) ~in_: - (let_in (var "del") ~rhs:(none key_hash_ty) ~in_: - ( let_in - (var "unusedCC") - ~rhs:(string "no use") (* overshadow or never used var *) + (var "args") + ~rhs:(tuple (Row.Node [ Row.Leaf (None, int 1); Row.Leaf (None, int 2) ])) ~in_: - (create_contract - ~storage:nat_ty - ~code:{ lam_var = var "args", param_storage_ty; body = code_body } - ~delegate:(variable (var "del") (option_ty key_hash_ty)) - ~initial_balance:(variable (var "bal") mutez_ty) - ~initial_storage:(let_in (var "args") ~rhs:(nat 99) ~in_:(nat 100)))))) + (let_in + (var "bal") + ~rhs:(mutez 100) + ~in_: + (let_in + (var "del") + ~rhs:(none key_hash_ty) + ~in_: + (let_in + (var "unusedCC") + ~rhs:(string "no use") (* overshadow or never used var *) + ~in_: + (create_contract + ~storage:nat_ty + ~code: + { lam_var = var "args", param_storage_ty; body = code_body } + ~delegate:(variable (var "del") (option_ty key_hash_ty)) + ~initial_balance:(variable (var "bal") mutez_ty) + ~initial_storage: + (let_in (var "args") ~rhs:(nat 99) ~in_:(nat 100)))))) in test_and_print "test_create_contract" expr; [%expect @@ -4520,10 +4629,11 @@ let%expect_test "test_create_contract" = CREATE_CONTRACT { parameter nat ; storage nat ; code { SWAP ; DROP ; UNPAIR ; ADD } } ; PAIR } |}] +;; -(* - GLOBAL_CONSTANT overshadow multiple arguments: - global_constant "SomeGlobalHash" [ +(* + GLOBAL_CONSTANT overshadow multiple arguments: + global_constant "SomeGlobalHash" [ let x=1 in x, let x=99 in x ] : int diff --git a/test/test_michelson_rewrites.ml b/test/test_michelson_rewrites.ml index d36e0cb..4799b2a 100644 --- a/test/test_michelson_rewrites.ml +++ b/test/test_michelson_rewrites.ml @@ -1,552 +1,602 @@ - module Rewriter = Michelson_optimisations.Rewriter module If_suffix_rewriter = Michelson_optimisations.If_suffix_rewriter -open Oasis_core.Michelson +open Smartpy_core.Michelson let oasis_micheline_to_micheline oasis_micheline = let micheline = Rewriter.oasis_micheline_to_micheline oasis_micheline in - let micheline = Tezos_micheline.Micheline.map_node (fun x -> x) (fun prim -> Michelson.Ast.Prim.of_string prim) (If_suffix_rewriter.optimize (Tezos_micheline.Micheline.map_node (fun x -> x) (fun prim -> Michelson.Ast.Prim.to_string prim) micheline)) in + let micheline = + Tezos_micheline.Micheline.map_node + (fun x -> x) + (fun prim -> Lltz_michelson.Ast.Prim.of_string prim) + (If_suffix_rewriter.optimize + (Tezos_micheline.Micheline.map_node + (fun x -> x) + (fun prim -> Lltz_michelson.Ast.Prim.to_string prim) + micheline)) + in micheline +;; -let make_instructions instr = +let make_instructions instr = let micheline = - Oasis_core.Micheline.Sequence ( - Oasis_core.Michelson.To_micheline.instruction ( - {instr = MIseq ( - List.map ~f:(fun i -> {instr = i}) instr - )} - ) - ) in + Smartpy_core.Micheline.Sequence + (Smartpy_core.Michelson.To_micheline.instruction + { instr = MIseq (List.map ~f:(fun i -> { instr = i }) instr) }) + in micheline +;; let test_instructions instructions = let oasis_micheline = make_instructions instructions in - - let code = Oasis_core.Michelson.Of_micheline.instruction oasis_micheline in - let optimised_code = Oasis_core.Michelson_rewriter.run (Oasis_core.Michelson_rewriter.simplify) code in - let oasis_micheline_list = Oasis_core.Michelson.To_micheline.instruction optimised_code in - let optimised_oasis_micheline = Oasis_core.Micheline.Sequence (oasis_micheline_list) in - - Test_nodes.print_instructions [oasis_micheline_to_micheline oasis_micheline]; + let code = Smartpy_core.Michelson.Of_micheline.instruction oasis_micheline in + let optimised_code = + Smartpy_core.Michelson_rewriter.run Smartpy_core.Michelson_rewriter.simplify code + in + let oasis_micheline_list = + Smartpy_core.Michelson.To_micheline.instruction optimised_code + in + let optimised_oasis_micheline = Smartpy_core.Micheline.Sequence oasis_micheline_list in + Test_nodes.print_instructions [ oasis_micheline_to_micheline oasis_micheline ]; Printf.printf "->\n"; - Test_nodes.print_instructions [oasis_micheline_to_micheline optimised_oasis_micheline]; - + Test_nodes.print_instructions [ oasis_micheline_to_micheline optimised_oasis_micheline ]; (* Check if second pass differs from first pass. If it does, print it. *) - let second_optimised_code = Oasis_core.Michelson_rewriter.run (Oasis_core.Michelson_rewriter.simplify) optimised_code in - let second_optimised_micheline_list = Oasis_core.Michelson.To_micheline.instruction second_optimised_code in - let second_optimised_oasis_micheline = Oasis_core.Micheline.Sequence second_optimised_micheline_list in - - if second_optimised_oasis_micheline <> optimised_oasis_micheline then begin + let second_optimised_code = + Smartpy_core.Michelson_rewriter.run + Smartpy_core.Michelson_rewriter.simplify + optimised_code + in + let second_optimised_micheline_list = + Smartpy_core.Michelson.To_micheline.instruction second_optimised_code + in + let second_optimised_oasis_micheline = + Smartpy_core.Micheline.Sequence second_optimised_micheline_list + in + if second_optimised_oasis_micheline <> optimised_oasis_micheline + then ( Printf.printf "Further optimisations were possible:\n"; - Test_nodes.print_instructions [oasis_micheline_to_micheline optimised_oasis_micheline]; + Test_nodes.print_instructions + [ oasis_micheline_to_micheline optimised_oasis_micheline ]; Printf.printf "->\n"; - Test_nodes.print_instructions [oasis_micheline_to_micheline second_optimised_oasis_micheline] - end + Test_nodes.print_instructions + [ oasis_micheline_to_micheline second_optimised_oasis_micheline ]) +;; let%expect_test "print_expr" = - test_instructions [MIdup 1; MIdig 0; MIdup 1]; + test_instructions [ MIdup 1; MIdig 0; MIdup 1 ]; [%expect {| { DUP ; DIG 0 ; DUP } -> { DUP ; DUP } |}] +;; let test = test_instructions (* instr_to_push *) let%expect_test "instr_to_push_unit" = - test [MI0 Unit_]; + test [ MI0 Unit_ ]; [%expect {| { UNIT } -> { UNIT } |}] +;; let%expect_test "instr_to_push_none" = - test [MI0 (None_ mt_nat)]; + test [ MI0 (None_ mt_nat) ]; [%expect {| { NONE nat } -> { NONE nat } |}] +;; let%expect_test "instr_to_push_nil" = - test [MI0 (Nil mt_string)]; + test [ MI0 (Nil mt_string) ]; [%expect {| { NIL string } -> { NIL string } |}] +;; let%expect_test "instr_to_push_empty_set" = - test [MI0 (Empty_set mt_bytes)]; + test [ MI0 (Empty_set mt_bytes) ]; [%expect {| { EMPTY_SET bytes } -> { EMPTY_SET bytes } |}] +;; let%expect_test "instr_to_push_empty_map" = - test [MI0 (Empty_map (mt_string, mt_int))]; + test [ MI0 (Empty_map (mt_string, mt_int)) ]; [%expect {| { EMPTY_MAP string int } -> { EMPTY_MAP string int } |}] +;; (* push_to_instr *) let%expect_test "push_to_instr_unit" = - test [MIpush (mt_unit, MLiteral.unit)]; + test [ MIpush (mt_unit, MLiteral.unit) ]; [%expect {| { PUSH unit Unit } -> { UNIT } |}] +;; let%expect_test "push_to_instr_none" = - test [MIpush (mt_option mt_nat, MLiteral.none)]; + test [ MIpush (mt_option mt_nat, MLiteral.none) ]; [%expect {| { PUSH (option nat) None } -> { NONE nat } |}] +;; let%expect_test "push_to_instr_nil" = - test [MIpush (mt_list mt_string, MLiteral.list [])]; + test [ MIpush (mt_list mt_string, MLiteral.list []) ]; [%expect {| { PUSH (list string) {} } -> { NIL string } |}] +;; let%expect_test "push_to_instr_empty_set" = - test [MIpush (mt_set mt_bytes, MLiteral.set [])]; + test [ MIpush (mt_set mt_bytes, MLiteral.set []) ]; [%expect {| { PUSH (set bytes) {} } -> { EMPTY_SET bytes } |}] +;; let%expect_test "push_to_instr_empty_map" = - test [MIpush (mt_map mt_string mt_int, MLiteral.mk_map [])]; + test [ MIpush (mt_map mt_string mt_int, MLiteral.mk_map []) ]; [%expect {| { PUSH (map string int) {} } -> { PUSH (map string int) {} } |}] +;; (* unfold_macros *) let%expect_test "unfold_macros_setfield_a" = - test [MIsetField [A]]; + test [ MIsetField [ A ] ]; [%expect {| { CDR ; SWAP ; PAIR } -> { CDR ; SWAP ; PAIR } |}] +;; let%expect_test "unfold_macros_setfield_d" = - test [MIsetField [D]]; + test [ MIsetField [ D ] ]; [%expect {| { CAR ; PAIR } -> { CAR ; PAIR } |}] +;; let%expect_test "unfold_macros_setfield_complex" = - test [MIsetField [A; D]]; - [%expect {| + test [ MIsetField [ A; D ] ]; + [%expect + {| { DUP ; DIP { CAR ; CAR ; PAIR } ; CDR ; SWAP ; PAIR } -> { DUP ; DIP { CAR ; CAR ; PAIR } ; CDR ; SWAP ; PAIR } |}] +;; let%expect_test "unfold_macros_pairn_2" = - test [MIpairn 2]; + test [ MIpairn 2 ]; [%expect {| { PAIR 2 } -> { PAIR } |}] +;; (* unfold_mifield *) let%expect_test "unfold_mifield_simple" = - test [MIfield [D; A]]; + test [ MIfield [ D; A ] ]; [%expect {| { CDR ; CAR } -> { GET 3 } |}] +;; let%expect_test "unfold_mifield_getn_1" = - test [MI1 (Getn 1)]; + test [ MI1 (Getn 1) ]; [%expect {| { GET 1 } -> { CAR } |}] +;; let%expect_test "unfold_mifield_getn_2" = - test [MI1 (Getn 2)]; + test [ MI1 (Getn 2) ]; [%expect {| { GET 2 } -> { CDR } |}] +;; (* unfold_selective_unpair *) let%expect_test "unfold_selective_unpair_true_false" = - test [MIunpair [true; true]]; - [%expect{| + test [ MIunpair [ true; true ] ]; + [%expect {| { UNPAIR } -> { UNPAIR } |}] +;; let%expect_test "unfold_selective_unpair_many" = -test [MIunpair [true; true;]; MIdropn 1]; -[%expect{| + test [ MIunpair [ true; true ]; MIdropn 1 ]; + [%expect {| { UNPAIR ; DROP 1 } -> { CDR } |}] +;; let%expect_test "unfold_selective_unpair_many" = - test [MIunpair [true; true; true]; MIdropn 1]; - [%expect{| + test [ MIunpair [ true; true; true ]; MIdropn 1 ]; + [%expect {| { UNPAIR 3 ; DROP 1 } -> { CDR ; UNPAIR } |}] +;; let%expect_test "fold_getn_d_a" = - test [MIfield [D]; MIfield [A]]; + test [ MIfield [ D ]; MIfield [ A ] ]; [%expect {| { CDR ; CAR } -> { GET 3 } |}] +;; let%expect_test "fold_getn_d_d" = - test [MIfield [D]; MIfield [D]]; + test [ MIfield [ D ]; MIfield [ D ] ]; [%expect {| { CDR ; CDR } -> { GET 4 } |}] +;; let%expect_test "fold_getn_d_then_getn" = - test [MIfield [D]; MI1 (Getn 5)]; + test [ MIfield [ D ]; MI1 (Getn 5) ]; [%expect {| { CDR ; GET 5 } -> { GET 7 } |}] +;; let%expect_test "fold_getn_getn_even" = - test [MI1 (Getn 4); MI1 (Getn 2)]; + test [ MI1 (Getn 4); MI1 (Getn 2) ]; [%expect {| { GET 4 ; GET 2 } -> { GET 4 ; CDR } |}] +;; (* fold_dropn *) let%expect_test "fold_dropn_simple" = - test [MIdrop; MIdrop]; + test [ MIdrop; MIdrop ]; [%expect {| { DROP ; DROP } -> { DROP 2 } |}] +;; let%expect_test "fold_dropn_drop_dropn" = - test [MIdrop; MIdropn 3]; + test [ MIdrop; MIdropn 3 ]; [%expect {| { DROP ; DROP 3 } -> { DROP 4 } |}] +;; let%expect_test "fold_dropn_dropn_drop" = - test [MIdropn 2; MIdrop]; + test [ MIdropn 2; MIdrop ]; [%expect {| { DROP 2 ; DROP } -> { DROP 3 } |}] +;; let%expect_test "fold_dropn_dropn_dropn" = - test [MIdropn 2; MIdropn 3]; + test [ MIdropn 2; MIdropn 3 ]; [%expect {| { DROP 2 ; DROP 3 } -> { DROP 5 } |}] +;; (* unfold_dropn *) let%expect_test "unfold_dropn_1" = - test [MIdropn 1]; + test [ MIdropn 1 ]; [%expect {| { DROP 1 } -> { DROP } |}] +;; let%expect_test "unfold_dropn_many" = - test [MIdropn 3]; + test [ MIdropn 3 ]; [%expect {| { DROP 3 } -> { DROP 3 } |}] +;; (* push_push *) let%expect_test "push_push_same_literal" = - test - [ MIpush (mt_nat, MLiteral.small_int 42) - ; MIpush (mt_nat, MLiteral.small_int 42) - ]; + test [ MIpush (mt_nat, MLiteral.small_int 42); MIpush (mt_nat, MLiteral.small_int 42) ]; [%expect {| { PUSH nat 42 ; PUSH nat 42 } -> { PUSH nat 42 ; DUP } |}] +;; let%expect_test "push_push_different_literal" = test [ MIpush (mt_string, MLiteral.string "foo") ; MIpush (mt_string, MLiteral.string "bar") ]; - [%expect {| + [%expect + {| { PUSH string "foo" ; PUSH string "bar" } -> { PUSH string "foo" ; PUSH string "bar" } |}] +;; (* push_zero_compare *) let%expect_test "push_zero_compare_nat_eq" = - test - [ MIpush (mt_nat, MLiteral.small_int 0) - ; MIdig 1 - ; MI2 Compare - ; MI1 Eq - ]; - [%expect {| + test [ MIpush (mt_nat, MLiteral.small_int 0); MIdig 1; MI2 Compare; MI1 Eq ]; + [%expect + {| { PUSH nat 0 ; DIG 1 ; COMPARE ; EQ } -> { PUSH nat 0 ; COMPARE ; EQ } |}] +;; let%expect_test "push_zero_compare_int_ge" = - test - [ MIpush (mt_int, MLiteral.small_int 0) - ; MIdup 2 - ; MI2 Compare - ; MI1 Ge - ]; + test [ MIpush (mt_int, MLiteral.small_int 0); MIdup 2; MI2 Compare; MI1 Ge ]; [%expect {| { PUSH int 0 ; DUP 2 ; COMPARE ; GE } -> { DUP ; GE } |}] +;; (* dig1_to_swap *) let%expect_test "dig1_to_swap" = - test [MIdig 1]; + test [ MIdig 1 ]; [%expect {| { DIG 1 } -> { SWAP } |}] +;; (* swap_to_dig1 *) let%expect_test "swap_to_dig1" = - test [MIswap]; + test [ MIswap ]; [%expect {| { SWAP } -> { SWAP } |}] +;; let mk_instr instr = { instr } let%expect_test "cond_check_last_same_push_if" = - test [ - MIif ( - { instr = MIseq [ - mk_instr (MIdig 2); - mk_instr (MIpush (mt_int, MLiteral.small_int 42)); - ]}, - { instr = MIseq [ - mk_instr (MIdig 1); - mk_instr (MIpush (mt_int, MLiteral.small_int 42)); - ]} - ) - ]; - [%expect {| + test + [ MIif + ( { instr = + MIseq + [ mk_instr (MIdig 2); mk_instr (MIpush (mt_int, MLiteral.small_int 42)) ] + } + , { instr = + MIseq + [ mk_instr (MIdig 1); mk_instr (MIpush (mt_int, MLiteral.small_int 42)) ] + } ) + ]; + [%expect + {| { IF { DIG 2 ; PUSH int 42 } { DIG 1 ; PUSH int 42 } } -> { IF { DIG 2 } { SWAP } ; PUSH int 42 } |}] +;; let%expect_test "cond_check_last_push_fail_if" = - test [ - MIif ( - { instr = MIseq [ - mk_instr (MIdup 1); - mk_instr (MIpush (mt_string, MLiteral.string "failed")); - ]}, - { instr = MIseq [ - mk_instr (MI1_fail Failwith) - ]} - ) - ]; - [%expect {| + test + [ MIif + ( { instr = + MIseq + [ mk_instr (MIdup 1) + ; mk_instr (MIpush (mt_string, MLiteral.string "failed")) + ] + } + , { instr = MIseq [ mk_instr (MI1_fail Failwith) ] } ) + ]; + [%expect + {| { IF { DUP ; PUSH string "failed" } { FAILWITH } } -> { IF { DUP } { FAILWITH } ; PUSH string "failed" } |}] +;; let%expect_test "cond_check_last_fail_push_if" = - test [ - MIif ( - { instr = MIseq [ - mk_instr (MI1_fail Failwith) - ]}, - { instr = MIseq [ - mk_instr (MIdig 2); - mk_instr (MIpush (mt_nat, MLiteral.small_int 123)); - ]} - ) - ]; - [%expect {| + test + [ MIif + ( { instr = MIseq [ mk_instr (MI1_fail Failwith) ] } + , { instr = + MIseq + [ mk_instr (MIdig 2); mk_instr (MIpush (mt_nat, MLiteral.small_int 123)) ] + } ) + ]; + [%expect + {| { IF { FAILWITH } { DIG 2 ; PUSH nat 123 } } -> { IF { FAILWITH } { DIG 2 } ; PUSH nat 123 } |}] +;; let%expect_test "cond_check_last_same_push_if_none" = - test [ - MIif_none ( - { instr = MIseq [ - mk_instr (MIdig 3); - mk_instr (MIpush (mt_int, MLiteral.small_int 99)); - ]}, - { instr = MIseq [ - mk_instr (MIdig 1); - mk_instr (MIpush (mt_int, MLiteral.small_int 99)); - ]} - ) - ]; - [%expect {| + test + [ MIif_none + ( { instr = + MIseq + [ mk_instr (MIdig 3); mk_instr (MIpush (mt_int, MLiteral.small_int 99)) ] + } + , { instr = + MIseq + [ mk_instr (MIdig 1); mk_instr (MIpush (mt_int, MLiteral.small_int 99)) ] + } ) + ]; + [%expect + {| { IF_NONE { DIG 3 ; PUSH int 99 } { DIG 1 ; PUSH int 99 } } -> { IF_NONE { DIG 3 } { SWAP } ; PUSH int 99 } |}] +;; let%expect_test "cond_check_last_push_fail_if_none" = - test [ - MIif_none ( - { instr = MIseq [ - mk_instr (MIdrop); - mk_instr (MIpush (mt_string, MLiteral.string "if-none case")); - ]}, - { instr = MIseq [ - mk_instr (MI1_fail Failwith) - ]} - ) - ]; - [%expect {| + test + [ MIif_none + ( { instr = + MIseq + [ mk_instr MIdrop + ; mk_instr (MIpush (mt_string, MLiteral.string "if-none case")) + ] + } + , { instr = MIseq [ mk_instr (MI1_fail Failwith) ] } ) + ]; + [%expect + {| { IF_NONE { DROP ; PUSH string "if-none case" } { FAILWITH } } -> { IF_NONE { DROP } { FAILWITH } ; PUSH string "if-none case" } |}] +;; let%expect_test "cond_check_last_fail_push_if_none" = - test [ - MIif_none ( - { instr = MIseq [ - mk_instr (MI1_fail Failwith) - ]}, - { instr = MIseq [ - mk_instr (MIdup 1); - mk_instr (MIpush (mt_unit, MLiteral.unit)); - ]} - ) - ]; - [%expect {| + test + [ MIif_none + ( { instr = MIseq [ mk_instr (MI1_fail Failwith) ] } + , { instr = + MIseq [ mk_instr (MIdup 1); mk_instr (MIpush (mt_unit, MLiteral.unit)) ] + } ) + ]; + [%expect + {| { IF_NONE { FAILWITH } { DUP ; PUSH unit Unit } } -> { IF_NONE { FAILWITH } { DUP } ; UNIT } |}] +;; let%expect_test "cond_check_last_same_push_if_left" = - test [ - MIif_left ( - { instr = MIseq [ - mk_instr (MIdrop); - mk_instr (MIpush (mt_bool, MLiteral.bool true)); - ]}, - { instr = MIseq [ - mk_instr (MIdup 1); - mk_instr (MIpush (mt_bool, MLiteral.bool true)); - ]} - ) - ]; - [%expect {| + test + [ MIif_left + ( { instr = + MIseq [ mk_instr MIdrop; mk_instr (MIpush (mt_bool, MLiteral.bool true)) ] + } + , { instr = + MIseq + [ mk_instr (MIdup 1); mk_instr (MIpush (mt_bool, MLiteral.bool true)) ] + } ) + ]; + [%expect + {| { IF_LEFT { DROP ; PUSH bool True } { DUP ; PUSH bool True } } -> { IF_LEFT { DROP } { DUP } ; PUSH bool True } |}] +;; let%expect_test "cond_check_last_push_fail_if_left" = - test [ - MIif_left ( - { instr = MIseq [ - mk_instr (MIdig 2); - mk_instr (MIpush (mt_string, MLiteral.string "left")); - ]}, - { instr = MIseq [ - mk_instr (MI1_fail Failwith) - ]} - ) - ]; - [%expect {| + test + [ MIif_left + ( { instr = + MIseq + [ mk_instr (MIdig 2) + ; mk_instr (MIpush (mt_string, MLiteral.string "left")) + ] + } + , { instr = MIseq [ mk_instr (MI1_fail Failwith) ] } ) + ]; + [%expect + {| { IF_LEFT { DIG 2 ; PUSH string "left" } { FAILWITH } } -> { IF_LEFT { DIG 2 } { FAILWITH } ; PUSH string "left" } |}] +;; let%expect_test "cond_check_last_fail_push_if_left" = - test [ - MIif_left ( - { instr = MIseq [ - mk_instr (MI1_fail Failwith) - ]}, - { instr = MIseq [ - mk_instr (MIdig 3); - mk_instr (MIpush (mt_nat, MLiteral.small_int 7)); - ]} - ) - ]; - [%expect {| + test + [ MIif_left + ( { instr = MIseq [ mk_instr (MI1_fail Failwith) ] } + , { instr = + MIseq + [ mk_instr (MIdig 3); mk_instr (MIpush (mt_nat, MLiteral.small_int 7)) ] + } ) + ]; + [%expect + {| { IF_LEFT { FAILWITH } { DIG 3 ; PUSH nat 7 } } -> { IF_LEFT { FAILWITH } { DIG 3 } ; PUSH nat 7 } |}] +;; let%expect_test "cond_check_last_same_push_if_cons" = - test [ - MIif_cons ( - { instr = MIseq [ - mk_instr (MIdup 2); - mk_instr (MIpush (mt_string, MLiteral.string "cons-branch")); - ]}, - { instr = MIseq [ - mk_instr (MIdig 1); - mk_instr (MIpush (mt_string, MLiteral.string "cons-branch")); - ]} - ) - ]; - [%expect {| + test + [ MIif_cons + ( { instr = + MIseq + [ mk_instr (MIdup 2) + ; mk_instr (MIpush (mt_string, MLiteral.string "cons-branch")) + ] + } + , { instr = + MIseq + [ mk_instr (MIdig 1) + ; mk_instr (MIpush (mt_string, MLiteral.string "cons-branch")) + ] + } ) + ]; + [%expect + {| { IF_CONS { DUP 2 ; PUSH string "cons-branch" } { DIG 1 ; PUSH string "cons-branch" } } -> { IF_CONS { DUP 2 } { SWAP } ; PUSH string "cons-branch" } |}] +;; let%expect_test "cond_check_last_push_fail_if_cons" = - test [ - MIif_cons ( - { instr = MIseq [ - mk_instr (MIdig 4); - mk_instr (MIpush (mt_int, MLiteral.small_int 2023)); - ]}, - { instr = MIseq [ - mk_instr (MI1_fail Failwith) - ]} - ) - ]; - [%expect {| + test + [ MIif_cons + ( { instr = + MIseq + [ mk_instr (MIdig 4) + ; mk_instr (MIpush (mt_int, MLiteral.small_int 2023)) + ] + } + , { instr = MIseq [ mk_instr (MI1_fail Failwith) ] } ) + ]; + [%expect + {| { IF_CONS { DIG 4 ; PUSH int 2023 } { FAILWITH } } -> { IF_CONS { DIG 4 } { FAILWITH } ; PUSH int 2023 } |}] +;; let%expect_test "cond_check_last_fail_push_if_cons" = - test [ - MIif_cons ( - { instr = MIseq [ - mk_instr (MI1_fail Failwith) - ]}, - { instr = MIseq [ - mk_instr (MIdig 2); - mk_instr (MIpush (mt_unit, MLiteral.unit)); - ]} - ) - ]; - [%expect {| + test + [ MIif_cons + ( { instr = MIseq [ mk_instr (MI1_fail Failwith) ] } + , { instr = + MIseq [ mk_instr (MIdig 2); mk_instr (MIpush (mt_unit, MLiteral.unit)) ] + } ) + ]; + [%expect + {| { IF_CONS { FAILWITH } { DIG 2 ; PUSH unit Unit } } -> { IF_CONS { FAILWITH } { DIG 2 } ; UNIT } |}] +;; let mk i = { instr = i } @@ -561,10 +611,12 @@ let%expect_test "if_with_left_branch_prefix_drop_and_right_branch_fails" = ] } ) ]; - [%expect {| + [%expect + {| { IF { DROP } { PUSH string "failing branch" ; FAILWITH } } -> { SWAP ; DROP ; IF {} { PUSH string "failing branch" ; FAILWITH } } |}] +;; let%expect_test "if_with_right_branch_prefix_drop_and_left_branch_fails" = test_instructions @@ -577,88 +629,73 @@ let%expect_test "if_with_right_branch_prefix_drop_and_left_branch_fails" = } , { instr = MIdrop } ) ]; - [%expect {| + [%expect + {| { IF { PUSH string "left fails" ; FAILWITH } { DROP } } -> { SWAP ; DROP ; IF { PUSH string "left fails" ; FAILWITH } {} } |}] +;; let%expect_test "if_with_drop_appended_after_the_if" = test_instructions [ MIif - ( { instr = - MIseq - [ mk (MIpush (mt_int, MLiteral.small_int 1)) - ; mk (MI2 (Add)) - ] - } - , { instr = - MIseq - [ mk (MIpush (mt_int, MLiteral.small_int 2)) - ; mk (MI2 (Mul)) - ] - } ) + ( { instr = MIseq [ mk (MIpush (mt_int, MLiteral.small_int 1)); mk (MI2 Add) ] } + , { instr = MIseq [ mk (MIpush (mt_int, MLiteral.small_int 2)); mk (MI2 Mul) ] } + ) ; MIdrop ]; - [%expect {| + [%expect + {| { IF { PUSH int 1 ; ADD } { PUSH int 2 ; MUL } ; DROP } -> { IF { PUSH int 1 ; ADD ; DROP } { PUSH int 2 ; MUL ; DROP } } |}] +;; let%expect_test "if_none_with_drop_appended" = test_instructions [ MIif_none ( { instr = MIseq [ mk (MIdig 1); mk (MI1 Neg) ] } - , { instr = MIseq [ mk (MIdig 2); mk (MI2 (Sub)) ] } ) + , { instr = MIseq [ mk (MIdig 2); mk (MI2 Sub) ] } ) ; MIdrop ]; - [%expect {| + [%expect + {| { IF_NONE { DIG 1 ; NEG } { DIG 2 ; SUB } ; DROP } -> { IF_NONE { SWAP ; DROP } { DIG 2 ; SUB ; DROP } } |}] +;; let%expect_test "if_left_with_drop_appended" = test_instructions [ MIif_left ( { instr = MIdrop } - , { instr = - MIseq - [ mk (MIpush (mt_nat, MLiteral.small_int 42)) - ; mk (MI1 Int) - ] - } ) + , { instr = MIseq [ mk (MIpush (mt_nat, MLiteral.small_int 42)); mk (MI1 Int) ] } + ) ; MIdrop ]; - [%expect {| + [%expect + {| { IF_LEFT { DROP } { PUSH nat 42 ; INT } ; DROP } -> { IF_LEFT { DROP 2 } {} } |}] +;; let%expect_test "if_cons_with_drop_appended" = test_instructions - [ MIif_cons - ( { instr = - MIseq - [ mk (MIdig 2) - ; mk (MIswap) - ] - } - , { instr = MIdrop } ) + [ MIif_cons ({ instr = MIseq [ mk (MIdig 2); mk MIswap ] }, { instr = MIdrop }) ; MIdrop ]; - [%expect {| + [%expect + {| { IF_CONS { DIG 2 ; SWAP } { DROP } ; DROP } -> { IF_CONS { DROP ; SWAP } { DROP 2 } } |}] +;; let%expect_test "if_with_prefix_drop_on_left_and_failing_right" = test_instructions [ MIif - ( { instr = - MIseq - [ mk (MIdrop) - ; mk (MI2 (Or)) - ] - } + ( { instr = MIseq [ mk MIdrop; mk (MI2 Or) ] } , { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "fail branch")) @@ -666,10 +703,12 @@ let%expect_test "if_with_prefix_drop_on_left_and_failing_right" = ] } ) ]; - [%expect {| + [%expect + {| { IF { DROP ; OR } { PUSH string "fail branch" ; FAILWITH } } -> { SWAP ; DROP ; IF { OR } { PUSH string "fail branch" ; FAILWITH } } |}] +;; let%expect_test "if_with_prefix_drop_on_right_and_failing_left" = test_instructions @@ -680,29 +719,21 @@ let%expect_test "if_with_prefix_drop_on_right_and_failing_left" = ; mk (MI1_fail Failwith) ] } - , { instr = - MIseq - [ mk (MIdrop) - ; mk (MI1 Not) - ] - } ) + , { instr = MIseq [ mk MIdrop; mk (MI1 Not) ] } ) ]; - [%expect {| + [%expect + {| { IF { PUSH string "Left is failing" ; FAILWITH } { DROP ; NOT } } -> { SWAP ; DROP ; IF { PUSH string "Left is failing" ; FAILWITH } { NOT } } |}] +;; let%expect_test "if_none_with_prefix_drop_on_left_and_failing_right" = test_instructions [ MIif_none - ( { instr = - MIseq - [ mk (MIdrop) - ; mk (MIdup 2) - ] - } + ( { instr = MIseq [ mk MIdrop; mk (MIdup 2) ] } , { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "right fails")) @@ -710,36 +741,30 @@ let%expect_test "if_none_with_prefix_drop_on_left_and_failing_right" = ] } ) ]; - [%expect {| + [%expect + {| { IF_NONE { DROP ; DUP 2 } { PUSH string "right fails" ; FAILWITH } } -> { IF_NONE { DROP ; DUP 2 } { PUSH string "right fails" ; FAILWITH } } |}] +;; let%expect_test "if_left_with_prefix_drop_on_right_and_failing_left" = test_instructions [ MIif_left ( { instr = MIseq [ mk (MI1_fail Failwith) ] } - , { instr = - MIseq - [ mk (MIdrop) - ; mk (MIdig 3) - ] - } ) + , { instr = MIseq [ mk MIdrop; mk (MIdig 3) ] } ) ]; - [%expect {| + [%expect + {| { IF_LEFT { FAILWITH } { DROP ; DIG 3 } } -> { IF_LEFT { FAILWITH } { DROP ; DIG 3 } } |}] +;; let%expect_test "if_cons_with_prefix_drop_on_left_and_failing_right" = test_instructions [ MIif_cons - ( { instr = - MIseq - [ mk (MIdrop) - ; mk (MIpush (mt_bool, MLiteral.bool true)) - ] - } + ( { instr = MIseq [ mk MIdrop; mk (MIpush (mt_bool, MLiteral.bool true)) ] } , { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "failing")) @@ -747,140 +772,116 @@ let%expect_test "if_cons_with_prefix_drop_on_left_and_failing_right" = ] } ) ]; - [%expect {| + [%expect + {| { IF_CONS { DROP ; PUSH bool True } { PUSH string "failing" ; FAILWITH } } -> { IF_CONS { DROP } { PUSH string "failing" ; FAILWITH } ; PUSH bool True } |}] +;; let%expect_test "remove_prefix_drop_on_if_left" = test_instructions [ MIif_left - ( { instr = MIdrop } - , { instr = MIseq [ mk (MIpush (mt_unit, MLiteral.unit)) ] } ) + ({ instr = MIdrop }, { instr = MIseq [ mk (MIpush (mt_unit, MLiteral.unit)) ] }) ]; - [%expect {| + [%expect + {| { IF_LEFT { DROP } { PUSH unit Unit } } -> { IF_LEFT { DROP } { UNIT } } |}] - +;; + let%expect_test "dig_dug_several_same_DIG" = - test_instructions - [ MIdig 2 - ; MIdig 2 - ; MIdig 2 - ; MIdig 2 - ]; + test_instructions [ MIdig 2; MIdig 2; MIdig 2; MIdig 2 ]; [%expect {| { DIG 2 ; DIG 2 ; DIG 2 ; DIG 2 } -> { DIG 2 } |}] +;; let%expect_test "dig_dug_several_same_DUG" = - test_instructions - [ MIdug 3 - ; MIdug 3 - ; MIdug 3 - ]; + test_instructions [ MIdug 3; MIdug 3; MIdug 3 ]; [%expect {| { DUG 3 ; DUG 3 ; DUG 3 } -> { DIG 3 } |}] +;; let%expect_test "dig_dug_interleave" = - test_instructions - [ MIdig 2 - ; MIdig 2 - ; MIdug 2 - ; MIdug 2 - ; MIdig 2 - ]; + test_instructions [ MIdig 2; MIdig 2; MIdug 2; MIdug 2; MIdig 2 ]; [%expect {| { DIG 2 ; DIG 2 ; DUG 2 ; DUG 2 ; DIG 2 } -> { DIG 2 } |}] +;; let%expect_test "dig_dug_with_swap" = - test_instructions - [ MIdig 1 - ; MIdig 1 - ; MIswap - ; MIdug 1 - ; MIdug 1 - ]; + test_instructions [ MIdig 1; MIdig 1; MIswap; MIdug 1; MIdug 1 ]; [%expect {| { DIG 1 ; DIG 1 ; SWAP ; DUG 1 ; DUG 1 } -> { SWAP } |}] +;; let%expect_test "dig_dug_swap_with_break" = - test_instructions - [ MIdig 1 - ; MIpush (mt_nat, MLiteral.small_int 42) - ; MIswap - ; MIdug 1 - ]; - [%expect {| + test_instructions [ MIdig 1; MIpush (mt_nat, MLiteral.small_int 42); MIswap; MIdug 1 ]; + [%expect + {| { DIG 1 ; PUSH nat 42 ; SWAP ; DUG 1 } -> { SWAP ; PUSH nat 42 } |}] +;; let%expect_test "dig_dug_with_comments" = test_instructions [ MIdig 2 - ; MIcomment ["some comment"] + ; MIcomment [ "some comment" ] ; MIdig 2 ; MIswap ; MIdug 2 - ; MIcomment ["another comment"] + ; MIcomment [ "another comment" ] ; MIdug 2 ]; - [%expect {| + [%expect + {| { DIG 2 ; DIG 2 ; SWAP ; DUG 2 ; DUG 2 } -> { DUG 2 ; SWAP ; DIG 2 } |}] +;; let%expect_test "dig_dug_single_DIG" = - test_instructions - [ MIdig 3 - ; MIpush (mt_string, MLiteral.string "hello") - ]; - [%expect {| + test_instructions [ MIdig 3; MIpush (mt_string, MLiteral.string "hello") ]; + [%expect + {| { DIG 3 ; PUSH string "hello" } -> { DIG 3 ; PUSH string "hello" } |}] +;; let%expect_test "dig_dug_single_DUG" = - test_instructions - [ MIdug 2 - ; MI1 Not - ; MIdrop - ]; + test_instructions [ MIdug 2; MI1 Not; MIdrop ]; [%expect {| { DUG 2 ; NOT ; DROP } -> { SWAP ; DROP ; SWAP } |}] +;; let%expect_test "dig_dug_cycle_dig" = - test_instructions - [ MIdig 3 - ; MIdig 3 - ; MIdig 3 - ]; + test_instructions [ MIdig 3; MIdig 3; MIdig 3 ]; [%expect {| { DIG 3 ; DIG 3 ; DIG 3 } -> { DUG 3 } |}] +;; let%expect_test "dig_dug_cycle_dug" = - test_instructions - [ MIdug 2 - ; MIdug 2 - ]; + test_instructions [ MIdug 2; MIdug 2 ]; [%expect {| { DUG 2 ; DUG 2 } -> { DIG 2 } |}] +;; let%expect_test "if_both_branches_start_with_DIG_DROP_same_n" = test_instructions @@ -900,23 +901,22 @@ let%expect_test "if_both_branches_start_with_DIG_DROP_same_n" = ] } ) ]; - [%expect {| + [%expect + {| { IF { DIG 2 ; DROP ; PUSH string "left branch" } { DIG 2 ; DROP ; PUSH string "right branch" } } -> { DIG 3 ; DROP ; IF { PUSH string "left branch" } { PUSH string "right branch" } } |}] +;; let%expect_test "if_DIG2_DROP_vs_DIG1_DROP_minmax_like_case" = test_instructions [ MIif ( { instr = MIseq - [ mk (MIdig 2) - ; mk MIdrop - ; mk (MIpush (mt_int, MLiteral.small_int 100)) - ] + [ mk (MIdig 2); mk MIdrop; mk (MIpush (mt_int, MLiteral.small_int 100)) ] } , { instr = MIseq @@ -928,43 +928,34 @@ let%expect_test "if_DIG2_DROP_vs_DIG1_DROP_minmax_like_case" = ] } ) ]; - [%expect {| + [%expect + {| { IF { DIG 2 ; DROP ; PUSH int 100 } { DIG 1 ; DROP ; DIG 1 ; DROP ; PUSH int 200 } } -> { DIG 3 ; DROP ; IF { PUSH int 100 } { SWAP ; DROP ; PUSH int 200 } } |}] +;; let%expect_test "if_min_max_pattern" = test_instructions [ MIif - ( { instr = - MIseq - [ mk MIdrop - ; mk (MIdig 3) - ; mk MIdrop - ] - } - , { instr = - MIseq - [ mk (MIdig 1) - ; mk MIdrop - ; mk (MIdig 3) - ; mk MIdrop - ] - } ) + ( { instr = MIseq [ mk MIdrop; mk (MIdig 3); mk MIdrop ] } + , { instr = MIseq [ mk (MIdig 1); mk MIdrop; mk (MIdig 3); mk MIdrop ] } ) ]; - [%expect {| + [%expect + {| { IF { DROP ; DIG 3 ; DROP } { DIG 1 ; DROP ; DIG 3 ; DROP } } -> { DIG 5 ; DROP ; IF { DROP } { SWAP ; DROP } } |}] +;; let%expect_test "if_with_empty_branches" = - test_instructions - [ MIif ({ instr = MIseq [] }, { instr = MIseq [] }) ]; + test_instructions [ MIif ({ instr = MIseq [] }, { instr = MIseq [] }) ]; [%expect {| { IF {} {} } -> { DROP } |}] +;; let%expect_test "if_left_drop_drop_to_drop" = test_instructions [ MIif_left (mk MIdrop, mk MIdrop) ]; @@ -972,17 +963,16 @@ let%expect_test "if_left_drop_drop_to_drop" = { IF_LEFT { DROP } { DROP } } -> { DROP } |}] +;; let%expect_test "if_cons_double_drop_left_empty_right" = test_instructions - [ MIif_cons - ( { instr = MIseq [ mk MIdrop; mk MIdrop ] } - , { instr = MIseq [] } ) - ]; + [ MIif_cons ({ instr = MIseq [ mk MIdrop; mk MIdrop ] }, { instr = MIseq [] }) ]; [%expect {| { IF_CONS { DROP ; DROP } {} } -> { DROP } |}] +;; let%expect_test "if_left_with_drop_dig_drop_on_both_sides" = test_instructions @@ -1004,7 +994,8 @@ let%expect_test "if_left_with_drop_dig_drop_on_both_sides" = ] } ) ]; - [%expect {| + [%expect + {| { IF_LEFT { DROP ; DIG 2 ; DROP ; PUSH string "L" } { DROP ; DIG 2 ; DROP ; PUSH string "R" } } @@ -1012,6 +1003,7 @@ let%expect_test "if_left_with_drop_dig_drop_on_both_sides" = { DIG 3 ; DROP ; IF_LEFT { DROP ; PUSH string "L" } { DROP ; PUSH string "R" } } |}] +;; let%expect_test "not_then_if_swaps_branches" = test_instructions @@ -1020,103 +1012,92 @@ let%expect_test "not_then_if_swaps_branches" = ( { instr = MIseq [ mk (MIpush (mt_int, MLiteral.small_int 1)) ] } , { instr = MIseq [ mk (MIpush (mt_int, MLiteral.small_int 2)) ] } ) ]; - [%expect {| + [%expect + {| { NOT ; IF { PUSH int 1 } { PUSH int 2 } } -> { IF { PUSH int 2 } { PUSH int 1 } } |}] +;; let%expect_test "if_push_true_push_false_removed" = test_instructions [ MIif - ( mk (MIpush (mt_bool, MLiteral.bool true)), - mk (MIpush (mt_bool, MLiteral.bool false)) ) + ( mk (MIpush (mt_bool, MLiteral.bool true)) + , mk (MIpush (mt_bool, MLiteral.bool false)) ) ]; [%expect {| { IF { PUSH bool True } { PUSH bool False } } -> {} |}] +;; let%expect_test "if_push_false_push_true_to_not" = test_instructions [ MIif - ( mk (MIpush (mt_bool, MLiteral.bool false)), - mk (MIpush (mt_bool, MLiteral.bool true)) ) + ( mk (MIpush (mt_bool, MLiteral.bool false)) + , mk (MIpush (mt_bool, MLiteral.bool true)) ) ]; [%expect {| { IF { PUSH bool False } { PUSH bool True } } -> { NOT } |}] +;; let%expect_test "if_push_bool_x_then_afterwards_not_on_stack" = test_instructions - [ MIif - ( mk (MIpush (mt_bool, MLiteral.bool true)), - mk (MIdrop) ) - ; MI1 Not - ]; - [%expect {| + [ MIif (mk (MIpush (mt_bool, MLiteral.bool true)), mk MIdrop); MI1 Not ]; + [%expect + {| { IF { PUSH bool True } { DROP } ; NOT } -> { IF { PUSH bool False } { DROP ; NOT } } |}] +;; let%expect_test "if_drop_appended_afterwards" = test_instructions [ MIif - ( { instr = - MIseq - [ mk (MIpush (mt_string, MLiteral.string "left code")) - ] - } - , { instr = - MIseq - [ mk (MIpush (mt_string, MLiteral.string "right code")) - ] - } ) + ( { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "left code")) ] } + , { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "right code")) ] } ) ; MIdrop ]; - [%expect {| + [%expect + {| { IF { PUSH string "left code" } { PUSH string "right code" } ; DROP } -> { DROP } |}] +;; let%expect_test "if_dig_drop_appended_afterwards" = test_instructions [ MIif - ( { instr = - MIseq - [ mk (MIpush (mt_nat, MLiteral.small_int 123)) ] - } - , { instr = - MIseq - [ mk (MIpush (mt_string, MLiteral.string "string-literal")) ] - } ) + ( { instr = MIseq [ mk (MIpush (mt_nat, MLiteral.small_int 123)) ] } + , { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "string-literal")) ] } + ) ; MIdig 2 ; MIdrop ]; - [%expect {| + [%expect + {| { IF { PUSH nat 123 } { PUSH string "string-literal" } ; DIG 2 ; DROP } -> { DIG 2 ; DROP ; IF { PUSH nat 123 } { PUSH string "string-literal" } } |}] +;; let%expect_test "if_left_left_branch_fail_right_branch_dig_drop" = test_instructions [ MIif_left - ( { instr = - MIseq - [ mk (MI1_fail Failwith) ] - } + ( { instr = MIseq [ mk (MI1_fail Failwith) ] } , { instr = MIseq - [ mk (MIdig 3) - ; mk MIdrop - ; mk (MIpush (mt_int, MLiteral.small_int 111)) - ] + [ mk (MIdig 3); mk MIdrop; mk (MIpush (mt_int, MLiteral.small_int 111)) ] } ) ]; - [%expect {| + [%expect + {| { IF_LEFT { FAILWITH } { DIG 3 ; DROP ; PUSH int 111 } } -> { IF_LEFT { FAILWITH } { DIG 3 ; DROP } ; PUSH int 111 } |}] +;; let%expect_test "if_none_right_branch_fail_left_branch_dig_drop" = test_instructions @@ -1130,42 +1111,33 @@ let%expect_test "if_none_right_branch_fail_left_branch_dig_drop" = } , { instr = MIseq [ mk (MI1_fail Failwith) ] } ) ]; - [%expect {| + [%expect + {| { IF_NONE { DIG 2 ; DROP ; PUSH string "some" } { FAILWITH } } -> { IF_NONE { DIG 2 ; DROP } { FAILWITH } ; PUSH string "some" } |}] +;; let%expect_test "if_none_pair_fail_test" = test_instructions [ MIif_none - ( { instr = - MIseq - [ mk (MI2 (Pair(None, None))) - ; mk (MI1_fail Failwith) - ] - } + ( { instr = MIseq [ mk (MI2 (Pair (None, None))); mk (MI1_fail Failwith) ] } , { instr = MIseq - [ mk (MIdig 3) - ; mk MIdrop - ; mk (MIpush (mt_nat, MLiteral.small_int 999)) - ] + [ mk (MIdig 3); mk MIdrop; mk (MIpush (mt_nat, MLiteral.small_int 999)) ] } ) ]; - [%expect {| + [%expect + {| { IF_NONE { PAIR ; FAILWITH } { DIG 3 ; DROP ; PUSH nat 999 } } -> { DIG 3 ; DROP ; IF_NONE { PAIR ; FAILWITH } {} ; PUSH nat 999 } |}] +;; let%expect_test "if_drop_fail" = test_instructions [ MIif - ( { instr = - MIseq - [ mk MIdrop - ; mk (MI1 Neg) - ] - } + ( { instr = MIseq [ mk MIdrop; mk (MI1 Neg) ] } , { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "fail msg")) @@ -1173,71 +1145,54 @@ let%expect_test "if_drop_fail" = ] } ) ]; - [%expect {| + [%expect + {| { IF { DROP ; NEG } { PUSH string "fail msg" ; FAILWITH } } -> { SWAP ; DROP ; IF { NEG } { PUSH string "fail msg" ; FAILWITH } } |}] +;; let%expect_test "if_fail_drop" = test_instructions [ MIif - ( { instr = - MIseq - [ mk (MI1_fail Failwith) - ] - } - , { instr = - MIseq - [ mk MIdrop - ; mk (MIdup 1) - ] - } ) + ( { instr = MIseq [ mk (MI1_fail Failwith) ] } + , { instr = MIseq [ mk MIdrop; mk (MIdup 1) ] } ) ]; - [%expect {| + [%expect + {| { IF { FAILWITH } { DROP ; DUP } } -> { IF { FAILWITH } { DROP ; DUP } } |}] +;; let%expect_test "if_both_branches_drop_merge_to_single_drop" = test_instructions - [ MIif - ( { instr = - MIseq - [ mk MIdrop - ; mk MIdrop - ] - } - , { instr = - MIseq - [ mk MIdrop - ] - } ) - ]; - [%expect {| + [ MIif ({ instr = MIseq [ mk MIdrop; mk MIdrop ] }, { instr = MIseq [ mk MIdrop ] }) ]; + [%expect + {| { IF { DROP ; DROP } { DROP } } -> { SWAP ; DROP ; IF { DROP } {} } |}] +;; let%expect_test "if_left_push_int_n_fail_merge" = test_instructions [ MIif_left ( { instr = MIseq - [ mk (MIpush (mt_int, MLiteral.small_int 999)) - ; mk (MI1_fail Failwith) - ] + [ mk (MIpush (mt_int, MLiteral.small_int 999)); mk (MI1_fail Failwith) ] } , { instr = MIseq - [ mk (MIpush (mt_int, MLiteral.small_int 999)) - ; mk (MI1_fail Failwith) - ] + [ mk (MIpush (mt_int, MLiteral.small_int 999)); mk (MI1_fail Failwith) ] } ) ]; - [%expect {| + [%expect + {| { IF_LEFT { PUSH int 999 ; FAILWITH } { PUSH int 999 ; FAILWITH } } -> { PUSH int 999 ; FAILWITH } |}] +;; let%expect_test "if_left_dig_drop_fail_right" = test_instructions @@ -1256,7 +1211,8 @@ let%expect_test "if_left_dig_drop_fail_right" = ] } ) ]; - [%expect {| + [%expect + {| { IF_LEFT { DIG 2 ; DROP ; PUSH string "some left" } { PUSH string "boom" ; FAILWITH } } @@ -1265,16 +1221,14 @@ let%expect_test "if_left_dig_drop_fail_right" = DROP ; IF_LEFT {} { PUSH string "boom" ; FAILWITH } ; PUSH string "some left" } |}] +;; let%expect_test "if_cons_left_is_dig_drop_fail_right" = test_instructions [ MIif_cons ( { instr = MIseq - [ mk (MIdig 2) - ; mk MIdrop - ; mk (MIpush (mt_bool, MLiteral.bool false)) - ] + [ mk (MIdig 2); mk MIdrop; mk (MIpush (mt_bool, MLiteral.bool false)) ] } , { instr = MIseq @@ -1283,7 +1237,8 @@ let%expect_test "if_cons_left_is_dig_drop_fail_right" = ] } ) ]; - [%expect {| + [%expect + {| { IF_CONS { DIG 2 ; DROP ; PUSH bool False } { PUSH string "failbranch" ; FAILWITH } } @@ -1292,91 +1247,78 @@ let%expect_test "if_cons_left_is_dig_drop_fail_right" = DROP ; IF_CONS {} { PUSH string "failbranch" ; FAILWITH } ; PUSH bool False } |}] +;; let%expect_test "if_left_dig1_drop_many" = test_instructions [ MIif_left - ( { instr = - MIseq - [ mk (MIdig 1) - ; mk MIdrop - ; mk (MIpush (mt_unit, MLiteral.unit)) - ] + ( { instr = MIseq [ mk (MIdig 1); mk MIdrop; mk (MIpush (mt_unit, MLiteral.unit)) ] } , { instr = MIseq - [ mk MIdrop - ; mk MIdrop - ; mk (MIpush (mt_string, MLiteral.string "hello")) - ] + [ mk MIdrop; mk MIdrop; mk (MIpush (mt_string, MLiteral.string "hello")) ] } ) ]; - [%expect {| + [%expect + {| { IF_LEFT { DIG 1 ; DROP ; PUSH unit Unit } { DROP ; DROP ; PUSH string "hello" } } -> { SWAP ; DROP ; IF_LEFT { UNIT } { DROP ; PUSH string "hello" } } |}] +;; let%expect_test "if_multiple_drop_on_left_and_right" = test_instructions [ MIif_none - ( { instr = - MIseq [ mk MIdrop; mk (MIdup 1) ] - } + ( { instr = MIseq [ mk MIdrop; mk (MIdup 1) ] } , { instr = - MIseq [ mk (MIdig 1); mk MIdrop; mk (MIpush (mt_nat, MLiteral.small_int 42)) ] + MIseq + [ mk (MIdig 1); mk MIdrop; mk (MIpush (mt_nat, MLiteral.small_int 42)) ] } ) ]; - [%expect {| + [%expect + {| { IF_NONE { DROP ; DUP } { DIG 1 ; DROP ; PUSH nat 42 } } -> { SWAP ; DROP ; IF_NONE { DUP } { PUSH nat 42 } } |}] +;; let%expect_test "if_left_drop_drop_and_drop_drop" = test_instructions [ MIif_left ( { instr = - MIseq - [ mk MIdrop - ; mk MIdrop - ; mk (MIpush (mt_int, MLiteral.small_int 10)) - ] + MIseq [ mk MIdrop; mk MIdrop; mk (MIpush (mt_int, MLiteral.small_int 10)) ] } , { instr = - MIseq - [ mk MIdrop - ; mk MIdrop - ; mk (MIpush (mt_int, MLiteral.small_int 20)) - ] + MIseq [ mk MIdrop; mk MIdrop; mk (MIpush (mt_int, MLiteral.small_int 20)) ] } ) ]; - [%expect {| + [%expect + {| { IF_LEFT { DROP ; DROP ; PUSH int 10 } { DROP ; DROP ; PUSH int 20 } } -> { SWAP ; DROP ; IF_LEFT { DROP ; PUSH int 10 } { DROP ; PUSH int 20 } } |}] +;; let%expect_test "if_none_bool_flip" = test_instructions [ MIif_none - ( { instr = (MIpush (mt_bool, MLiteral.bool false)) } - , { instr = - MIseq - [ mk MIdrop - ; mk (MIpush (mt_bool, MLiteral.bool true)) - ] - } ) + ( { instr = MIpush (mt_bool, MLiteral.bool false) } + , { instr = MIseq [ mk MIdrop; mk (MIpush (mt_bool, MLiteral.bool true)) ] } ) ; MIif - ( { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "x")) ] }, - { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "y")) ] } ) + ( { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "x")) ] } + , { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "y")) ] } ) ]; - [%expect {| + [%expect + {| { IF_NONE { PUSH bool False } { DROP ; PUSH bool True } ; IF { PUSH string "x" } { PUSH string "y" } } -> { IF_NONE { PUSH string "y" } { DROP ; PUSH string "x" } } |}] +;; let%expect_test "nested_if_in_one_branch" = test_instructions @@ -1385,32 +1327,36 @@ let%expect_test "nested_if_in_one_branch" = MIseq [ mk (MIif - ( mk (MIpush (mt_int, MLiteral.small_int 1)), - mk (MIpush (mt_int, MLiteral.small_int 2)) )) + ( mk (MIpush (mt_int, MLiteral.small_int 1)) + , mk (MIpush (mt_int, MLiteral.small_int 2)) )) ] } , { instr = MIdrop } ) ]; - [%expect {| + [%expect + {| { IF { IF { PUSH int 1 } { PUSH int 2 } } { DROP } } -> { IF { IF { PUSH int 1 } { PUSH int 2 } } { DROP } } |}] +;; let%expect_test "multiple_if_in_a_row" = test_instructions [ MIif - ( { instr = (MIpush (mt_string, MLiteral.string "A")) }, - { instr = (MIpush (mt_string, MLiteral.string "B")) } ) + ( { instr = MIpush (mt_string, MLiteral.string "A") } + , { instr = MIpush (mt_string, MLiteral.string "B") } ) ; MIif - ( { instr = (MIpush (mt_string, MLiteral.string "C")) }, - { instr = (MIpush (mt_string, MLiteral.string "D")) } ) + ( { instr = MIpush (mt_string, MLiteral.string "C") } + , { instr = MIpush (mt_string, MLiteral.string "D") } ) ]; - [%expect {| + [%expect + {| { IF { PUSH string "A" } { PUSH string "B" } ; IF { PUSH string "C" } { PUSH string "D" } } -> { IF { PUSH string "A" } { PUSH string "B" } ; IF { PUSH string "C" } { PUSH string "D" } } |}] +;; let%expect_test "if_none_nested_if_left_branch" = test_instructions @@ -1419,54 +1365,49 @@ let%expect_test "if_none_nested_if_left_branch" = MIseq [ mk (MIif - ( mk (MIpush (mt_bool, MLiteral.bool true)), - mk (MIpush (mt_bool, MLiteral.bool false)) )) + ( mk (MIpush (mt_bool, MLiteral.bool true)) + , mk (MIpush (mt_bool, MLiteral.bool false)) )) ] } , mk (MIpush (mt_nat, MLiteral.small_int 42)) ) ]; - [%expect {| + [%expect + {| { IF_NONE { IF { PUSH bool True } { PUSH bool False } } { PUSH nat 42 } } -> { IF_NONE {} { PUSH nat 42 } } |}] +;; let%expect_test "if_left_with_lambda_in_branch" = let lam_body = { instr = MIseq [ mk (MIpush (mt_int, MLiteral.small_int 1)) ] } in test_instructions [ MIif_left - ( { instr = - MIseq - [ mk (MIlambda (mt_nat, mt_int, lam_body)) - ; mk (MI2 Exec) - ] - } + ( { instr = MIseq [ mk (MIlambda (mt_nat, mt_int, lam_body)); mk (MI2 Exec) ] } , mk (MIpush (mt_string, MLiteral.string "right")) ) ]; - [%expect {| + [%expect + {| { IF_LEFT { LAMBDA nat int { PUSH int 1 } ; EXEC } { PUSH string "right" } } -> { IF_LEFT { LAMBDA nat int { PUSH int 1 } ; EXEC } { PUSH string "right" } } |}] +;; let%expect_test "if_left_with_lam_and_fail" = let lam_body = { instr = MIseq [ mk (MIpush (mt_int, MLiteral.small_int 123)) ] } in test_instructions [ MIif_left ( { instr = - MIseq - [ mk (MIlambda (mt_nat, mt_int, lam_body)) - ; mk (MI1_fail Failwith) - ] + MIseq [ mk (MIlambda (mt_nat, mt_int, lam_body)); mk (MI1_fail Failwith) ] } , { instr = MIseq - [ mk (MIpush (mt_int, MLiteral.small_int 999)) - ; mk (MI1_fail Failwith) - ] + [ mk (MIpush (mt_int, MLiteral.small_int 999)); mk (MI1_fail Failwith) ] } ) ]; - [%expect {| + [%expect + {| { IF_LEFT { LAMBDA nat int { PUSH int 123 } ; FAILWITH } { PUSH int 999 ; FAILWITH } } @@ -1474,6 +1415,7 @@ let%expect_test "if_left_with_lam_and_fail" = { IF_LEFT { LAMBDA nat int { PUSH int 123 } ; FAILWITH } { PUSH int 999 ; FAILWITH } } |}] +;; let%expect_test "if_cons_with_nested_condition_in_left" = test_instructions @@ -1482,29 +1424,33 @@ let%expect_test "if_cons_with_nested_condition_in_left" = MIseq [ mk (MIif - ( mk (MIpush (mt_bool, MLiteral.bool false)), - mk (MIpush (mt_bool, MLiteral.bool true)) )) + ( mk (MIpush (mt_bool, MLiteral.bool false)) + , mk (MIpush (mt_bool, MLiteral.bool true)) )) ] } , mk MIdrop ) ]; - [%expect {| + [%expect + {| { IF_CONS { IF { PUSH bool False } { PUSH bool True } } { DROP } } -> { IF_CONS { NOT } { DROP } } |}] +;; let%expect_test "multiple_not_in_a_row_then_if" = test_instructions [ MI1 Not ; MI1 Not ; MIif - ( mk (MIpush (mt_bool, MLiteral.bool false)), - mk (MIpush (mt_bool, MLiteral.bool true)) ) + ( mk (MIpush (mt_bool, MLiteral.bool false)) + , mk (MIpush (mt_bool, MLiteral.bool true)) ) ]; - [%expect {| + [%expect + {| { NOT ; NOT ; IF { PUSH bool False } { PUSH bool True } } -> { NOT ; NOT ; NOT } |}] +;; let%expect_test "if_min_max_pattern_double" = test_instructions @@ -1529,7 +1475,8 @@ let%expect_test "if_min_max_pattern_double" = } ) ; MI1 Neg ]; - [%expect {| + [%expect + {| { NEG ; IF { DROP ; DIG 2 ; DROP ; PUSH nat 10 } { DIG 1 ; DROP ; DIG 2 ; DROP ; PUSH nat 20 } ; @@ -1539,41 +1486,38 @@ let%expect_test "if_min_max_pattern_double" = IF { DROP ; DIG 2 ; DROP ; PUSH nat 10 } { SWAP ; DROP ; DIG 2 ; DROP ; PUSH nat 20 } ; NEG } |}] +;; let%expect_test "if_drop_on_one_branch_and_nested_if_on_other" = test_instructions [ MIif ( { instr = MIseq - [ mk MIdrop - ; mk (MIpush (mt_string, MLiteral.string "some leftover")) - ] + [ mk MIdrop; mk (MIpush (mt_string, MLiteral.string "some leftover")) ] } , { instr = MIseq [ mk (MIif - ( mk (MIpush (mt_nat, MLiteral.small_int 123)), - mk (MIpush (mt_nat, MLiteral.small_int 456)) )) + ( mk (MIpush (mt_nat, MLiteral.small_int 123)) + , mk (MIpush (mt_nat, MLiteral.small_int 456)) )) ] } ) ]; - [%expect {| + [%expect + {| { IF { DROP ; PUSH string "some leftover" } { IF { PUSH nat 123 } { PUSH nat 456 } } } -> { IF { DROP ; PUSH string "some leftover" } { IF { PUSH nat 123 } { PUSH nat 456 } } } |}] +;; let%expect_test "if_with_chained_drops_and_fail" = test_instructions [ MIif ( { instr = - MIseq - [ mk MIdrop - ; mk MIdrop - ; mk (MIpush (mt_int, MLiteral.small_int 111)) - ] + MIseq [ mk MIdrop; mk MIdrop; mk (MIpush (mt_int, MLiteral.small_int 111)) ] } , { instr = MIseq @@ -1582,34 +1526,35 @@ let%expect_test "if_with_chained_drops_and_fail" = ] } ) ]; - [%expect {| + [%expect + {| { IF { DROP ; DROP ; PUSH int 111 } { PUSH string "fail msg" ; FAILWITH } } -> { DUG 2 ; DROP 2 ; IF {} { PUSH string "fail msg" ; FAILWITH } ; PUSH int 111 } |}] +;; let%expect_test "if_none_push_true_push_false_not_appended" = test_instructions [ MIif_none - ( mk (MIpush (mt_bool, MLiteral.bool true)), - mk (MIpush (mt_bool, MLiteral.bool false)) ) + ( mk (MIpush (mt_bool, MLiteral.bool true)) + , mk (MIpush (mt_bool, MLiteral.bool false)) ) ; MI1 Not ]; - [%expect {| + [%expect + {| { IF_NONE { PUSH bool True } { PUSH bool False } ; NOT } -> { IF_NONE { PUSH bool True } { PUSH bool False } ; NOT } |}] +;; let%expect_test "if_none_multiple_branches_with_drop_extra" = test_instructions [ MIif_none ( { instr = - MIseq - [ mk MIdrop - ; mk (MIpush (mt_string, MLiteral.string "some data")) - ] + MIseq [ mk MIdrop; mk (MIpush (mt_string, MLiteral.string "some data")) ] } , { instr = MIseq @@ -1619,7 +1564,8 @@ let%expect_test "if_none_multiple_branches_with_drop_extra" = ] } ) ]; - [%expect {| + [%expect + {| { IF_NONE { DROP ; PUSH string "some data" } { DIG 2 ; DROP ; PUSH string "other data" } } @@ -1627,94 +1573,89 @@ let%expect_test "if_none_multiple_branches_with_drop_extra" = { IF_NONE { DROP ; PUSH string "some data" } { DIG 2 ; DROP ; PUSH string "other data" } } |}] +;; let%expect_test "if_cons_drop_drop_vs_nested_if" = test_instructions [ MIif_cons - ( { instr = MIseq [ mk MIdrop; mk MIdrop ] }, - { instr = + ( { instr = MIseq [ mk MIdrop; mk MIdrop ] } + , { instr = MIseq [ mk (MIif - ( mk (MIpush (mt_int, MLiteral.small_int 1000)), - mk (MIpush (mt_int, MLiteral.small_int 2000)) )) - ] } ) + ( mk (MIpush (mt_int, MLiteral.small_int 1000)) + , mk (MIpush (mt_int, MLiteral.small_int 2000)) )) + ] + } ) ]; - [%expect {| + [%expect + {| { IF_CONS { DROP ; DROP } { IF { PUSH int 1000 } { PUSH int 2000 } } } -> { IF_CONS { DROP 2 } { IF { PUSH int 1000 } { PUSH int 2000 } } } |}] +;; let%expect_test "if_cons_push_bool_false_fail_merge" = test_instructions [ MIif_cons ( { instr = - MIseq - [ mk (MIpush (mt_bool, MLiteral.bool false)) - ; mk (MI1_fail Failwith) - ] + MIseq [ mk (MIpush (mt_bool, MLiteral.bool false)); mk (MI1_fail Failwith) ] } , { instr = - MIseq - [ mk (MIpush (mt_bool, MLiteral.bool false)) - ; mk (MI1_fail Failwith) - ] + MIseq [ mk (MIpush (mt_bool, MLiteral.bool false)); mk (MI1_fail Failwith) ] } ) ]; - [%expect {| + [%expect + {| { IF_CONS { PUSH bool False ; FAILWITH } { PUSH bool False ; FAILWITH } } -> { IF_CONS { PUSH bool False ; FAILWITH } { PUSH bool False ; FAILWITH } } |}] +;; let%expect_test "if_left_drop_dig1_drop_left_vs_simple_right" = test_instructions [ MIif_left - ( { instr = - MIseq - [ mk MIdrop - ; mk (MIdig 1) - ; mk MIdrop - ] - } + ( { instr = MIseq [ mk MIdrop; mk (MIdig 1); mk MIdrop ] } , mk (MIpush (mt_nat, MLiteral.small_int 42)) ) ]; - [%expect {| + [%expect + {| { IF_LEFT { DROP ; DIG 1 ; DROP } { PUSH nat 42 } } -> { IF_LEFT { DROP ; SWAP ; DROP } { PUSH nat 42 } } |}] +;; let%expect_test "remove_comments_single" = - test_instructions - [ MIcomment ["this is a comment"] ]; + test_instructions [ MIcomment [ "this is a comment" ] ]; [%expect {| {} -> {} |}] +;; let%expect_test "remove_comments_interleaved" = test_instructions [ MIpush (mt_int, MLiteral.small_int 42) - ; MIcomment ["comment1"] + ; MIcomment [ "comment1" ] ; MIdrop - ; MIcomment ["comment2"; "comment3"] + ; MIcomment [ "comment2"; "comment3" ] ; MIdup 1 ]; [%expect {| { PUSH int 42 ; DROP ; DUP } -> { DUP } |}] +;; let%expect_test "remove_comments_sequences" = - test_instructions - [ MIcomment ["comment in seq"] - ; MIswap - ]; + test_instructions [ MIcomment [ "comment in seq" ]; MIswap ]; [%expect {| { SWAP } -> { SWAP } |}] +;; -let%expect_test "is_iter_cons_match_nil_nil" = +let%expect_test "is_iter_cons_match_nil_nil" = test_instructions [ MI0 (Nil mt_int) ; MIdig 1 @@ -1723,10 +1664,12 @@ let%expect_test "is_iter_cons_match_nil_nil" = ; MIiter { instr = MI2 Cons } ; MIiter { instr = MI2 Cons } ]; - [%expect {| + [%expect + {| { NIL int ; DIG 1 ; NIL int ; DIG 1 ; ITER { CONS } ; ITER { CONS } } -> { NIL int ; NIL int ; DIG 2 ; ITER { CONS } ; ITER { CONS } } |}] +;; let%expect_test "is_iter_cons_with_one_match_only" = test_instructions @@ -1735,22 +1678,25 @@ let%expect_test "is_iter_cons_with_one_match_only" = ; MIiter { instr = MI2 Cons } ; MIiter { instr = MIdrop } ]; - [%expect {| + [%expect + {| { NIL string ; DIG 1 ; ITER { CONS } ; ITER { DROP } } -> { NIL string ; SWAP ; ITER { CONS } ; ITER { DROP } } |}] +;; let%expect_test "main_merge_consecutive_comments" = test_instructions - [ MIcomment ["comment 1"] - ; MIcomment ["comment 2"] - ; MIcomment ["comment 3"] + [ MIcomment [ "comment 1" ] + ; MIcomment [ "comment 2" ] + ; MIcomment [ "comment 3" ] ; MIpush (mt_int, MLiteral.small_int 42) ]; [%expect {| { PUSH int 42 } -> { PUSH int 42 } |}] +;; let%expect_test "main_flatten_sequences" = test_instructions @@ -1765,18 +1711,17 @@ let%expect_test "main_flatten_sequences" = { PUSH nat 10 ; DROP ; PUSH nat 20 ; DROP } -> {} |}] +;; let%expect_test "main_superfluous_swap" = test_instructions - [ MIdup 1 - ; MIdig 1 - ; MIdrop - ; MIpush (mt_string, MLiteral.string "post-swap") - ]; - [%expect {| + [ MIdup 1; MIdig 1; MIdrop; MIpush (mt_string, MLiteral.string "post-swap") ]; + [%expect + {| { DUP ; DIG 1 ; DROP ; PUSH string "post-swap" } -> { PUSH string "post-swap" } |}] +;; let%expect_test "main_swap_consecutive_pushes_with_dig1" = test_instructions @@ -1785,22 +1730,26 @@ let%expect_test "main_swap_consecutive_pushes_with_dig1" = ; MIdig 1 ; MIdrop ]; - [%expect {| + [%expect + {| { PUSH string "a" ; PUSH string "b" ; DIG 1 ; DROP } -> { PUSH string "b" } |}] +;; let%expect_test "main_instr_before_push_failwith" = test_instructions [ MIswap ; MIpush (mt_string, MLiteral.string "some error") ; MI1_fail Failwith - ; MIpush (mt_int, MLiteral.small_int 111) + ; MIpush (mt_int, MLiteral.small_int 111) ]; - [%expect {| + [%expect + {| { SWAP ; PUSH string "some error" ; FAILWITH ; PUSH int 111 } -> { PUSH string "some error" ; FAILWITH } |}] +;; let%expect_test "main_pushy_instr_drop" = test_instructions @@ -1808,198 +1757,168 @@ let%expect_test "main_pushy_instr_drop" = ; MIdrop ; MIpush (mt_string, MLiteral.string "continuation") ]; - [%expect {| + [%expect + {| { PUSH nat 123 ; DROP ; PUSH string "continuation" } -> { PUSH string "continuation" } |}] +;; let%expect_test "main_one_to_one_instr_drop" = - test_instructions - [ MI1 Not - ; MIdrop - ; MIpush (mt_int, MLiteral.small_int 42) - ]; + test_instructions [ MI1 Not; MIdrop; MIpush (mt_int, MLiteral.small_int 42) ]; [%expect {| { NOT ; DROP ; PUSH int 42 } -> { DROP ; PUSH int 42 } |}] +;; let%expect_test "main_two_to_one_instr_drop" = - test_instructions - [ MI2 Compare - ; MIdrop - ; MIpush (mt_bool, MLiteral.bool true) - ]; - [%expect {| + test_instructions [ MI2 Compare; MIdrop; MIpush (mt_bool, MLiteral.bool true) ]; + [%expect + {| { COMPARE ; DROP ; PUSH bool True } -> { DROP 2 ; PUSH bool True } |}] +;; let%expect_test "main_two_to_one_instr_double_drop" = test_instructions - [ MI2 Compare - ; MIdrop - ; MIdrop - ; MIpush (mt_string, MLiteral.string "hello") - ]; - [%expect {| + [ MI2 Compare; MIdrop; MIdrop; MIpush (mt_string, MLiteral.string "hello") ]; + [%expect + {| { COMPARE ; DROP ; DROP ; PUSH string "hello" } -> { DROP 3 ; PUSH string "hello" } |}] +;; let%expect_test "main_merge_consecutive_DIP" = - test_instructions - [ MIdip - { instr = - MIseq - [ mk (MIpush (mt_nat, MLiteral.small_int 10)) - ; mk (MIdrop) - ] - } - ; MIdip - { instr = - MIseq - [ mk (MIpush (mt_string, MLiteral.string "hello")) - ; mk (MI1 Not) - ] - } - ; MIdrop - ]; - [%expect {| + test_instructions + [ MIdip { instr = MIseq [ mk (MIpush (mt_nat, MLiteral.small_int 10)); mk MIdrop ] } + ; MIdip + { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "hello")); mk (MI1 Not) ] + } + ; MIdrop + ]; + [%expect + {| { DIP { PUSH nat 10 ; DROP } ; DIP { PUSH string "hello" ; NOT } ; DROP } -> { DROP ; PUSH string "hello" ; NOT } |}] - +;; let%expect_test "main_DIP_with_DROP_only" = - test_instructions - [ MIdip { instr = MIdrop } - ; MIpush (mt_int, MLiteral.small_int 999) - ]; - [%expect {| + test_instructions [ MIdip { instr = MIdrop }; MIpush (mt_int, MLiteral.small_int 999) ]; + [%expect + {| { DIP { DROP } ; PUSH int 999 } -> { SWAP ; DROP ; PUSH int 999 } |}] - - let%expect_test "main_DUP1_DIP_with_1to1_instr" = - test_instructions - [ MIdup 1 - ; MIdip - { instr = - MIseq - [ mk (MI1 Not) - ] - } - ; MIdrop - ]; - [%expect {| +;; + +let%expect_test "main_DUP1_DIP_with_1to1_instr" = + test_instructions [ MIdup 1; MIdip { instr = MIseq [ mk (MI1 Not) ] }; MIdrop ]; + [%expect {| { DUP ; DIP { NOT } ; DROP } -> { NOT } |}] - - let%expect_test "main_DIP_then_DROP" = - test_instructions - [ MIdip { instr = MIseq [ mk (MI2 Add) ] } - ; MIdrop - ; MIpush (mt_string, MLiteral.string "unused") - ]; - [%expect {| +;; + +let%expect_test "main_DIP_then_DROP" = + test_instructions + [ MIdip { instr = MIseq [ mk (MI2 Add) ] } + ; MIdrop + ; MIpush (mt_string, MLiteral.string "unused") + ]; + [%expect + {| { DIP { ADD } ; DROP ; PUSH string "unused" } -> { DROP ; ADD ; PUSH string "unused" } |}] - - let%expect_test "main_loop_push_bool_false" = - test_instructions - [ MIpush (mt_bool, MLiteral.bool false) - ; MIloop - { instr = - MIseq - [ mk (MI2 Mul) - ; mk (MIdrop) - ] - } - ; MIpush (mt_int, MLiteral.small_int 100) - ]; - [%expect {| +;; + +let%expect_test "main_loop_push_bool_false" = + test_instructions + [ MIpush (mt_bool, MLiteral.bool false) + ; MIloop { instr = MIseq [ mk (MI2 Mul); mk MIdrop ] } + ; MIpush (mt_int, MLiteral.small_int 100) + ]; + [%expect + {| { PUSH bool False ; LOOP { MUL ; DROP } ; PUSH int 100 } -> { PUSH int 100 } |}] - - let%expect_test "main_loop_left_push_right" = - test_instructions - [ MI1 (Right (None, None, mt_string)) - ; MIloop_left - { instr = - MIseq - [ mk (MIdrop) - ; mk (MIpush (mt_bool, MLiteral.bool true)) - ] - } - ; MIpush (mt_bool, MLiteral.bool false) - ]; - [%expect {| +;; + +let%expect_test "main_loop_left_push_right" = + test_instructions + [ MI1 (Right (None, None, mt_string)) + ; MIloop_left + { instr = MIseq [ mk MIdrop; mk (MIpush (mt_bool, MLiteral.bool true)) ] } + ; MIpush (mt_bool, MLiteral.bool false) + ]; + [%expect + {| { RIGHT string ; LOOP_LEFT { DROP ; PUSH bool True } ; PUSH bool False } -> { PUSH bool False } |}] +;; - let%expect_test "main_push_pair_literal" = - test_instructions - [ MIpush (mt_nat, MLiteral.small_int 11) - ; MIpush (mt_string, MLiteral.string "s") - ; MI2 (Pair (None, None)) - ; MIdrop - ]; - [%expect {| +let%expect_test "main_push_pair_literal" = + test_instructions + [ MIpush (mt_nat, MLiteral.small_int 11) + ; MIpush (mt_string, MLiteral.string "s") + ; MI2 (Pair (None, None)) + ; MIdrop + ]; + [%expect {| { PUSH nat 11 ; PUSH string "s" ; PAIR ; DROP } -> {} |}] - - let%expect_test "main_push_literal_then_Some" = - test_instructions - [ MIpush (mt_int, MLiteral.small_int 10) - ; MI1 Some_ - ; MIdrop - ]; - [%expect {| +;; + +let%expect_test "main_push_literal_then_Some" = + test_instructions [ MIpush (mt_int, MLiteral.small_int 10); MI1 Some_; MIdrop ]; + [%expect {| { PUSH int 10 ; SOME ; DROP } -> {} |}] - +;; + let%expect_test "main_push_and_left" = - test_instructions - [ MIpush (mt_nat, MLiteral.small_int 123) - ; MI1 (Left (None, None, mt_string)) - ; MIdrop - ]; - [%expect {| + test_instructions + [ MIpush (mt_nat, MLiteral.small_int 123) + ; MI1 (Left (None, None, mt_string)) + ; MIdrop + ]; + [%expect {| { PUSH nat 123 ; LEFT string ; DROP } -> {} |}] - +;; + let%expect_test "main_push_and_right" = - test_instructions - [ MIpush (mt_string, MLiteral.string "hello") - ; MI1 (Right (None, None, mt_nat)) - ; MIdrop - ]; - [%expect {| + test_instructions + [ MIpush (mt_string, MLiteral.string "hello") + ; MI1 (Right (None, None, mt_nat)) + ; MIdrop + ]; + [%expect {| { PUSH string "hello" ; RIGHT nat ; DROP } -> {} |}] +;; let%expect_test "main_two_one_instr_drop_drop" = test_instructions - [ MI2 Compare - ; MIdrop - ; MIdrop - ; MIpush (mt_int, MLiteral.small_int 42) - ]; - [%expect {| + [ MI2 Compare; MIdrop; MIdrop; MIpush (mt_int, MLiteral.small_int 42) ]; + [%expect + {| { COMPARE ; DROP ; DROP ; PUSH int 42 } -> { DROP 3 ; PUSH int 42 } |}] +;; let%expect_test "main_two_one_instr_drop_dig_drop" = test_instructions @@ -2009,41 +1928,42 @@ let%expect_test "main_two_one_instr_drop_dig_drop" = ; MIdrop ; MIpush (mt_bool, MLiteral.bool false) ]; - [%expect {| + [%expect + {| { PAIR ; DROP ; DIG 3 ; DROP ; PUSH bool False } -> { DROP 2 ; DIG 3 ; DROP ; PUSH bool False } |}] +;; let%expect_test "main_three_one_harmless_instr_drop" = - test_instructions - [ MI3 Slice - ; MIdrop - ; MIpush (mt_nat, MLiteral.small_int 987) - ]; + test_instructions [ MI3 Slice; MIdrop; MIpush (mt_nat, MLiteral.small_int 987) ]; [%expect {| { SLICE ; DROP ; PUSH nat 987 } -> { DROP 3 ; PUSH nat 987 } |}] +;; - let%expect_test "main_remove_dip_drop" = +let%expect_test "main_remove_dip_drop" = test_instructions - [ MIdip { instr = MIdrop } - ; MIpush (mt_string, MLiteral.string "after dip+drop") - ]; - [%expect {| + [ MIdip { instr = MIdrop }; MIpush (mt_string, MLiteral.string "after dip+drop") ]; + [%expect + {| { DIP { DROP } ; PUSH string "after dip+drop" } -> { SWAP ; DROP ; PUSH string "after dip+drop" } |}] +;; let%expect_test "main_remove_dip_empty_seq" = test_instructions [ MIdip { instr = MIseq [] } ; MIpush (mt_string, MLiteral.string "another instruction") ]; - [%expect {| + [%expect + {| { DIP {} ; PUSH string "another instruction" } -> { PUSH string "another instruction" } |}] +;; let%expect_test "main_merge_nested_dip" = test_instructions @@ -2051,10 +1971,12 @@ let%expect_test "main_merge_nested_dip" = ; MIdip { instr = MIseq [ mk (MIpush (mt_nat, MLiteral.small_int 2)) ] } ; MIpush (mt_nat, MLiteral.small_int 3) ]; - [%expect {| + [%expect + {| { DIP { PUSH nat 1 } ; DIP { PUSH nat 2 } ; PUSH nat 3 } -> { DIP { PUSH nat 1 ; PUSH nat 2 } ; PUSH nat 3 } |}] +;; let%expect_test "main_dup1_dip_one_to_one_instr" = test_instructions @@ -2062,10 +1984,12 @@ let%expect_test "main_dup1_dip_one_to_one_instr" = ; MIdip { instr = MI1 Not } ; MIpush (mt_string, MLiteral.string "continuation") ]; - [%expect {| + [%expect + {| { DUP ; DIP { NOT } ; PUSH string "continuation" } -> { DUP ; NOT ; SWAP ; PUSH string "continuation" } |}] +;; let%expect_test "main_push_literal_some" = test_instructions @@ -2073,10 +1997,12 @@ let%expect_test "main_push_literal_some" = ; MI1 Some_ ; MIpush (mt_string, MLiteral.string "after some") ]; - [%expect {| + [%expect + {| { PUSH nat 123 ; SOME ; PUSH string "after some" } -> { PUSH nat 123 ; SOME ; PUSH string "after some" } |}] +;; let%expect_test "main_push_literal_left" = test_instructions @@ -2088,6 +2014,7 @@ let%expect_test "main_push_literal_left" = { PUSH nat 42 ; LEFT %annot_left string ; DROP } -> {} |}] +;; let%expect_test "main_push_literal_right" = test_instructions @@ -2095,10 +2022,12 @@ let%expect_test "main_push_literal_right" = ; MI1 (Right (None, Some "annot_right", mt_nat)) ; MIdrop ]; - [%expect{| + [%expect + {| { PUSH string "right side" ; RIGHT %annot_right nat ; DROP } -> {} |}] +;; let%expect_test "main_push_push_pair" = test_instructions @@ -2107,22 +2036,26 @@ let%expect_test "main_push_push_pair" = ; MI2 (Pair (Some "fst", Some "snd")) ; MIdrop ]; - [%expect {| + [%expect + {| { PUSH int 10 ; PUSH string "xyz" ; PAIR %fst %snd ; DROP } -> {} |}] +;; let%expect_test "main_push_push_pair_with_comment" = test_instructions [ MIpush (mt_string, MLiteral.string "ab") - ; MIcomment ["some annotation"] + ; MIcomment [ "some annotation" ] ; MIpush (mt_nat, MLiteral.small_int 66) ; MI2 (Pair (None, None)) ]; - [%expect {| + [%expect + {| { PUSH string "ab" ; PUSH nat 66 ; PAIR } -> { PUSH string "ab" ; PUSH nat 66 ; PAIR } |}] +;; let%expect_test "main_push_pair_then_mifield_a" = test_instructions @@ -2132,10 +2065,12 @@ let%expect_test "main_push_pair_then_mifield_a" = ; MIfield [ A; D ] ; MIpush (mt_string, MLiteral.string "rest") ]; - [%expect {| + [%expect + {| { PUSH (pair int bool) (Pair 123 True) ; CAR ; CDR ; PUSH string "rest" } -> { PUSH int 123 ; CDR ; PUSH string "rest" } |}] +;; let%expect_test "main_push_pair_then_mifield_d" = test_instructions @@ -2145,10 +2080,12 @@ let%expect_test "main_push_pair_then_mifield_d" = ; MIfield [ D ] ; MIpush (mt_bool, MLiteral.bool false) ]; - [%expect {| + [%expect + {| { PUSH (pair nat string) (Pair 999 "D-part") ; CDR ; PUSH bool False } -> { PUSH string "D-part" ; PUSH bool False } |}] +;; let%expect_test "main_nil_push_cons_single_element_list" = test_instructions @@ -2157,10 +2094,12 @@ let%expect_test "main_nil_push_cons_single_element_list" = ; MI2 Cons ; MIpush (mt_string, MLiteral.string "post") ]; - [%expect {| + [%expect + {| { NIL string ; PUSH string "hello" ; CONS ; PUSH string "post" } -> { NIL string ; PUSH string "hello" ; CONS ; PUSH string "post" } |}] +;; let%expect_test "main_double_nil_iter_cons_pattern" = test_instructions @@ -2168,11 +2107,12 @@ let%expect_test "main_double_nil_iter_cons_pattern" = ; MIdig 1 ; MI0 (Nil mt_nat) ; MIdig 1 - ; MIiter { instr = MI2 Cons } - ; MIiter { instr = MI2 Cons } + ; MIiter { instr = MI2 Cons } + ; MIiter { instr = MI2 Cons } ; MIpush (mt_nat, MLiteral.small_int 123) ]; - [%expect {| + [%expect + {| { NIL nat ; DIG 1 ; NIL nat ; @@ -2187,18 +2127,21 @@ let%expect_test "main_double_nil_iter_cons_pattern" = ITER { CONS } ; ITER { CONS } ; PUSH nat 123 } |}] +;; let%expect_test "main_push_seq_then_push_elem_cons" = test_instructions - [ MIpush (mt_list mt_string, MLiteral.list [MLiteral.string "world"]) + [ MIpush (mt_list mt_string, MLiteral.list [ MLiteral.string "world" ]) ; MIpush (mt_string, MLiteral.string "hello") ; MI2 Cons ; MIdrop ]; - [%expect {| + [%expect + {| { PUSH (list string) { "world" } ; PUSH string "hello" ; CONS ; DROP } -> {} |}] +;; let%expect_test "main_push_bool_not" = test_instructions @@ -2206,10 +2149,12 @@ let%expect_test "main_push_bool_not" = ; MI1 Not ; MIpush (mt_string, MLiteral.string "done") ]; - [%expect {| + [%expect + {| { PUSH bool True ; NOT ; PUSH string "done" } -> { PUSH bool False ; PUSH string "done" } |}] +;; let%expect_test "main_push_bool_and" = test_instructions @@ -2218,10 +2163,12 @@ let%expect_test "main_push_bool_and" = ; MI2 And ; MIpush (mt_string, MLiteral.string "rest") ]; - [%expect {| + [%expect + {| { PUSH bool True ; PUSH bool False ; AND ; PUSH string "rest" } -> { PUSH bool False ; PUSH string "rest" } |}] +;; let%expect_test "main_push_bool_or" = test_instructions @@ -2234,17 +2181,17 @@ let%expect_test "main_push_bool_or" = { PUSH bool False ; PUSH bool True ; OR ; DROP } -> {} |}] +;; let%expect_test "main_get_and_update_drop" = test_instructions - [ MI3 Get_and_update - ; MIdrop - ; MIpush (mt_int, MLiteral.small_int 999) - ]; - [%expect {| + [ MI3 Get_and_update; MIdrop; MIpush (mt_int, MLiteral.small_int 999) ]; + [%expect + {| { GET_AND_UPDATE ; DROP ; PUSH int 999 } -> { UPDATE ; PUSH int 999 } |}] +;; let%expect_test "main_pair_then_mifield_d" = test_instructions @@ -2252,15 +2199,17 @@ let%expect_test "main_pair_then_mifield_d" = ; MIfield [ D; A ] ; MIpush (mt_string, MLiteral.string "more instructions") ]; - [%expect {| + [%expect + {| { PAIR ; CDR ; CAR ; PUSH string "more instructions" } -> { DROP ; CAR ; PUSH string "more instructions" } |}] +;; let%expect_test "main_pair_comment_mifield_d" = test_instructions [ MI2 (Pair (Some "fst", Some "snd")) - ; MIcomment ["some comment"] + ; MIcomment [ "some comment" ] ; MIfield [ D ] ; MIdrop ]; @@ -2268,6 +2217,7 @@ let%expect_test "main_pair_comment_mifield_d" = { PAIR %fst %snd ; CDR ; DROP } -> { DROP 2 } |}] +;; let%expect_test "main_pair_then_mifield_a" = test_instructions @@ -2275,54 +2225,53 @@ let%expect_test "main_pair_then_mifield_a" = ; MIfield [ A; D ] ; MIpush (mt_string, MLiteral.string "rest code") ]; - [%expect {| + [%expect + {| { PAIR ; CAR ; CDR ; PUSH string "rest code" } -> { SWAP ; DROP ; CDR ; PUSH string "rest code" } |}] +;; let%expect_test "main_pair_comment_mifield_a" = test_instructions [ MI2 (Pair (Some "x", Some "y")) - ; MIcomment ["comment inside"] + ; MIcomment [ "comment inside" ] ; MIfield [ A ] ; MIpush (mt_bool, MLiteral.bool true) ]; - [%expect {| + [%expect + {| { PAIR %x %y ; CAR ; PUSH bool True } -> { SWAP ; DROP ; PUSH bool True } |}] +;; let%expect_test "main_mifield_concat" = test_instructions - [ MIfield [ A; D ] - ; MIfield [ A ] - ; MIpush (mt_nat, MLiteral.small_int 99) - ]; - [%expect {| + [ MIfield [ A; D ]; MIfield [ A ]; MIpush (mt_nat, MLiteral.small_int 99) ]; + [%expect + {| { CAR ; CDR ; CAR ; PUSH nat 99 } -> { CAR ; GET 3 ; PUSH nat 99 } |}] +;; let%expect_test "main_mifield_empty" = - test_instructions - [ MIfield [] - ; MIpush (mt_nat, MLiteral.small_int 2023) - ]; + test_instructions [ MIfield []; MIpush (mt_nat, MLiteral.small_int 2023) ]; [%expect {| { PUSH nat 2023 } -> { PUSH nat 2023 } |}] +;; let%expect_test "main_push_false_loop" = test_instructions - [ MIpush (mt_bool, MLiteral.bool false) - ; MIloop { instr = MI2 Sub } - ; MIdrop - ]; + [ MIpush (mt_bool, MLiteral.bool false); MIloop { instr = MI2 Sub }; MIdrop ]; [%expect {| { PUSH bool False ; LOOP { SUB } ; DROP } -> { DROP } |}] +;; let%expect_test "main_push_right_loop_left" = test_instructions @@ -2330,21 +2279,22 @@ let%expect_test "main_push_right_loop_left" = ; MIloop_left { instr = MIswap } ; MIpush (mt_string, MLiteral.string "continuation") ]; - [%expect {| + [%expect + {| { RIGHT int ; LOOP_LEFT { SWAP } ; PUSH string "continuation" } -> { PUSH string "continuation" } |}] +;; let%expect_test "main_dup1_dip_dup1" = test_instructions - [ MIdup 1 - ; MIdip { instr = MIdup 1 } - ; MIpush (mt_nat, MLiteral.small_int 77) - ]; - [%expect {| + [ MIdup 1; MIdip { instr = MIdup 1 }; MIpush (mt_nat, MLiteral.small_int 77) ]; + [%expect + {| { DUP ; DIP { DUP } ; PUSH nat 77 } -> { DUP ; DUP ; PUSH nat 77 } |}] +;; let%expect_test "main_dup1_dip_drop" = test_instructions @@ -2352,91 +2302,71 @@ let%expect_test "main_dup1_dip_drop" = ; MIdip { instr = MIdrop } ; MIpush (mt_string, MLiteral.string "post dip drop") ]; - [%expect {| + [%expect + {| { DUP ; DIP { DROP } ; PUSH string "post dip drop" } -> { PUSH string "post dip drop" } |}] +;; let%expect_test "main_dig1_commutative_binop" = - test_instructions - [ MIdig 1 - ; MI2 Add - ; MIdrop - ]; + test_instructions [ MIdig 1; MI2 Add; MIdrop ]; [%expect {| { DIG 1 ; ADD ; DROP } -> { ADD ; DROP } |}] +;; let%expect_test "main_dig1_compare_eq" = test_instructions - [ MIdig 1 - ; MI2 Compare - ; MI1 Eq - ; MIpush (mt_string, MLiteral.string "rest") - ]; - [%expect {| + [ MIdig 1; MI2 Compare; MI1 Eq; MIpush (mt_string, MLiteral.string "rest") ]; + [%expect + {| { DIG 1 ; COMPARE ; EQ ; PUSH string "rest" } -> { COMPARE ; EQ ; PUSH string "rest" } |}] +;; let%expect_test "main_dig1_compare_neq" = - test_instructions - [ MIdig 1 - ; MI2 Compare - ; MI1 Neq - ; MIdrop - ]; + test_instructions [ MIdig 1; MI2 Compare; MI1 Neq; MIdrop ]; [%expect {| { DIG 1 ; COMPARE ; NEQ ; DROP } -> { DROP 2 } |}] +;; let%expect_test "main_eq_not_to_neq" = - test_instructions - [ MI1 Eq - ; MI1 Not - ; MIpush (mt_int, MLiteral.small_int 200) - ]; + test_instructions [ MI1 Eq; MI1 Not; MIpush (mt_int, MLiteral.small_int 200) ]; [%expect {| { EQ ; NOT ; PUSH int 200 } -> { NEQ ; PUSH int 200 } |}] +;; let%expect_test "main_neq_not_to_eq" = - test_instructions - [ MI1 Neq - ; MI1 Not - ; MIpush (mt_int, MLiteral.small_int 111) - ]; + test_instructions [ MI1 Neq; MI1 Not; MIpush (mt_int, MLiteral.small_int 111) ]; [%expect {| { NEQ ; NOT ; PUSH int 111 } -> { EQ ; PUSH int 111 } |}] +;; let%expect_test "main_dig1_compare_lt" = - test_instructions - [ MIdig 1 - ; MI2 Compare - ; MI1 Lt - ; MIdrop - ]; + test_instructions [ MIdig 1; MI2 Compare; MI1 Lt; MIdrop ]; [%expect {| { DIG 1 ; COMPARE ; LT ; DROP } -> { DROP 2 } |}] +;; let%expect_test "main_dig1_compare_gt" = - test_instructions - [ MIdig 1 - ; MI2 Compare - ; MI1 Gt - ; MIpush (mt_bool, MLiteral.bool true) - ]; - [%expect {| + test_instructions [ MIdig 1; MI2 Compare; MI1 Gt; MIpush (mt_bool, MLiteral.bool true) ]; + [%expect + {| { DIG 1 ; COMPARE ; GT ; PUSH bool True } -> { COMPARE ; LT ; PUSH bool True } |}] +;; let%expect_test "main_bubble_up_drop_push_dig1_drop" = test_instructions @@ -2445,22 +2375,22 @@ let%expect_test "main_bubble_up_drop_push_dig1_drop" = ; MIdrop ; MIpush (mt_int, MLiteral.small_int 42) ]; - [%expect {| + [%expect + {| { PUSH string "hello" ; DIG 1 ; DROP ; PUSH int 42 } -> { DROP ; PUSH string "hello" ; PUSH int 42 } |}] +;; let%expect_test "main_bubble_up_drop_dig1_double_drop" = test_instructions - [ MIdig 1 - ; MIdrop - ; MIdrop - ; MIpush (mt_string, MLiteral.string "done") - ]; - [%expect {| + [ MIdig 1; MIdrop; MIdrop; MIpush (mt_string, MLiteral.string "done") ]; + [%expect + {| { DIG 1 ; DROP ; DROP ; PUSH string "done" } -> { DROP 2 ; PUSH string "done" } |}] +;; let%expect_test "main_bubble_up_drop_dip" = test_instructions @@ -2468,10 +2398,12 @@ let%expect_test "main_bubble_up_drop_dip" = ; MIdrop ; MIpush (mt_string, MLiteral.string "rest code") ]; - [%expect {| + [%expect + {| { DIP { PUSH nat 99 } ; DROP ; PUSH string "rest code" } -> { DROP ; PUSH nat 99 ; PUSH string "rest code" } |}] +;; let%expect_test "main_bubble_up_dip_after_one_to_one_mono" = test_instructions @@ -2479,10 +2411,12 @@ let%expect_test "main_bubble_up_dip_after_one_to_one_mono" = ; MIdip { instr = MIseq [ mk (MIpush (mt_int, MLiteral.small_int 123)) ] } ; MIdrop ]; - [%expect {| + [%expect + {| { NOT ; DIP { PUSH int 123 } ; DROP } -> { DROP ; PUSH int 123 } |}] +;; let%expect_test "main_bubble_up_dip_push" = test_instructions @@ -2490,22 +2424,21 @@ let%expect_test "main_bubble_up_dip_push" = ; MIdip { instr = MIseq [ mk (MIpush (mt_bool, MLiteral.bool true)) ] } ; MIpush (mt_int, MLiteral.small_int 10) ]; - [%expect {| + [%expect + {| { PUSH string "pushed" ; DIP { PUSH bool True } ; PUSH int 10 } -> { PUSH bool True ; PUSH string "pushed" ; PUSH int 10 } |}] +;; let%expect_test "main_bubble_up_swap_push_mono" = - test_instructions - [ MIpush (mt_nat, MLiteral.small_int 777) - ; MIdig 1 - ; MI1 Not - ; MIdrop - ]; - [%expect {| + test_instructions [ MIpush (mt_nat, MLiteral.small_int 777); MIdig 1; MI1 Not; MIdrop ]; + [%expect + {| { PUSH nat 777 ; DIG 1 ; NOT ; DROP } -> { DROP ; PUSH nat 777 } |}] +;; let%expect_test "main_double_swap_bubble" = test_instructions @@ -2515,15 +2448,17 @@ let%expect_test "main_double_swap_bubble" = ; MIdig 1 ; MIpush (mt_string, MLiteral.string "continuation") ]; - [%expect {| + [%expect + {| { NOT ; DIG 1 ; NEG ; DIG 1 ; PUSH string "continuation" } -> { SWAP ; NEG ; SWAP ; NOT ; PUSH string "continuation" } |}] +;; let%expect_test "main_dig_dug_same_n_with_comment" = test_instructions [ MIdig 2 - ; MIcomment ["some comment"] + ; MIcomment [ "some comment" ] ; MIdug 2 ; MIpush (mt_int, MLiteral.small_int 42) ]; @@ -2531,18 +2466,17 @@ let%expect_test "main_dig_dug_same_n_with_comment" = { DIG 2 ; DUG 2 ; PUSH int 42 } -> { PUSH int 42 } |}] +;; let%expect_test "main_multiple_dig_drops" = test_instructions - [ MIdig 3 - ; MIdig 2 - ; MIdrop - ; MIpush (mt_string, MLiteral.string "rest") - ]; - [%expect {| + [ MIdig 3; MIdig 2; MIdrop; MIpush (mt_string, MLiteral.string "rest") ]; + [%expect + {| { DIG 3 ; DIG 2 ; DROP ; PUSH string "rest" } -> { SWAP ; DROP ; DIG 2 ; PUSH string "rest" } |}] +;; let%expect_test "main_push_dig_drop_n_greater_one" = test_instructions @@ -2551,195 +2485,162 @@ let%expect_test "main_push_dig_drop_n_greater_one" = ; MIdrop ; MIpush (mt_string, MLiteral.string "foo") ]; - [%expect {| + [%expect + {| { PUSH bool True ; DIG 2 ; DROP ; PUSH string "foo" } -> { SWAP ; DROP ; PUSH bool True ; PUSH string "foo" } |}] +;; let%expect_test "main_dup1_dig_drop" = - test_instructions - [ MIdup 1 - ; MIdig 3 - ; MIdrop - ; MIdrop - ]; + test_instructions [ MIdup 1; MIdig 3; MIdrop; MIdrop ]; [%expect {| { DUP ; DIG 3 ; DROP ; DROP } -> { DIG 2 ; DROP } |}] +;; let%expect_test "main_dup_k_dig_n_drop_variants" = - test_instructions - [ MIdup 2 - ; MIdig 3 - ; MIdrop - ; MIpush (mt_unit, MLiteral.unit) - ]; - [%expect {| + test_instructions [ MIdup 2; MIdig 3; MIdrop; MIpush (mt_unit, MLiteral.unit) ]; + [%expect + {| { DUP 2 ; DIG 3 ; DROP ; PUSH unit Unit } -> { DIG 2 ; DROP ; DUP 2 ; UNIT } |}] +;; let%expect_test "main_dup_k_dig_n_eq" = - test_instructions - [ MIdup 3 - ; MIdig 3 - ; MIpush (mt_nat, MLiteral.small_int 999) - ]; - [%expect {| + test_instructions [ MIdup 3; MIdig 3; MIpush (mt_nat, MLiteral.small_int 999) ]; + [%expect + {| { DUP 3 ; DIG 3 ; PUSH nat 999 } -> { DIG 2 ; DUP ; PUSH nat 999 } |}] +;; let%expect_test "main_dug_n1_mono_dig_n2" = test_instructions - [ MIdug 3 - ; MI1 Not - ; MIdig 3 - ; MIpush (mt_string, MLiteral.string "done") - ]; - [%expect {| + [ MIdug 3; MI1 Not; MIdig 3; MIpush (mt_string, MLiteral.string "done") ]; + [%expect + {| { DUG 3 ; NOT ; DIG 3 ; PUSH string "done" } -> { SWAP ; NOT ; SWAP ; PUSH string "done" } |}] +;; let%expect_test "main_dig_n_dig1_mono_dig1" = - test_instructions - [ MIdig 2 - ; MIdig 1 - ; MI1 Neg - ; MIdig 1 - ; MIdrop - ]; - [%expect {| + test_instructions [ MIdig 2; MIdig 1; MI1 Neg; MIdig 1; MIdrop ]; + [%expect + {| { DIG 2 ; DIG 1 ; NEG ; DIG 1 ; DROP } -> { DIG 2 ; DROP ; NEG } |}] +;; let%expect_test "main_dug_midig_drop_mixed" = test_instructions - [ MIdug 3 - ; MIdig 1 - ; MIdrop - ; MIpush (mt_string, MLiteral.string "rest code") - ]; - [%expect {| + [ MIdug 3; MIdig 1; MIdrop; MIpush (mt_string, MLiteral.string "rest code") ]; + [%expect + {| { DUG 3 ; DIG 1 ; DROP ; PUSH string "rest code" } -> { DIG 2 ; DROP ; DUG 2 ; PUSH string "rest code" } |}] +;; let%expect_test "main_2_1_binop_dig_drop" = test_instructions - [ MI2 Concat2 - ; MIdig 2 - ; MIdrop - ; MIpush (mt_string, MLiteral.string "final") - ]; - [%expect {| + [ MI2 Concat2; MIdig 2; MIdrop; MIpush (mt_string, MLiteral.string "final") ]; + [%expect + {| { CONCAT ; DIG 2 ; DROP ; PUSH string "final" } -> { CONCAT ; DIG 2 ; DROP ; PUSH string "final" } |}] +;; let%expect_test "main_1_2_instr_dig_drop" = test_instructions - [ MIunpair [true; true] - ; MIdig 3 - ; MIdrop - ; MIpush (mt_bool, MLiteral.bool true) - ]; - [%expect{| + [ MIunpair [ true; true ]; MIdig 3; MIdrop; MIpush (mt_bool, MLiteral.bool true) ]; + [%expect + {| { UNPAIR ; DIG 3 ; DROP ; PUSH bool True } -> { DIG 2 ; DROP ; UNPAIR ; PUSH bool True } |}] +;; let%expect_test "main_1_2_instr_dig1_drop_dig_n_drop" = - test_instructions - [ MIunpair [true; true] - ; MIdig 1 - ; MIdrop - ; MIdig 2 - ; MIdrop - ; MIdrop - ]; - [%expect {| + test_instructions [ MIunpair [ true; true ]; MIdig 1; MIdrop; MIdig 2; MIdrop; MIdrop ]; + [%expect + {| { UNPAIR ; DIG 1 ; DROP ; DIG 2 ; DROP ; DROP } -> { DIG 2 ; DROP 2 } |}] +;; let%expect_test "main_1_2_instr_drop_drop" = test_instructions - [ MIpairn 2 - ; MIdig 1 - ; MIdrop - ; MIdrop - ; MIpush (mt_string, MLiteral.string "rest") - ]; - [%expect {| + [ MIpairn 2; MIdig 1; MIdrop; MIdrop; MIpush (mt_string, MLiteral.string "rest") ]; + [%expect + {| { PAIR 2 ; DIG 1 ; DROP ; DROP ; PUSH string "rest" } -> { DROP 3 ; PUSH string "rest" } |}] +;; let%expect_test "main_1_2_instr_drop_drop_second" = test_instructions - [ MIunpair [true; true] - ; MIdrop - ; MIdrop - ; MIpush (mt_int, MLiteral.small_int 42) - ]; - [%expect {| + [ MIunpair [ true; true ]; MIdrop; MIdrop; MIpush (mt_int, MLiteral.small_int 42) ]; + [%expect + {| { UNPAIR ; DROP ; DROP ; PUSH int 42 } -> { DROP ; PUSH int 42 } |}] +;; let%expect_test "main_1_2_instr_dig_drop_again" = - test_instructions - [ MIunpair [true; true] - ; MIdig 3 - ; MIdrop - ; MIdrop - ]; + test_instructions [ MIunpair [ true; true ]; MIdig 3; MIdrop; MIdrop ]; [%expect {| { UNPAIR ; DIG 3 ; DROP ; DROP } -> { DIG 2 ; DROP ; CDR } |}] +;; let%expect_test "main_pair_unpair_cancel" = test_instructions [ MI2 (Pair (None, None)) - ; MIunpair [true; true] + ; MIunpair [ true; true ] ; MIpush (mt_string, MLiteral.string "rest") ]; - [%expect {| + [%expect + {| { PAIR ; UNPAIR ; PUSH string "rest" } -> { PUSH string "rest" } |}] +;; let%expect_test "main_mipairn_unpair_alltrue" = - test_instructions - [ MIpairn 3 - ; MIunpair [true; true; true] - ; MIdrop - ]; + test_instructions [ MIpairn 3; MIunpair [ true; true; true ]; MIdrop ]; [%expect {| { PAIR 3 ; UNPAIR 3 ; DROP } -> { PAIR 3 ; CDR ; UNPAIR } |}] +;; let%expect_test "main_pair_comment_unpair_alltrue" = test_instructions [ MI2 (Pair (Some "a", Some "b")) - ; MIcomment ["some comment"] - ; MIunpair [true; true] + ; MIcomment [ "some comment" ] + ; MIunpair [ true; true ] ; MIpush (mt_nat, MLiteral.small_int 999) ]; [%expect {| { PAIR %a %b ; UNPAIR ; PUSH nat 999 } -> { PUSH nat 999 } |}] +;; let%expect_test "main_unpair_pair_cancel" = test_instructions - [ MIunpair [true; true] + [ MIunpair [ true; true ] ; MI2 (Pair (None, None)) ; MIpush (mt_bool, MLiteral.bool true) ]; @@ -2747,101 +2648,83 @@ let%expect_test "main_unpair_pair_cancel" = { UNPAIR ; PAIR ; PUSH bool True } -> { PUSH bool True } |}] +;; let%expect_test "main_read_ticket_drop" = test_instructions - [ MI1 Read_ticket - ; MIdrop - ; MIpush (mt_string, MLiteral.string "done") - ]; - [%expect {| + [ MI1 Read_ticket; MIdrop; MIpush (mt_string, MLiteral.string "done") ]; + [%expect + {| { READ_TICKET ; DROP ; PUSH string "done" } -> { PUSH string "done" } |}] +;; let%expect_test "main_dup1_mifield_d_dig1_mifield_a" = - test_instructions - [ MIdup 1 - ; MIfield [ D ] - ; MIdig 1 - ; MIfield [ A ] - ; MIdrop - ]; + test_instructions [ MIdup 1; MIfield [ D ]; MIdig 1; MIfield [ A ]; MIdrop ]; [%expect {| { DUP ; CDR ; DIG 1 ; CAR ; DROP } -> { CDR } |}] +;; let%expect_test "main_dup1_mifield_a_dig1_mifield_d" = test_instructions - [ MIdup 1 - ; MIfield [ A ] - ; MIdig 1 - ; MIfield [ D ] - ; MIpush (mt_unit, MLiteral.unit) - ]; - [%expect {| + [ MIdup 1; MIfield [ A ]; MIdig 1; MIfield [ D ]; MIpush (mt_unit, MLiteral.unit) ]; + [%expect + {| { DUP ; CAR ; DIG 1 ; CDR ; PUSH unit Unit } -> { UNPAIR ; SWAP ; UNIT } |}] +;; let%expect_test "main_ternary_instr_midig_drop" = test_instructions - [ MI3 Update - ; MIdig 2 - ; MIdrop - ; MIpush (mt_string, MLiteral.string "rest") - ]; - [%expect {| + [ MI3 Update; MIdig 2; MIdrop; MIpush (mt_string, MLiteral.string "rest") ]; + [%expect + {| { UPDATE ; DIG 2 ; DROP ; PUSH string "rest" } -> { DIG 4 ; DROP ; UPDATE ; PUSH string "rest" } |}] +;; let%expect_test "main_ternary_3_2_midig_drop" = - test_instructions - [ MI2 Split_ticket - ; MIdig 2 - ; MIdrop - ; MIdrop - ]; + test_instructions [ MI2 Split_ticket; MIdig 2; MIdrop; MIdrop ]; [%expect {| { SPLIT_TICKET ; DIG 2 ; DROP ; DROP } -> { DIG 3 ; DROP 3 } |}] +;; let%expect_test "main_comment_push_fail_reorder" = test_instructions - [ MIcomment ["some comment"] + [ MIcomment [ "some comment" ] ; MIpush (mt_string, MLiteral.string "error msg") ; MI1_fail Failwith ; MIdrop ]; - [%expect {| + [%expect + {| { PUSH string "error msg" ; FAILWITH ; DROP } -> { PUSH string "error msg" ; FAILWITH } |}] +;; let%expect_test "main_dup1_then_fail_redundant" = - test_instructions - [ MIdup 1 - ; MI1_fail Never - ; MIpush (mt_nat, MLiteral.small_int 100) - ]; + test_instructions [ MIdup 1; MI1_fail Never; MIpush (mt_nat, MLiteral.small_int 100) ]; [%expect {| { DUP ; NEVER ; PUSH nat 100 } -> { NEVER } |}] +;; let%expect_test "main_dup1_then_failwith" = - test_instructions - [ MIdup 1 - ; MI1_fail Failwith - ; MIdrop - ]; + test_instructions [ MIdup 1; MI1_fail Failwith; MIdrop ]; [%expect {| { DUP ; FAILWITH ; DROP } -> { FAILWITH } |}] +;; let%expect_test "main_dug_n_pair_exec_fail" = test_instructions @@ -2851,10 +2734,12 @@ let%expect_test "main_dug_n_pair_exec_fail" = ; MI1_fail Failwith ; MIpush (mt_string, MLiteral.string "unreachable") ]; - [%expect {| + [%expect + {| { DUG 3 ; PAIR ; EXEC ; FAILWITH ; PUSH string "unreachable" } -> { DROP ; PAIR ; EXEC ; FAILWITH } |}] +;; let%expect_test "main_dug_n_push_midig_k_pair_exec_fail" = test_instructions @@ -2866,7 +2751,8 @@ let%expect_test "main_dug_n_push_midig_k_pair_exec_fail" = ; MI1_fail Failwith ; MIdrop ]; - [%expect {| + [%expect + {| { DUG 3 ; PUSH string "lazy error string" ; DIG 3 ; @@ -2876,11 +2762,12 @@ let%expect_test "main_dug_n_push_midig_k_pair_exec_fail" = DROP } -> { DROP ; PUSH string "lazy error string" ; DIG 3 ; PAIR ; EXEC ; FAILWITH } |}] +;; let%expect_test "main_create_contract_dig_drop" = test_instructions [ MIcreate_contract - { tparameter = (mt_nat, None) + { tparameter = mt_nat, None ; tstorage = mt_string ; code = { instr = MIdrop } ; views = [] @@ -2889,7 +2776,8 @@ let%expect_test "main_create_contract_dig_drop" = ; MIdrop ; MIpush (mt_string, MLiteral.string "post-create") ]; - [%expect {| + [%expect + {| { CREATE_CONTRACT { parameter nat ; storage string ; code { DROP } } ; DIG 2 ; DROP ; @@ -2899,22 +2787,24 @@ let%expect_test "main_create_contract_dig_drop" = DROP ; CREATE_CONTRACT { parameter nat ; storage string ; code { DROP } } ; PUSH string "post-create" } |}] +;; let%expect_test "main_create_contract_output_ad_hoc" = test_instructions [ MI2 (Pair (Some "fst", Some "snd")) - ; MIcomment ["some comment"] + ; MIcomment [ "some comment" ] ; MIdup 1 ; MIfield [ A ] ; MI0 (Nil mt_operation) ; MIdig 1 ; MI2 Cons - ; MIcomment ["another comment"] + ; MIcomment [ "another comment" ] ; MIdig 1 ; MIfield [ D ] ; MIpush (mt_nat, MLiteral.small_int 404) ]; - [%expect {| + [%expect + {| { PAIR %fst %snd ; DUP ; CAR ; @@ -2926,52 +2816,42 @@ let%expect_test "main_create_contract_output_ad_hoc" = PUSH nat 404 } -> { NIL operation ; SWAP ; CONS ; SWAP ; PUSH nat 404 } |}] +;; let%expect_test "main_comment_drop_reorder" = test_instructions - [ MIcomment ["some cmt"] - ; MIdrop - ; MIpush (mt_string, MLiteral.string "rest") - ]; - [%expect {| + [ MIcomment [ "some cmt" ]; MIdrop; MIpush (mt_string, MLiteral.string "rest") ]; + [%expect + {| { DROP ; PUSH string "rest" } -> { DROP ; PUSH string "rest" } |}] +;; let%expect_test "main_comment_dig1_reorder" = - test_instructions - [ MIcomment ["cc"] - ; MIdig 1 - ; MIpush (mt_bool, MLiteral.bool false) - ]; + test_instructions [ MIcomment [ "cc" ]; MIdig 1; MIpush (mt_bool, MLiteral.bool false) ]; [%expect {| { DIG 1 ; PUSH bool False } -> { SWAP ; PUSH bool False } |}] +;; let%expect_test "main_comment_dig_n_drop_reorder" = - test_instructions - [ MIcomment ["c"] - ; MIdig 3 - ; MIdrop - ; MIdrop - ]; + test_instructions [ MIcomment [ "c" ]; MIdig 3; MIdrop; MIdrop ]; [%expect {| { DIG 3 ; DROP ; DROP } -> { DIG 3 ; DROP 2 } |}] +;; let%expect_test "main_mono_dig_drop" = - test_instructions - [ MI1 Not - ; MIdig 2 - ; MIdrop - ; MIpush (mt_nat, MLiteral.small_int 999) - ]; - [%expect {| + test_instructions [ MI1 Not; MIdig 2; MIdrop; MIpush (mt_nat, MLiteral.small_int 999) ]; + [%expect + {| { NOT ; DIG 2 ; DROP ; PUSH nat 999 } -> { DIG 2 ; DROP ; NOT ; PUSH nat 999 } |}] +;; let%expect_test "main_iter_cons_dig_drop" = test_instructions @@ -2980,10 +2860,12 @@ let%expect_test "main_iter_cons_dig_drop" = ; MIdrop ; MIpush (mt_string, MLiteral.string "done") ]; - [%expect {| + [%expect + {| { ITER { CONS } ; DIG 2 ; DROP ; PUSH string "done" } -> { DIG 3 ; DROP ; ITER { CONS } ; PUSH string "done" } |}] +;; let%expect_test "main_push_dig1_iter_cons_dig1_drop" = test_instructions @@ -2994,7 +2876,8 @@ let%expect_test "main_push_dig1_iter_cons_dig1_drop" = ; MIdrop ; MIpush (mt_string, MLiteral.string "rest") ]; - [%expect {| + [%expect + {| { PUSH int 123 ; DIG 1 ; ITER { CONS } ; @@ -3003,40 +2886,34 @@ let%expect_test "main_push_dig1_iter_cons_dig1_drop" = PUSH string "rest" } -> { SWAP ; DROP ; PUSH int 123 ; SWAP ; ITER { CONS } ; PUSH string "rest" } |}] +;; let%expect_test "main_dug_n_drop" = - test_instructions - [ MIdug 2 - ; MIdrop - ; MIpush (mt_string, MLiteral.string "post") - ]; - [%expect {| + test_instructions [ MIdug 2; MIdrop; MIpush (mt_string, MLiteral.string "post") ]; + [%expect + {| { DUG 2 ; DROP ; PUSH string "post" } -> { SWAP ; DROP ; SWAP ; PUSH string "post" } |}] +;; let%expect_test "main_dup1_dug_n_drop" = test_instructions - [ MIdup 1 - ; MIdug 2 - ; MIdrop - ; MIpush (mt_string, MLiteral.string "rest") - ]; - [%expect {| + [ MIdup 1; MIdug 2; MIdrop; MIpush (mt_string, MLiteral.string "rest") ]; + [%expect + {| { DUP ; DUG 2 ; DROP ; PUSH string "rest" } -> { SWAP ; PUSH string "rest" } |}] +;; let%expect_test "main_dup1_dip_dig1" = - test_instructions - [ MIdup 1 - ; MIdip { instr = MIdig 1 } - ; MIdrop - ]; + test_instructions [ MIdup 1; MIdip { instr = MIdig 1 }; MIdrop ]; [%expect {| { DUP ; DIP { DIG 1 } ; DROP } -> { SWAP } |}] +;; let%expect_test "main_push_dig1_dup1_dug2" = test_instructions @@ -3046,37 +2923,30 @@ let%expect_test "main_push_dig1_dup1_dug2" = ; MIdug 2 ; MIpush (mt_string, MLiteral.string "rest") ]; - [%expect {| + [%expect + {| { PUSH nat 321 ; DIG 1 ; DUP ; DUG 2 ; PUSH string "rest" } -> { PUSH nat 321 ; DUP 2 ; PUSH string "rest" } |}] +;; let%expect_test "main_dup1_push_binop_dig1_drop" = test_instructions - [ MIdup 1 - ; MIpush (mt_int, MLiteral.small_int 444) - ; MI2 Add - ; MIdig 1 - ; MIdrop - ; MIdrop - ]; - [%expect {| + [ MIdup 1; MIpush (mt_int, MLiteral.small_int 444); MI2 Add; MIdig 1; MIdrop; MIdrop ]; + [%expect + {| { DUP ; PUSH int 444 ; ADD ; DIG 1 ; DROP ; DROP } -> { PUSH int 444 ; ADD ; DROP } |}] +;; let%expect_test "main_complex_dig_dug_interplay" = - test_instructions - [ MIdig 2 - ; MIdig 1 - ; MIdup 1 - ; MIdug 1 - ; MIdrop - ]; + test_instructions [ MIdig 2; MIdig 1; MIdup 1; MIdug 1; MIdrop ]; [%expect {| { DIG 2 ; DIG 1 ; DUP ; DUG 1 ; DROP } -> { DIG 2 ; SWAP } |}] +;; let%expect_test "main_constant_folding_compare" = test_instructions @@ -3089,6 +2959,7 @@ let%expect_test "main_constant_folding_compare" = { PUSH int 3 ; PUSH int 10 ; COMPARE ; DROP } -> {} |}] +;; let%expect_test "main_constant_folding_int_eq" = test_instructions @@ -3096,21 +2967,20 @@ let%expect_test "main_constant_folding_int_eq" = ; MI1 Eq ; MIpush (mt_string, MLiteral.string "done") ]; - [%expect {| + [%expect + {| { PUSH int 0 ; EQ ; PUSH string "done" } -> { PUSH bool True ; PUSH string "done" } |}] +;; let%expect_test "main_constant_folding_int_gt" = - test_instructions - [ MIpush (mt_int, MLiteral.small_int 1) - ; MI1 Gt - ; MIdrop - ]; + test_instructions [ MIpush (mt_int, MLiteral.small_int 1); MI1 Gt; MIdrop ]; [%expect {| { PUSH int 1 ; GT ; DROP } -> {} |}] +;; let%expect_test "main_drop_before_push_failwith" = test_instructions @@ -3119,11 +2989,12 @@ let%expect_test "main_drop_before_push_failwith" = ; MI1_fail Failwith ; MIpush (mt_nat, MLiteral.small_int 123) ]; - [%expect {| + [%expect + {| { DROP ; PUSH string "some error" ; FAILWITH ; PUSH nat 123 } -> { PUSH string "some error" ; FAILWITH } |}] - +;; let%expect_test "main_dup2_field_d_dig2_field_a" = test_instructions @@ -3133,10 +3004,12 @@ let%expect_test "main_dup2_field_d_dig2_field_a" = ; MIfield [ A ] ; MIpush (mt_string, MLiteral.string "post") ]; - [%expect {| + [%expect + {| { DUP 2 ; CDR ; DIG 2 ; CAR ; PUSH string "post" } -> { SWAP ; UNPAIR ; PUSH string "post" } |}] +;; let%expect_test "main_swap_push_dig1" = test_instructions @@ -3145,118 +3018,92 @@ let%expect_test "main_swap_push_dig1" = ; MIdig 1 ; MIpush (mt_string, MLiteral.string "rest") ]; - [%expect {| + [%expect + {| { SWAP ; PUSH bool False ; DIG 1 ; PUSH string "rest" } -> { PUSH bool False ; DIG 2 ; PUSH string "rest" } |}] +;; let%expect_test "main_two_dig_with_drops_n1_gt_n2" = - test_instructions - [ MIdig 3 - ; MIdrop - ; MIdig 1 - ; MIdrop - ; MIpush (mt_unit, MLiteral.unit) - ]; - [%expect {| + test_instructions [ MIdig 3; MIdrop; MIdig 1; MIdrop; MIpush (mt_unit, MLiteral.unit) ]; + [%expect + {| { DIG 3 ; DROP ; DIG 1 ; DROP ; PUSH unit Unit } -> { SWAP ; DROP ; DIG 2 ; DROP ; UNIT } |}] - +;; let%expect_test "main_dig1_dup1_dug2" = - test_instructions - [ MIdig 1 - ; MIdup 1 - ; MIdug 2 - ; MIdrop - ]; + test_instructions [ MIdig 1; MIdup 1; MIdug 2; MIdrop ]; [%expect {| { DIG 1 ; DUP ; DUG 2 ; DROP } -> {} |}] +;; let%expect_test "main_dup2_dig1_drop" = test_instructions - [ MIdup 2 - ; MIdig 1 - ; MIdrop - ; MIpush (mt_string, MLiteral.string "rest") - ]; - [%expect {| + [ MIdup 2; MIdig 1; MIdrop; MIpush (mt_string, MLiteral.string "rest") ]; + [%expect + {| { DUP 2 ; DIG 1 ; DROP ; PUSH string "rest" } -> { DROP ; DUP ; PUSH string "rest" } |}] +;; let%expect_test "main_field_concatenation_second_test" = test_instructions - [ MIfield [ A; D ] - ; MIfield [ D; A ] - ; MIpush (mt_bool, MLiteral.bool true) - ]; - [%expect {| + [ MIfield [ A; D ]; MIfield [ D; A ]; MIpush (mt_bool, MLiteral.bool true) ]; + [%expect + {| { CAR ; CDR ; CDR ; CAR ; PUSH bool True } -> { CAR ; GET 5 ; PUSH bool True } |}] +;; let%expect_test "main_nat_neg" = - test_instructions - [ MIpush (mt_nat, MLiteral.small_int 5) - ; MI1 Neg - ; MIdrop - ]; + test_instructions [ MIpush (mt_nat, MLiteral.small_int 5); MI1 Neg; MIdrop ]; [%expect {| { PUSH nat 5 ; NEG ; DROP } -> {} |}] +;; let%expect_test "main_nat_int_neg" = - test_instructions - [ MIpush (mt_nat, MLiteral.small_int 12) - ; MI1 Int - ; MI1 Neg - ; MIdrop - ]; + test_instructions [ MIpush (mt_nat, MLiteral.small_int 12); MI1 Int; MI1 Neg; MIdrop ]; [%expect {| { PUSH nat 12 ; INT ; NEG ; DROP } -> {} |}] +;; let%expect_test "main_sub_rewriting_extended" = - test_instructions - [ MIpush (mt_int, MLiteral.small_int 10) - ; MIdig 1 - ; MI2 Sub - ; MIdrop - ]; - [%expect {| + test_instructions [ MIpush (mt_int, MLiteral.small_int 10); MIdig 1; MI2 Sub; MIdrop ]; + [%expect + {| { PUSH int 10 ; DIG 1 ; SUB ; DROP } -> { PUSH int -10 ; ADD ; DROP } |}] +;; let%expect_test "main_neg_dig1_add_to_sub" = test_instructions - [ MI1 Neg - ; MIdig 1 - ; MI2 Add - ; MIpush (mt_string, MLiteral.string "rest") - ]; - [%expect {| + [ MI1 Neg; MIdig 1; MI2 Add; MIpush (mt_string, MLiteral.string "rest") ]; + [%expect + {| { NEG ; DIG 1 ; ADD ; PUSH string "rest" } -> { NEG ; ADD ; PUSH string "rest" } |}] +;; let%expect_test "main_neg_dig1_sub_to_add" = - test_instructions - [ MI1 Neg - ; MIdig 1 - ; MI2 Sub - ; MIdrop - ]; + test_instructions [ MI1 Neg; MIdig 1; MI2 Sub; MIdrop ]; [%expect {| { NEG ; DIG 1 ; SUB ; DROP } -> { ADD ; DROP } |}] +;; let%expect_test "main_push_t_l_dup1" = test_instructions @@ -3264,10 +3111,12 @@ let%expect_test "main_push_t_l_dup1" = ; MIdup 1 ; MIpush (mt_bool, MLiteral.bool false) ]; - [%expect {| + [%expect + {| { PUSH string "dup me" ; DUP ; PUSH bool False } -> { PUSH string "dup me" ; DUP ; PUSH bool False } |}] +;; let%expect_test "main_lambda_dig1_exec" = test_instructions @@ -3276,123 +3125,107 @@ let%expect_test "main_lambda_dig1_exec" = ; MI2 Exec ; MIpush (mt_string, MLiteral.string "post-lambda") ]; - [%expect {| + [%expect + {| { LAMBDA int int { NEG } ; DIG 1 ; EXEC ; PUSH string "post-lambda" } -> { NEG ; PUSH string "post-lambda" } |}] +;; let%expect_test "main_push_instr_dig1_exec" = let lambda_body = { instr = MIseq [ mk (MIpush (mt_int, MLiteral.small_int 123)) ] } in test_instructions - [ MIpush - ( mt_lambda mt_unit mt_int - , MLiteral.instr lambda_body - ) + [ MIpush (mt_lambda mt_unit mt_int, MLiteral.instr lambda_body) ; MIdig 1 ; MI2 Exec ; MIdrop ]; - [%expect {| + [%expect + {| { PUSH (lambda unit int) { PUSH int 123 } ; DIG 1 ; EXEC ; DROP } -> { PUSH (lambda unit int) { PUSH int 123 } ; SWAP ; EXEC ; DROP } |}] +;; let%expect_test "main_dig_n_dup1_dug_n_plus_1" = - test_instructions - [ MIdig 2 - ; MIdup 1 - ; MIdug 3 - ; MIdrop - ]; + test_instructions [ MIdig 2; MIdup 1; MIdug 3; MIdrop ]; [%expect {| { DIG 2 ; DUP ; DUG 3 ; DROP } -> {} |}] +;; let%expect_test "main_dup_n_swap_drop" = test_instructions - [ MIdup 3 - ; MIswap - ; MIdrop - ; MIpush (mt_string, MLiteral.string "rest") - ]; - [%expect {| + [ MIdup 3; MIswap; MIdrop; MIpush (mt_string, MLiteral.string "rest") ]; + [%expect + {| { DUP 3 ; SWAP ; DROP ; PUSH string "rest" } -> { DROP ; DUP 2 ; PUSH string "rest" } |}] +;; let%expect_test "main_dup1_dup2" = - test_instructions - [ MIdup 1 - ; MIdup 2 - ; MIdrop - ]; + test_instructions [ MIdup 1; MIdup 2; MIdrop ]; [%expect {| { DUP ; DUP 2 ; DROP } -> { DUP } |}] +;; let%expect_test "main_dup1_dup1_f_push_dig3" = test_instructions [ MIdup 1 ; MIdup 1 - ; MI1 Not + ; MI1 Not ; MIpush (mt_int, MLiteral.small_int 123) ; MIdig 3 ; MIpush (mt_nat, MLiteral.small_int 77) ]; - [%expect {| + [%expect + {| { DUP ; DUP ; NOT ; PUSH int 123 ; DIG 3 ; PUSH nat 77 } -> { DUP ; NOT ; PUSH int 123 ; DUP 3 ; PUSH nat 77 } |}] +;; let%expect_test "main_self_none_address" = - test_instructions - [ MI0 (Self None) - ; MI1 Address - ; MIdrop - ]; + test_instructions [ MI0 (Self None); MI1 Address; MIdrop ]; [%expect {| { SELF ; ADDRESS ; DROP } -> {} |}] +;; - let%expect_test "main_1_2_instr_drop_drop" = +let%expect_test "main_1_2_instr_drop_drop" = test_instructions - [ MIpairn 2 - ; MIdrop - ; MIdrop - ; MIpush (mt_string, MLiteral.string "continuation") - ]; - [%expect {| + [ MIpairn 2; MIdrop; MIdrop; MIpush (mt_string, MLiteral.string "continuation") ]; + [%expect + {| { PAIR 2 ; DROP ; DROP ; PUSH string "continuation" } -> { DROP 3 ; PUSH string "continuation" } |}] +;; let%expect_test "main_1_2_instr_dig1_drop_drop" = test_instructions - [ MIpairn 2 - ; MIdig 1 - ; MIdrop - ; MIdrop - ; MIpush (mt_string, MLiteral.string "done") - ]; - [%expect {| + [ MIpairn 2; MIdig 1; MIdrop; MIdrop; MIpush (mt_string, MLiteral.string "done") ]; + [%expect + {| { PAIR 2 ; DIG 1 ; DROP ; DROP ; PUSH string "done" } -> { DROP 3 ; PUSH string "done" } |}] +;; let%expect_test "final_two_one_instr_double_drop_again" = test_instructions - [ MI2 (Pair (None, None)) - ; MIdrop - ; MIdrop - ; MIpush (mt_int, MLiteral.small_int 10) - ]; - [%expect {| + [ MI2 (Pair (None, None)); MIdrop; MIdrop; MIpush (mt_int, MLiteral.small_int 10) ]; + [%expect + {| { PAIR ; DROP ; DROP ; PUSH int 10 } -> { DROP 3 ; PUSH int 10 } |}] +;; let%expect_test "final_two_one_instr_drop_dig_drop_variant" = test_instructions @@ -3402,41 +3235,39 @@ let%expect_test "final_two_one_instr_drop_dig_drop_variant" = ; MIdrop ; MIpush (mt_string, MLiteral.string "after pattern") ]; - [%expect {| + [%expect + {| { COMPARE ; DROP ; DIG 2 ; DROP ; PUSH string "after pattern" } -> { DROP 2 ; DIG 2 ; DROP ; PUSH string "after pattern" } |}] +;; let%expect_test "final_three_one_instr_drop" = test_instructions - [ MI3 (Slice) - ; MIdrop - ; MIpush (mt_string, MLiteral.string "some next instr") - ]; - [%expect {| + [ MI3 Slice; MIdrop; MIpush (mt_string, MLiteral.string "some next instr") ]; + [%expect + {| { SLICE ; DROP ; PUSH string "some next instr" } -> { DROP 3 ; PUSH string "some next instr" } |}] +;; let%expect_test "final_remove_dip_drop" = - test_instructions - [ MIdip { instr = MIdrop } - ; MIpush (mt_nat, MLiteral.small_int 123) - ]; - [%expect {| + test_instructions [ MIdip { instr = MIdrop }; MIpush (mt_nat, MLiteral.small_int 123) ]; + [%expect + {| { DIP { DROP } ; PUSH nat 123 } -> { SWAP ; DROP ; PUSH nat 123 } |}] +;; let%expect_test "final_remove_dip_empty_seq" = - test_instructions - [ MIdip { instr = MIseq [] } - ; MIdrop - ]; + test_instructions [ MIdip { instr = MIseq [] }; MIdrop ]; [%expect {| { DIP {} ; DROP } -> { DROP } |}] +;; let%expect_test "final_merge_nested_dip" = test_instructions @@ -3444,21 +3275,20 @@ let%expect_test "final_merge_nested_dip" = ; MIdip { instr = MIseq [ mk (MIpush (mt_int, MLiteral.small_int 2)) ] } ; MIdrop ]; - [%expect {| + [%expect + {| { DIP { PUSH int 1 } ; DIP { PUSH int 2 } ; DROP } -> { DROP ; PUSH int 1 ; PUSH int 2 } |}] +;; let%expect_test "final_push_literal_some" = - test_instructions - [ MIpush (mt_nat, MLiteral.small_int 99) - ; MI1 Some_ - ; MIdrop - ]; + test_instructions [ MIpush (mt_nat, MLiteral.small_int 99); MI1 Some_; MIdrop ]; [%expect {| { PUSH nat 99 ; SOME ; DROP } -> {} |}] +;; let%expect_test "final_push_literal_left" = test_instructions @@ -3470,17 +3300,16 @@ let%expect_test "final_push_literal_left" = { PUSH string "left side" ; LEFT bool ; DROP } -> {} |}] +;; let%expect_test "final_push_literal_right" = test_instructions - [ MIpush (mt_bool, MLiteral.bool true) - ; MI1 (Right (None, None, mt_nat)) - ; MIdrop - ]; + [ MIpush (mt_bool, MLiteral.bool true); MI1 (Right (None, None, mt_nat)); MIdrop ]; [%expect {| { PUSH bool True ; RIGHT nat ; DROP } -> {} |}] +;; let%expect_test "final_push_push_pair" = test_instructions @@ -3493,13 +3322,13 @@ let%expect_test "final_push_push_pair" = { PUSH int 1 ; PUSH nat 2 ; PAIR %fst %snd ; DROP } -> {} |}] +;; let%expect_test "final_push_pair_then_mifield_a" = test_instructions [ MIpush ( mt_pair mt_nat mt_int - , MLiteral.pair (MLiteral.small_int 7) (MLiteral.small_int 77) - ) + , MLiteral.pair (MLiteral.small_int 7) (MLiteral.small_int 77) ) ; MIfield [ A ] ; MIdrop ]; @@ -3507,6 +3336,7 @@ let%expect_test "final_push_pair_then_mifield_a" = { PUSH (pair nat int) (Pair 7 77) ; CAR ; DROP } -> {} |}] +;; let%expect_test "final_nil_push_cons" = test_instructions @@ -3519,17 +3349,16 @@ let%expect_test "final_nil_push_cons" = { NIL string ; PUSH string "some str" ; CONS ; DROP } -> {} |}] +;; let%expect_test "final_push_false_loop" = test_instructions - [ MIpush (mt_bool, MLiteral.bool false) - ; MIloop { instr = MIswap } - ; MIdrop - ]; + [ MIpush (mt_bool, MLiteral.bool false); MIloop { instr = MIswap }; MIdrop ]; [%expect {| { PUSH bool False ; LOOP { SWAP } ; DROP } -> { DROP } |}] +;; let%expect_test "final_right_loop_left" = test_instructions @@ -3537,33 +3366,28 @@ let%expect_test "final_right_loop_left" = ; MIloop_left { instr = MI1 Not } ; MIpush (mt_string, MLiteral.string "rest") ]; - [%expect {| + [%expect + {| { RIGHT string ; LOOP_LEFT { NOT } ; PUSH string "rest" } -> { PUSH string "rest" } |}] +;; let%expect_test "final_dig1_commutative" = - test_instructions - [ MIdig 1 - ; MI2 Add - ; MIdrop - ]; + test_instructions [ MIdig 1; MI2 Add; MIdrop ]; [%expect {| { DIG 1 ; ADD ; DROP } -> { ADD ; DROP } |}] +;; let%expect_test "final_dig1_compare_eq" = - test_instructions - [ MIdig 1 - ; MI2 Compare - ; MI1 Eq - ; MIdrop - ]; + test_instructions [ MIdig 1; MI2 Compare; MI1 Eq; MIdrop ]; [%expect {| { DIG 1 ; COMPARE ; EQ ; DROP } -> { DROP 2 } |}] +;; let%expect_test "final_bubble_drop_push_dig1" = test_instructions @@ -3572,10 +3396,12 @@ let%expect_test "final_bubble_drop_push_dig1" = ; MIdrop ; MIpush (mt_int, MLiteral.small_int 101) ]; - [%expect {| + [%expect + {| { PUSH string "bubble-up" ; DIG 1 ; DROP ; PUSH int 101 } -> { DROP ; PUSH string "bubble-up" ; PUSH int 101 } |}] +;; let%expect_test "final_bubble_dip" = test_instructions @@ -3583,10 +3409,12 @@ let%expect_test "final_bubble_dip" = ; MIdip { instr = MIseq [ mk (MIpush (mt_int, MLiteral.small_int 20)) ] } ; MIdrop ]; - [%expect {| + [%expect + {| { NEG ; DIP { PUSH int 20 } ; DROP } -> { DROP ; PUSH int 20 } |}] +;; let%expect_test "final_bubble_swap_push_mono" = test_instructions @@ -3595,138 +3423,120 @@ let%expect_test "final_bubble_swap_push_mono" = ; MI1 Not ; MIpush (mt_string, MLiteral.string "rest") ]; - [%expect {| + [%expect + {| { PUSH bool True ; DIG 1 ; NOT ; PUSH string "rest" } -> { NOT ; PUSH bool True ; SWAP ; PUSH string "rest" } |}] +;; let%expect_test "final_multiple_dig_reorder" = test_instructions - [ MIdig 3 - ; MIdig 2 - ; MIdrop - ; MIpush (mt_string, MLiteral.string "rest") - ]; - [%expect {| + [ MIdig 3; MIdig 2; MIdrop; MIpush (mt_string, MLiteral.string "rest") ]; + [%expect + {| { DIG 3 ; DIG 2 ; DROP ; PUSH string "rest" } -> { SWAP ; DROP ; DIG 2 ; PUSH string "rest" } |}] +;; let%expect_test "final_push_dig_n_greater1" = test_instructions - [ MIpush (mt_string, MLiteral.string "some-literal") - ; MIdig 3 - ; MIdrop - ; MIdrop - ]; - [%expect {| + [ MIpush (mt_string, MLiteral.string "some-literal"); MIdig 3; MIdrop; MIdrop ]; + [%expect + {| { PUSH string "some-literal" ; DIG 3 ; DROP ; DROP } -> { DIG 2 ; DROP } |}] +;; let%expect_test "final_dup1_dig_n_drop" = - test_instructions - [ MIdup 1 - ; MIdig 2 - ; MIdrop - ; MIpush (mt_unit, MLiteral.unit) - ]; - [%expect {| + test_instructions [ MIdup 1; MIdig 2; MIdrop; MIpush (mt_unit, MLiteral.unit) ]; + [%expect + {| { DUP ; DIG 2 ; DROP ; PUSH unit Unit } -> { SWAP ; DROP ; DUP ; UNIT } |}] +;; let%expect_test "final_one_to_two_instr_dig_n_drop" = - test_instructions - [ MIunpair [true; true] - ; MIdig 2 - ; MIdrop - ; MIdrop - ]; + test_instructions [ MIunpair [ true; true ]; MIdig 2; MIdrop; MIdrop ]; [%expect {| { UNPAIR ; DIG 2 ; DROP ; DROP } -> { SWAP ; DROP ; CDR } |}] +;; let%expect_test "final_pair_unpair_cancel" = test_instructions [ MI2 (Pair (None, None)) - ; MIunpair [true; true] + ; MIunpair [ true; true ] ; MIpush (mt_int, MLiteral.small_int 999) ]; [%expect {| { PAIR ; UNPAIR ; PUSH int 999 } -> { PUSH int 999 } |}] +;; let%expect_test "final_read_ticket_drop" = - test_instructions - [ MI1 Read_ticket - ; MIdrop - ; MIpush (mt_bool, MLiteral.bool false) - ]; - [%expect {| + test_instructions [ MI1 Read_ticket; MIdrop; MIpush (mt_bool, MLiteral.bool false) ]; + [%expect + {| { READ_TICKET ; DROP ; PUSH bool False } -> { PUSH bool False } |}] +;; let%expect_test "final_ternary_midig_drop" = test_instructions - [ MI3 Update - ; MIdig 2 - ; MIdrop - ; MIpush (mt_string, MLiteral.string "end") - ]; - [%expect {| + [ MI3 Update; MIdig 2; MIdrop; MIpush (mt_string, MLiteral.string "end") ]; + [%expect + {| { UPDATE ; DIG 2 ; DROP ; PUSH string "end" } -> { DIG 4 ; DROP ; UPDATE ; PUSH string "end" } |}] +;; let%expect_test "final_ternary_3_2" = - test_instructions - [ MI2 Split_ticket - ; MIdig 2 - ; MIdrop - ; MIdrop - ]; + test_instructions [ MI2 Split_ticket; MIdig 2; MIdrop; MIdrop ]; [%expect {| { SPLIT_TICKET ; DIG 2 ; DROP ; DROP } -> { DIG 3 ; DROP 3 } |}] +;; let%expect_test "final_comment_push_fail_reorder" = test_instructions - [ MIcomment ["some cmt"] + [ MIcomment [ "some cmt" ] ; MIpush (mt_string, MLiteral.string "fail message") ; MI1_fail Failwith ; MIdrop ]; - [%expect {| + [%expect + {| { PUSH string "fail message" ; FAILWITH ; DROP } -> { PUSH string "fail message" ; FAILWITH } |}] +;; let%expect_test "final_dup1_then_never_fail" = - test_instructions - [ MIdup 1 - ; MI1_fail Never - ; MIpush (mt_int, MLiteral.small_int 101) - ]; + test_instructions [ MIdup 1; MI1_fail Never; MIpush (mt_int, MLiteral.small_int 101) ]; [%expect {| { DUP ; NEVER ; PUSH int 101 } -> { NEVER } |}] +;; let%expect_test "final_dup1_then_failwith" = test_instructions - [ MIdup 1 - ; MI1_fail Failwith - ; MIpush (mt_string, MLiteral.string "unreachable") - ]; - [%expect {| + [ MIdup 1; MI1_fail Failwith; MIpush (mt_string, MLiteral.string "unreachable") ]; + [%expect + {| { DUP ; FAILWITH ; PUSH string "unreachable" } -> { FAILWITH } |}] +;; let%expect_test "final_dug_n_pair_exec_failwith" = test_instructions @@ -3736,10 +3546,12 @@ let%expect_test "final_dug_n_pair_exec_failwith" = ; MI1_fail Failwith ; MIpush (mt_string, MLiteral.string "post") ]; - [%expect {| + [%expect + {| { DUG 3 ; PAIR ; EXEC ; FAILWITH ; PUSH string "post" } -> { DROP ; PAIR ; EXEC ; FAILWITH } |}] +;; let%expect_test "final_dug_n_push_midig_k_pair_fail" = test_instructions @@ -3751,7 +3563,8 @@ let%expect_test "final_dug_n_push_midig_k_pair_fail" = ; MI1_fail Failwith ; MIdrop ]; - [%expect {| + [%expect + {| { DUG 3 ; PUSH string "lazy error msg" ; DIG 3 ; @@ -3761,11 +3574,12 @@ let%expect_test "final_dug_n_push_midig_k_pair_fail" = DROP } -> { DROP ; PUSH string "lazy error msg" ; DIG 3 ; PAIR ; EXEC ; FAILWITH } |}] +;; let%expect_test "final_create_contract_dig_drop" = test_instructions [ MIcreate_contract - { tparameter = (mt_string, None) + { tparameter = mt_string, None ; tstorage = mt_nat ; code = { instr = MIdrop } ; views = [] @@ -3774,7 +3588,8 @@ let%expect_test "final_create_contract_dig_drop" = ; MIdrop ; MIpush (mt_string, MLiteral.string "after create_contract") ]; - [%expect {| + [%expect + {| { CREATE_CONTRACT { parameter string ; storage nat ; code { DROP } } ; DIG 2 ; DROP ; @@ -3784,22 +3599,24 @@ let%expect_test "final_create_contract_dig_drop" = DROP ; CREATE_CONTRACT { parameter string ; storage nat ; code { DROP } } ; PUSH string "after create_contract" } |}] +;; let%expect_test "final_create_contract_output_pattern" = test_instructions [ MI2 (Pair (None, None)) - ; MIcomment ["some cmt"] + ; MIcomment [ "some cmt" ] ; MIdup 1 ; MIfield [ A ] ; MI0 (Nil mt_operation) ; MIdig 1 ; MI2 Cons - ; MIcomment ["another cmt"] + ; MIcomment [ "another cmt" ] ; MIdig 1 ; MIfield [ D ] ; MIpush (mt_nat, MLiteral.small_int 808) ]; - [%expect {| + [%expect + {| { PAIR ; DUP ; CAR ; @@ -3811,53 +3628,45 @@ let%expect_test "final_create_contract_output_pattern" = PUSH nat 808 } -> { NIL operation ; SWAP ; CONS ; SWAP ; PUSH nat 808 } |}] +;; let%expect_test "final_comment_drop_reorder" = test_instructions - [ MIcomment ["a comment"] - ; MIdrop - ; MIpush (mt_int, MLiteral.small_int 555) - ]; + [ MIcomment [ "a comment" ]; MIdrop; MIpush (mt_int, MLiteral.small_int 555) ]; [%expect {| { DROP ; PUSH int 555 } -> { DROP ; PUSH int 555 } |}] +;; let%expect_test "final_comment_dig1" = test_instructions - [ MIcomment ["some text"] - ; MIdig 1 - ; MIpush (mt_nat, MLiteral.small_int 123) - ]; + [ MIcomment [ "some text" ]; MIdig 1; MIpush (mt_nat, MLiteral.small_int 123) ]; [%expect {| { DIG 1 ; PUSH nat 123 } -> { SWAP ; PUSH nat 123 } |}] +;; let%expect_test "final_comment_dig_drop" = test_instructions - [ MIcomment ["cc"] - ; MIdig 2 - ; MIdrop - ; MIpush (mt_string, MLiteral.string "rest") - ]; - [%expect {| + [ MIcomment [ "cc" ]; MIdig 2; MIdrop; MIpush (mt_string, MLiteral.string "rest") ]; + [%expect + {| { DIG 2 ; DROP ; PUSH string "rest" } -> { DIG 2 ; DROP ; PUSH string "rest" } |}] +;; let%expect_test "final_ternary_arbitrary" = test_instructions - [ MI2 (Split_ticket) - ; MIdig 3 - ; MIdrop - ; MIdrop - ; MIpush (mt_int, MLiteral.small_int 777) - ]; - [%expect {| + [ MI2 Split_ticket; MIdig 3; MIdrop; MIdrop; MIpush (mt_int, MLiteral.small_int 777) ]; + [%expect + {| { SPLIT_TICKET ; DIG 3 ; DROP ; DROP ; PUSH int 777 } -> { DIG 4 ; DROP 3 ; PUSH int 777 } |}] +;; let%expect_test "final_constant_folding_add" = test_instructions @@ -3870,6 +3679,7 @@ let%expect_test "final_constant_folding_add" = { PUSH int 5 ; PUSH int 7 ; ADD ; DROP } -> {} |}] +;; let%expect_test "final_constant_folding_sub" = test_instructions @@ -3882,6 +3692,7 @@ let%expect_test "final_constant_folding_sub" = { PUSH int 15 ; PUSH int 6 ; SUB ; DROP } -> {} |}] +;; let%expect_test "final_constant_folding_mul" = test_instructions @@ -3890,34 +3701,30 @@ let%expect_test "final_constant_folding_mul" = ; MI2 Mul ; MIpush (mt_bool, MLiteral.bool true) ]; - [%expect {| + [%expect + {| { PUSH int 3 ; PUSH int 4 ; MUL ; PUSH bool True } -> { PUSH int 12 ; PUSH bool True } |}] +;; let%expect_test "final_constant_folding_neg_nat" = - test_instructions - [ MIpush (mt_nat, MLiteral.small_int 10) - ; MI1 Neg - ; MIdrop - ]; + test_instructions [ MIpush (mt_nat, MLiteral.small_int 10); MI1 Neg; MIdrop ]; [%expect {| { PUSH nat 10 ; NEG ; DROP } -> {} |}] +;; let%expect_test "final_1_2_instr_dig1_double_drop" = test_instructions - [ MIunpair [true; true] - ; MIdig 1 - ; MIdrop - ; MIdrop - ; MIpush (mt_unit, MLiteral.unit) - ]; - [%expect {| + [ MIunpair [ true; true ]; MIdig 1; MIdrop; MIdrop; MIpush (mt_unit, MLiteral.unit) ]; + [%expect + {| { UNPAIR ; DIG 1 ; DROP ; DROP ; PUSH unit Unit } -> { DROP ; UNIT } |}] +;; let%expect_test "final_push_literal_dup1_second" = test_instructions @@ -3925,22 +3732,22 @@ let%expect_test "final_push_literal_dup1_second" = ; MIdup 1 ; MIpush (mt_bool, MLiteral.bool false) ]; - [%expect {| + [%expect + {| { PUSH string "duplicate me!" ; DUP ; PUSH bool False } -> { PUSH string "duplicate me!" ; DUP ; PUSH bool False } |}] +;; let%expect_test "final_lambda_exec_inlining" = test_instructions - [ MIlambda (mt_nat, mt_string, { instr = MI1 Not }) - ; MIdig 1 - ; MI2 Exec - ; MIdrop - ]; - [%expect {| + [ MIlambda (mt_nat, mt_string, { instr = MI1 Not }); MIdig 1; MI2 Exec; MIdrop ]; + [%expect + {| { LAMBDA nat string { NOT } ; DIG 1 ; EXEC ; DROP } -> { DROP } |}] +;; let%expect_test "final_push_instr_exec_inlining" = let body = { instr = MIseq [ mk (MIpush (mt_string, MLiteral.string "internal")) ] } in @@ -3950,48 +3757,42 @@ let%expect_test "final_push_instr_exec_inlining" = ; MI2 Exec ; MIdrop ]; - [%expect {| + [%expect + {| { PUSH (lambda unit string) { PUSH string "internal" } ; DIG 1 ; EXEC ; DROP } -> { PUSH (lambda unit string) { PUSH string "internal" } ; SWAP ; EXEC ; DROP } |}] +;; let%expect_test "final_dig_n_dup1_dug_n_plus1_check" = - test_instructions - [ MIdig 2 - ; MIdup 1 - ; MIdug 3 - ; MIdrop - ]; + test_instructions [ MIdig 2; MIdup 1; MIdug 3; MIdrop ]; [%expect {| { DIG 2 ; DUP ; DUG 3 ; DROP } -> {} |}] +;; let%expect_test "final_dup_n_swap_drop" = test_instructions - [ MIdup 2 - ; MIswap - ; MIdrop - ; MIpush (mt_string, MLiteral.string "afterwards") - ]; - [%expect {| + [ MIdup 2; MIswap; MIdrop; MIpush (mt_string, MLiteral.string "afterwards") ]; + [%expect + {| { DUP 2 ; SWAP ; DROP ; PUSH string "afterwards" } -> { DROP ; DUP ; PUSH string "afterwards" } |}] +;; let%expect_test "final_dup1_dup2_againa" = - test_instructions - [ MIdup 1 - ; MIdup 2 - ; MIpush (mt_nat, MLiteral.small_int 444) - ]; - [%expect {| + test_instructions [ MIdup 1; MIdup 2; MIpush (mt_nat, MLiteral.small_int 444) ]; + [%expect + {| { DUP ; DUP 2 ; PUSH nat 444 } -> { DUP ; DUP ; PUSH nat 444 } |}] +;; let%expect_test "final_dup1_dup1_f_push_dig3_again" = test_instructions @@ -4002,155 +3803,130 @@ let%expect_test "final_dup1_dup1_f_push_dig3_again" = ; MIdig 3 ; MIdrop ]; - [%expect {| + [%expect + {| { DUP ; DUP ; NOT ; PUSH nat 333 ; DIG 3 ; DROP } -> { DUP ; NOT ; PUSH nat 333 } |}] +;; let%expect_test "final_self_none_address_conversion" = - test_instructions - [ MI0 (Self None) - ; MI1 Address - ; MIdrop - ]; + test_instructions [ MI0 (Self None); MI1 Address; MIdrop ]; [%expect {| { SELF ; ADDRESS ; DROP } -> {} |}] +;; let%expect_test "lltz_specific_pre_dig_n_dropn_m_when_n_less_than_m" = - test_instructions - [ MIdig 1 - ; MIdropn 3 - ; MIpush (mt_string, MLiteral.string "after") - ]; - [%expect {| + test_instructions [ MIdig 1; MIdropn 3; MIpush (mt_string, MLiteral.string "after") ]; + [%expect + {| { DIG 1 ; DROP 3 ; PUSH string "after" } -> { DROP 3 ; PUSH string "after" } |}] +;; let%expect_test "lltz_specific_pre_dug_n_dropn_m_when_n_less_than_m" = - test_instructions - [ MIdug 2 - ; MIdropn 4 - ; MIpush (mt_nat, MLiteral.small_int 123) - ]; - [%expect {| + test_instructions [ MIdug 2; MIdropn 4; MIpush (mt_nat, MLiteral.small_int 123) ]; + [%expect + {| { DUG 2 ; DROP 4 ; PUSH nat 123 } -> { DROP 4 ; PUSH nat 123 } |}] +;; let%expect_test "lltz_specific_pre_no_rewrite_when_dig_n_is_not_less_than_m" = - test_instructions - [ MIdig 3 - ; MIdropn 2 - ; MIdrop - ]; + test_instructions [ MIdig 3; MIdropn 2; MIdrop ]; [%expect {| { DIG 3 ; DROP 2 ; DROP } -> { DIG 3 ; DROP 3 } |}] +;; let%expect_test "lltz_specific_pre_no_rewrite_when_dug_n_is_not_less_than_m" = test_instructions - [ MIdug 5 - ; MIdropn 5 - ; MIpush (mt_string, MLiteral.string "no rewrite") - ]; - [%expect {| + [ MIdug 5; MIdropn 5; MIpush (mt_string, MLiteral.string "no rewrite") ]; + [%expect + {| { DUG 5 ; DROP 5 ; PUSH string "no rewrite" } -> { DUG 5 ; DROP 5 ; PUSH string "no rewrite" } |}] +;; let%expect_test "lltz_specific_push_option_some" = test_instructions - [ MIpush - ( mt_option mt_nat - , MLiteral.some (MLiteral.small_int 42) - ) - ; MIdrop - ]; + [ MIpush (mt_option mt_nat, MLiteral.some (MLiteral.small_int 42)); MIdrop ]; [%expect {| { PUSH (option nat) (Some 42) ; DROP } -> {} |}] +;; let%expect_test "lltz_specific_push_option_none" = test_instructions - [ MIpush - ( mt_option mt_string - , MLiteral.none - ) - ; MIpush (mt_bool, MLiteral.bool true) - ]; - [%expect {| + [ MIpush (mt_option mt_string, MLiteral.none); MIpush (mt_bool, MLiteral.bool true) ]; + [%expect + {| { PUSH (option string) None ; PUSH bool True } -> { NONE string ; PUSH bool True } |}] +;; let%expect_test "lltz_specific_list_single_element" = test_instructions - [ MIpush - ( mt_list mt_nat - , MLiteral.list [MLiteral.small_int 999] ) - ; MIdig 1 - ]; - [%expect {| + [ MIpush (mt_list mt_nat, MLiteral.list [ MLiteral.small_int 999 ]); MIdig 1 ]; + [%expect + {| { PUSH (list nat) { 999 } ; DIG 1 } -> { NIL nat ; PUSH nat 999 ; CONS ; SWAP } |}] +;; let%expect_test "lltz_specific_list_single_element_more_complex" = test_instructions - [ MIpush - ( mt_list mt_string - , MLiteral.list [MLiteral.string "only-element"] ) + [ MIpush (mt_list mt_string, MLiteral.list [ MLiteral.string "only-element" ]) ; MIdrop ]; [%expect {| { PUSH (list string) { "only-element" } ; DROP } -> {} |}] +;; let%expect_test "lltz_specific_lambda_int_int_constant_hash" = test_instructions [ MIlambda - ( mt_int - , mt_int - , { instr = MIConstant { literal = String "some-hash-here" } } - ) + (mt_int, mt_int, { instr = MIConstant { literal = String "some-hash-here" } }) ; MIdrop ]; - [%expect {| + [%expect + {| { LAMBDA int int { constant "some-hash-here" } ; DROP } -> {} |}] +;; let%expect_test "lltz_specific_push_or_left" = test_instructions - [ MIpush - ( mt_or mt_string mt_nat - , MLiteral.left (MLiteral.string "left part") - ) + [ MIpush (mt_or mt_string mt_nat, MLiteral.left (MLiteral.string "left part")) ; MIdig 1 ]; - [%expect {| + [%expect + {| { PUSH (or string nat) (Left "left part") ; DIG 1 } -> { PUSH string "left part" ; LEFT nat ; SWAP } |}] +;; let%expect_test "lltz_specific_push_or_right" = test_instructions - [ MIpush - ( mt_or mt_bool mt_int - , MLiteral.right (MLiteral.small_int 1234) - ) - ; MIdrop - ]; + [ MIpush (mt_or mt_bool mt_int, MLiteral.right (MLiteral.small_int 1234)); MIdrop ]; [%expect {| { PUSH (or bool int) (Right 1234) ; DROP } -> {} |}] +;; let%expect_test "lltz_specific_push_pair_literal" = test_instructions @@ -4159,10 +3935,13 @@ let%expect_test "lltz_specific_push_pair_literal" = , MLiteral.pair (MLiteral.string "fst") (MLiteral.small_int 222) ) ; MIpush (mt_string, MLiteral.string "rest code") ]; - [%expect {| + [%expect + {| { PUSH (pair string nat) (Pair "fst" 222) ; PUSH string "rest code" } -> { PUSH nat 222 ; PUSH string "fst" ; PAIR ; PUSH string "rest code" } |}] +;; + let%expect_test "lltz_specific_dug_dig_swap_dropn" = test_instructions [ MIdig 1 @@ -4171,36 +3950,32 @@ let%expect_test "lltz_specific_dug_dig_swap_dropn" = ; MIdropn 1 ; MIpush (mt_string, MLiteral.string "continuation") ]; - [%expect {| + [%expect + {| { DIG 1 ; DROP 1 ; DUG 1 ; DROP 1 ; PUSH string "continuation" } -> { DUG 2 ; DROP 2 ; PUSH string "continuation" } |}] +;; let%expect_test "lltz_specific_dug_dig_swap_dropn_more" = test_instructions - [ MIswap - ; MIdrop - ; MIdug 1 - ; MIdropn 1 - ; MIpush (mt_nat, MLiteral.small_int 101) - ]; - [%expect {| + [ MIswap; MIdrop; MIdug 1; MIdropn 1; MIpush (mt_nat, MLiteral.small_int 101) ]; + [%expect + {| { SWAP ; DROP ; DUG 1 ; DROP 1 ; PUSH nat 101 } -> { DUG 2 ; DROP 2 ; PUSH nat 101 } |}] +;; let%expect_test "lltz_specific_dug_n_m_dropn_n_eq" = test_instructions - [ MIdig 1 - ; MIdropn 1 - ; MIdug 2 - ; MIdropn 2 - ; MIpush (mt_string, MLiteral.string "done") - ]; - [%expect {| + [ MIdig 1; MIdropn 1; MIdug 2; MIdropn 2; MIpush (mt_string, MLiteral.string "done") ]; + [%expect + {| { DIG 1 ; DROP 1 ; DUG 2 ; DROP 2 ; PUSH string "done" } -> { DUG 3 ; DROP 3 ; PUSH string "done" } |}] +;; let%expect_test "lltz_specific_mi2_dig_drop_midugn" = test_instructions @@ -4211,10 +3986,12 @@ let%expect_test "lltz_specific_mi2_dig_drop_midugn" = ; MIdropn 2 ; MIpush (mt_string, MLiteral.string "rest") ]; - [%expect {| + [%expect + {| { DIG 2 ; DROP ; DUG 3 ; DUG 3 ; DROP 2 ; PUSH string "rest" } -> { DIG 2 ; DROP ; DIG 2 ; DROP ; DIG 2 ; DROP ; PUSH string "rest" } |}] +;; let%expect_test "lltz_specific_mi3_dig_drop_midugn_triple" = test_instructions @@ -4226,284 +4003,252 @@ let%expect_test "lltz_specific_mi3_dig_drop_midugn_triple" = ; MIdropn 3 ; MIpush (mt_int, MLiteral.small_int 999) ]; - [%expect {| + [%expect + {| { DIG 3 ; DROP ; DUG 4 ; DUG 4 ; DUG 4 ; DROP 3 ; PUSH int 999 } -> { DIG 3 ; DROP ; DIG 3 ; DROP ; DIG 3 ; DROP 2 ; PUSH int 999 } |}] +;; let%expect_test "lltz_specific_midig2_drop" = - test_instructions - [ MIdig 2 - ; MIdrop - ; MIpush (mt_bool, MLiteral.bool true) - ]; - [%expect {| + test_instructions [ MIdig 2; MIdrop; MIpush (mt_bool, MLiteral.bool true) ]; + [%expect + {| { DIG 2 ; DROP ; PUSH bool True } -> { DIG 2 ; DROP ; PUSH bool True } |}] +;; let%expect_test "lltz_specific_midig3_drop" = test_instructions - [ MIdig 3 - ; MIdrop - ; MIpush (mt_string, MLiteral.string "continuation") - ]; - [%expect {| + [ MIdig 3; MIdrop; MIpush (mt_string, MLiteral.string "continuation") ]; + [%expect + {| { DIG 3 ; DROP ; PUSH string "continuation" } -> { DIG 3 ; DROP ; PUSH string "continuation" } |}] +;; let%expect_test "lltz_specific_mipairn_unpair_alltrue" = test_instructions - [ MIpairn 3 - ; MIunpair [true; true; true] - ; MIpush (mt_nat, MLiteral.small_int 777) - ]; + [ MIpairn 3; MIunpair [ true; true; true ]; MIpush (mt_nat, MLiteral.small_int 777) ]; [%expect {| { PAIR 3 ; UNPAIR 3 ; PUSH nat 777 } -> { PUSH nat 777 } |}] +;; let%expect_test "lltz_specific_mdropn_1" = - test_instructions - [ MIdropn 1 - ; MIpush (mt_string, MLiteral.string "some code") - ]; - [%expect {| + test_instructions [ MIdropn 1; MIpush (mt_string, MLiteral.string "some code") ]; + [%expect + {| { DROP 1 ; PUSH string "some code" } -> { DROP ; PUSH string "some code" } |}] +;; let%expect_test "lltz_specific_no_rewrite_scenario" = - test_instructions - [ MIpairn 2 - ; MIunpair [true; true; true] - ; MIdrop - ]; + test_instructions [ MIpairn 2; MIunpair [ true; true; true ]; MIdrop ]; [%expect {| { PAIR 2 ; UNPAIR 3 ; DROP } -> { DROP ; UNPAIR } |}] +;; let%expect_test "lltz_specific_no_rewrite_edge_case" = - test_instructions - [ MIdig 2 - ; MIdropn 2 - ; MIpush (mt_unit, MLiteral.unit) - ]; - [%expect {| + test_instructions [ MIdig 2; MIdropn 2; MIpush (mt_unit, MLiteral.unit) ]; + [%expect + {| { DIG 2 ; DROP 2 ; PUSH unit Unit } -> { DIG 2 ; DROP 2 ; UNIT } |}] +;; -let rec mk_dig k n = - if n = 0 then [] - else MIdig k :: mk_dig k (n - 1) - -let rec mk_dug k n = - if n = 0 then [] - else MIdug k :: mk_dug k (n - 1) +let rec mk_dig k n = if n = 0 then [] else MIdig k :: mk_dig k (n - 1) +let rec mk_dug k n = if n = 0 then [] else MIdug k :: mk_dug k (n - 1) let%expect_test "digdug_cycles_dig_k_times" = - test_instructions - (mk_dig 3 3 @ [ MIpush (mt_string, MLiteral.string "rest") ]); - [%expect {| + test_instructions (mk_dig 3 3 @ [ MIpush (mt_string, MLiteral.string "rest") ]); + [%expect + {| { DIG 3 ; DIG 3 ; DIG 3 ; PUSH string "rest" } -> { DUG 3 ; PUSH string "rest" } |}] +;; let%expect_test "digdug_cycles_dug_k_times" = - test_instructions - (mk_dug 4 4 @ [ MIdrop ]); + test_instructions (mk_dug 4 4 @ [ MIdrop ]); [%expect {| { DUG 4 ; DUG 4 ; DUG 4 ; DUG 4 ; DROP } -> { DIG 4 ; DROP } |}] +;; let%expect_test "digdug_cycles_dig1_or_dug1" = test_instructions - [ MIdig 1 - ; MIdig 1 - ; MIdug 1 - ; MIdug 1 - ; MIpush (mt_nat, MLiteral.small_int 42) - ]; - [%expect {| + [ MIdig 1; MIdig 1; MIdug 1; MIdug 1; MIpush (mt_nat, MLiteral.small_int 42) ]; + [%expect + {| { DIG 1 ; DIG 1 ; DUG 1 ; DUG 1 ; PUSH nat 42 } -> { PUSH nat 42 } |}] +;; let%expect_test "digdug_cycles_incomplete_sequence" = test_instructions - [ MIdig 2 - ; MIdig 2 - ; MIpush (mt_string, MLiteral.string "break sequence") - ; MIdig 2 - ]; - [%expect {| + [ MIdig 2; MIdig 2; MIpush (mt_string, MLiteral.string "break sequence"); MIdig 2 ]; + [%expect + {| { DIG 2 ; DIG 2 ; PUSH string "break sequence" ; DIG 2 } -> { DUG 2 ; PUSH string "break sequence" ; DIG 2 } |}] +;; let%expect_test "digdug_cycles_more_than_needed" = - test_instructions - (mk_dig 3 5 @ [ MIdrop ]); - [%expect {| + test_instructions (mk_dig 3 5 @ [ MIdrop ]); + [%expect + {| { DIG 3 ; DIG 3 ; DIG 3 ; DIG 3 ; DIG 3 ; DROP } -> { DIG 3 ; DROP } |}] +;; let%expect_test "digdug_cycles_interspersed_break" = test_instructions - [ MIdig 3 - ; MIdig 3 - ; MIdrop - ; MIdig 3 - ; MIpush (mt_string, MLiteral.string "end") - ]; - [%expect {| + [ MIdig 3; MIdig 3; MIdrop; MIdig 3; MIpush (mt_string, MLiteral.string "end") ]; + [%expect + {| { DIG 3 ; DIG 3 ; DROP ; DIG 3 ; PUSH string "end" } -> { DIG 2 ; DROP ; DIG 2 ; DIG 3 ; PUSH string "end" } |}] +;; let%expect_test "digdug_cycles_dug_interspersed" = test_instructions - [ MIdug 2 - ; MIdug 2 - ; MIswap - ; MIdug 2 - ; MIpush (mt_bool, MLiteral.bool true) - ]; - [%expect {| + [ MIdug 2; MIdug 2; MIswap; MIdug 2; MIpush (mt_bool, MLiteral.bool true) ]; + [%expect + {| { DUG 2 ; DUG 2 ; SWAP ; DUG 2 ; PUSH bool True } -> { DIG 2 ; SWAP ; DUG 2 ; PUSH bool True } |}] +;; let%expect_test "unpair_empty" = - test_instructions - [ MIunpair [] - ; MIpush (mt_nat, MLiteral.small_int 42) - ]; + test_instructions [ MIunpair []; MIpush (mt_nat, MLiteral.small_int 42) ]; [%expect {| { UNPAIR 0 ; PUSH nat 42 } -> { PUSH nat 42 } |}] +;; let%expect_test "unpair_single_true" = - test_instructions - [ MIunpair [true; true] - ; MIdrop - ]; - [%expect{| + test_instructions [ MIunpair [ true; true ]; MIdrop ]; + [%expect {| { UNPAIR ; DROP } -> { CDR } |}] +;; let%expect_test "unpair_single_false" = - test_instructions - [ MIunpair [true] - ; MIpush (mt_string, MLiteral.string "rest") - ]; - [%expect{| + test_instructions [ MIunpair [ true ]; MIpush (mt_string, MLiteral.string "rest") ]; + [%expect {| { UNPAIR 1 ; PUSH string "rest" } -> { PUSH string "rest" } |}] +;; let%expect_test "unpair_true_true_drop" = - test_instructions - [ MIunpair [true; true] - ; MIdrop - ; MIdig 1 - ]; + test_instructions [ MIunpair [ true; true ]; MIdrop; MIdig 1 ]; [%expect {| { UNPAIR ; DROP ; DIG 1 } -> { CDR ; SWAP } |}] +;; let%expect_test "unpair_true_false_drop" = test_instructions - [ MIunpair [true; true] - ; MIdrop - ; MIpush (mt_bool, MLiteral.bool true) - ]; - [%expect{| + [ MIunpair [ true; true ]; MIdrop; MIpush (mt_bool, MLiteral.bool true) ]; + [%expect + {| { UNPAIR ; DROP ; PUSH bool True } -> { CDR ; PUSH bool True } |}] +;; let%expect_test "unpair_complex_fields_first_is_true" = test_instructions - [ MIunpair [true; true; true] - ; MIdrop - ; MIpush (mt_unit, MLiteral.unit) - ]; - [%expect {| + [ MIunpair [ true; true; true ]; MIdrop; MIpush (mt_unit, MLiteral.unit) ]; + [%expect + {| { UNPAIR 3 ; DROP ; PUSH unit Unit } -> { CDR ; UNPAIR ; UNIT } |}] +;; let%expect_test "unpair_complex_fields_first_is_false" = test_instructions - [ MIunpair [true; true; true] - ; MIpush (mt_string, MLiteral.string "rest code") - ]; - [%expect{| + [ MIunpair [ true; true; true ]; MIpush (mt_string, MLiteral.string "rest code") ]; + [%expect + {| { UNPAIR 3 ; PUSH string "rest code" } -> { UNPAIR 3 ; PUSH string "rest code" } |}] +;; let%expect_test "unpair_drop_field_beyond_arities" = test_instructions - [ MIunpair [true; true; true] + [ MIunpair [ true; true; true ] ; MIdig 2 ; MIdrop ; MIpush (mt_bool, MLiteral.bool false) ]; - [%expect {| + [%expect + {| { UNPAIR 3 ; DIG 2 ; DROP ; PUSH bool False } -> { UNPAIR 3 ; DIG 2 ; DROP ; PUSH bool False } |}] +;; let%expect_test "unpair_full_drop_when_n_ge_k" = test_instructions - [ MIunpair [true; true; true] + [ MIunpair [ true; true; true ] ; MIdig 3 ; MIdrop ; MIpush (mt_int, MLiteral.small_int 111) ]; - [%expect {| + [%expect + {| { UNPAIR 3 ; DIG 3 ; DROP ; PUSH int 111 } -> { SWAP ; DROP ; UNPAIR 3 ; PUSH int 111 } |}] +;; let%expect_test "unpair_true_true_dig1_drop" = test_instructions - [ MIunpair [true; true] + [ MIunpair [ true; true ] ; MIdig 1 ; MIdrop ; MIpush (mt_string, MLiteral.string "extra") ]; - [%expect {| + [%expect + {| { UNPAIR ; DIG 1 ; DROP ; PUSH string "extra" } -> { CAR ; PUSH string "extra" } |}] +;; let%expect_test "unpair_no_rewrite_nonmatching_pattern" = - test_instructions - [ MIunpair [true; true] - ; MI2 Add - ; MIpush (mt_unit, MLiteral.unit) - ]; + test_instructions [ MIunpair [ true; true ]; MI2 Add; MIpush (mt_unit, MLiteral.unit) ]; [%expect {| { UNPAIR ; ADD ; PUSH unit Unit } -> { UNPAIR ; ADD ; UNIT } |}] +;; let%expect_test "composite_test_1_complex_push_drop_fail" = test_instructions - [ - MIcomment ["comment A"] - ; MIcomment ["comment B"] + [ MIcomment [ "comment A" ] + ; MIcomment [ "comment B" ] ; MIseq [ { instr = MIpush (mt_int, MLiteral.small_int 123) } ; { instr = MIdrop } @@ -4518,7 +4263,8 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = ; MIpush (mt_nat, MLiteral.small_int 42) ; MI1 Not ]; - [%expect {| + [%expect + {| { PUSH int 123 ; DROP ; PUSH int 123 ; @@ -4532,12 +4278,12 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = NOT } -> { PUSH string "some error" ; FAILWITH } |}] +;; - let%expect_test "composite_test_2_macro_expansion_unpair_bubble" = +let%expect_test "composite_test_2_macro_expansion_unpair_bubble" = test_instructions - [ - MIsetField [ A; D ] - ; MIunpair [true; true; true] + [ MIsetField [ A; D ] + ; MIunpair [ true; true; true ] ; MIdip { instr = MIseq [] } ; MIdig 1 ; MIdig 1 @@ -4547,7 +4293,8 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = ; MIfield [ D ] ; MIdrop ]; - [%expect{| + [%expect + {| { DUP ; DIP { CAR ; CAR ; PAIR } ; CDR ; @@ -4564,15 +4311,14 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = DROP } -> { DUP ; DIP { CAR ; CAR ; PAIR } ; SWAP ; DROP ; CDR ; UNPAIR } |}] +;; - let%expect_test "composite_test_3_lists_and_iters" = +let%expect_test "composite_test_3_lists_and_iters" = test_instructions - [ - MI0 (Nil mt_int) + [ MI0 (Nil mt_int) ; MIpush (mt_int, MLiteral.small_int 999) ; MI2 Cons - ; - MIif_cons + ; MIif_cons ( { instr = MIseq [ { instr = MIdig 2 } @@ -4592,7 +4338,8 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = ; MIdig 1 ; MIdrop ]; - [%expect {| + [%expect + {| { NIL int ; PUSH int 999 ; CONS ; @@ -4611,20 +4358,16 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = CONS ; IF_CONS { DROP 2 } { PUSH string "fail-branch" ; FAILWITH } ; PUSH string "cons-branch" } |}] +;; - let%expect_test "composite_test_4_or_and_pair_interactions" = +let%expect_test "composite_test_4_or_and_pair_interactions" = test_instructions - [ - MIpush - ( mt_or mt_string mt_int - , MLiteral.right (MLiteral.small_int 10) - ) + [ MIpush (mt_or mt_string mt_int, MLiteral.right (MLiteral.small_int 10)) ; MIdig 1 ; MIdrop ; MIpush ( mt_pair mt_bool mt_nat - , MLiteral.pair (MLiteral.bool true) (MLiteral.small_int 42) - ) + , MLiteral.pair (MLiteral.bool true) (MLiteral.small_int 42) ) ; MIfield [ A ] ; MIpush (mt_bool, MLiteral.bool true) ; MIpush (mt_bool, MLiteral.bool false) @@ -4634,7 +4377,8 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = ; MIpush (mt_int, MLiteral.small_int 1234) ; MIdrop ]; - [%expect {| + [%expect + {| { PUSH (or string int) (Right 10) ; DIG 1 ; DROP ; @@ -4649,11 +4393,11 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = DROP } -> { DROP ; PUSH int 10 ; RIGHT string ; PUSH bool True ; PUSH bool False } |}] +;; - let%expect_test "composite_test_5_digdug_chaos" = +let%expect_test "composite_test_5_digdug_chaos" = test_instructions - [ - MIdig 3 + [ MIdig 3 ; MIdig 3 ; MIpush (mt_string, MLiteral.string "break pattern") ; MIdig 3 @@ -4670,7 +4414,8 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = ; MIdig 2 ; MIpush (mt_nat, MLiteral.small_int 777) ]; - [%expect {| + [%expect + {| { DIG 3 ; DIG 3 ; PUSH string "break pattern" ; @@ -4689,14 +4434,11 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = PUSH nat 777 } -> { DROP 3 ; DUP ; PUSH nat 777 } |}] +;; - let%expect_test "composite_test_6_big_map_update_folding" = +let%expect_test "composite_test_6_big_map_update_folding" = test_instructions - [ - MIpush - ( mt_map mt_string mt_bool - , MLiteral.mk_map [] - ) + [ MIpush (mt_map mt_string mt_bool, MLiteral.mk_map []) ; MIpush (mt_bool, MLiteral.some (MLiteral.bool true)) ; MIpush (mt_string, MLiteral.string "hello-key") ; MI3 Update @@ -4711,7 +4453,8 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = ; MIpush (mt_bool, MLiteral.bool true) ; MIdrop ]; - [%expect {| + [%expect + {| { PUSH (map string bool) {} ; PUSH bool (Some True) ; PUSH string "hello-key" ; @@ -4735,11 +4478,11 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = PUSH string "other-key" ; UPDATE ; PUSH int 5 } |}] +;; - let%expect_test "composite_test_7_create_contract_shortcut" = +let%expect_test "composite_test_7_create_contract_shortcut" = test_instructions - [ - MI2 (Pair (None, None)) + [ MI2 (Pair (None, None)) ; MIdup 1 ; MIfield [ A ] ; MI0 (Nil mt_operation) @@ -4752,7 +4495,8 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = ; MIpush (mt_bool, MLiteral.bool false) ; MIloop { instr = MIswap } ]; - [%expect {| + [%expect + {| { PAIR ; DUP ; CAR ; @@ -4767,11 +4511,11 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = LOOP { SWAP } } -> { DIG 2 ; DROP ; NIL operation ; SWAP ; CONS ; SWAP } |}] +;; - let%expect_test "composite_test_8_unpair_selective_fields_dig_drop" = +let%expect_test "composite_test_8_unpair_selective_fields_dig_drop" = test_instructions - [ - MIunpair [true; true; true] + [ MIunpair [ true; true; true ] ; MIdig 2 ; MIdrop ; MIdip { instr = MIseq [ mk MIdrop ] } @@ -4779,7 +4523,8 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = ; MI1 Neg ; MIpush (mt_string, MLiteral.string "end") ]; - [%expect{| + [%expect + {| { UNPAIR 3 ; DIG 2 ; DROP ; @@ -4789,19 +4534,16 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = PUSH string "end" } -> { UNPAIR 3 ; DUG 2 ; DROP 2 ; PUSH int 0 ; PUSH string "end" } |}] +;; - let%expect_test "composite_test_9_lambda_inlining_plus_arithmetic" = +let%expect_test "composite_test_9_lambda_inlining_plus_arithmetic" = test_instructions - [ - MIlambda + [ MIlambda ( mt_nat , mt_nat , { instr = MIseq - [ mk (MIpush (mt_int, MLiteral.small_int 2)) - ; mk (MI2 Mul) - ; mk (MI1 Neg) - ] + [ mk (MIpush (mt_int, MLiteral.small_int 2)); mk (MI2 Mul); mk (MI1 Neg) ] } ) ; MIdig 1 ; MI2 Exec @@ -4812,7 +4554,8 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = ; MIpush (mt_nat, MLiteral.small_int 100) ; MIdrop ]; - [%expect {| + [%expect + {| { LAMBDA nat nat { PUSH int 2 ; MUL ; NEG } ; DIG 1 ; EXEC ; @@ -4822,13 +4565,11 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = DROP } -> { PUSH int 2 ; MUL ; NEG ; PUSH string "false branch" } |}] +;; - let%expect_test "composite_test_10_lltz_specific_clashes" = +let%expect_test "composite_test_10_lltz_specific_clashes" = test_instructions - [ - MIpush - ( mt_list mt_string - , MLiteral.list [MLiteral.string "one-element"] ) + [ MIpush (mt_list mt_string, MLiteral.list [ MLiteral.string "one-element" ]) ; MIdrop ; MIdig 2 ; MIdrop @@ -4840,7 +4581,8 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = ; MIpush (mt_bool, MLiteral.bool true) ; MIdrop ]; - [%expect {| + [%expect + {| { PUSH (list string) { "one-element" } ; DROP ; DIG 2 ; @@ -4853,4 +4595,5 @@ let%expect_test "composite_test_1_complex_push_drop_fail" = PUSH bool True ; DROP } -> - { DIG 2 ; DROP ; DIG 2 ; DROP ; DIG 2 ; DROP ; DIG 2 ; DROP } |}] \ No newline at end of file + { DIG 2 ; DROP ; DIG 2 ; DROP ; DIG 2 ; DROP ; DIG 2 ; DROP } |}] +;; diff --git a/test/test_nodes.ml b/test/test_nodes.ml index c48041c..3322d14 100644 --- a/test/test_nodes.ml +++ b/test/test_nodes.ml @@ -1,11 +1,11 @@ -(* In this file, we test the compilation of various expressions to Michelson, - with each type of LLTZ node tested atleast once. We check that both optimised and unptimised michelson output is correct. - - The concrete syntaxes are written with a OCaml-like syntax. - In LLTZ, we can only copy the value of variables not their reference, - therefore even for mutable variable we don't use 'ref' which is present in OCaml - to simplify the syntax. Assignments are done with the '<-' operator. - *) +(* In this file, we test the compilation of various expressions to Michelson, + with each type of LLTZ node tested atleast once. We check that both optimised and unptimised michelson output is correct. + + The concrete syntaxes are written with a OCaml-like syntax. + In LLTZ, we can only copy the value of variables not their reference, + therefore even for mutable variable we don't use 'ref' which is present in OCaml + to simplify the syntax. Assignments are done with the '<-' operator. +*) open Core open Lltz_ir.Ast_builder.With_dummy module Ast_builder = Lltz_ir.Ast_builder @@ -18,14 +18,16 @@ let empty_stack : LM.Stack.t = [] let compile_and_collect_instructions ?(optimize = false) expr = let compiled_instruction = LM.compile_to_micheline ~optimize expr in [ compiled_instruction empty_stack ] +;; let print_instructions instructions = List.iter ~f:(fun instruction -> - Michelson.Ast.pp Format.std_formatter instruction; + Lltz_michelson.Ast.pp Format.std_formatter instruction; Format.print_newline ()) instructions; Format.print_flush () +;; let test_expr ?(optimize = true) expr = let instructions = compile_and_collect_instructions expr in @@ -36,6 +38,7 @@ let test_expr ?(optimize = true) expr = let optimised_instructions = compile_and_collect_instructions ~optimize expr in print_instructions optimised_instructions) else () +;; let%expect_test "unit" = test_expr unit; @@ -44,6 +47,7 @@ let%expect_test "unit" = Optimised: { UNIT } |}] +;; (* Bool Tests *) let%expect_test "bool true" = @@ -53,6 +57,7 @@ let%expect_test "bool true" = Optimised: { PUSH bool True } |}] +;; let%expect_test "bool false" = test_expr (bool false); @@ -61,6 +66,7 @@ let%expect_test "bool false" = Optimised: { PUSH bool False } |}] +;; (* Nat Tests *) let%expect_test "nat zero" = @@ -70,6 +76,7 @@ let%expect_test "nat zero" = Optimised: { PUSH nat 0 } |}] +;; let%expect_test "nat 42" = test_expr (nat 42); @@ -78,6 +85,7 @@ let%expect_test "nat 42" = Optimised: { PUSH nat 42 } |}] +;; let%expect_test "nat large" = test_expr (nat 999999999999999999); @@ -87,6 +95,7 @@ let%expect_test "nat large" = Optimised: { PUSH nat 999999999999999999 } |}] +;; (* Int Tests *) let%expect_test "int zero" = @@ -96,6 +105,7 @@ let%expect_test "int zero" = Optimised: { PUSH int 0 } |}] +;; let%expect_test "int positive" = test_expr (int 123456); @@ -104,6 +114,7 @@ let%expect_test "int positive" = Optimised: { PUSH int 123456 } |}] +;; let%expect_test "int negative" = test_expr (int (-999999)); @@ -112,6 +123,7 @@ let%expect_test "int negative" = Optimised: { PUSH int -999999 } |}] +;; (* Mutez Tests *) let%expect_test "mutez zero" = @@ -121,6 +133,7 @@ let%expect_test "mutez zero" = Optimised: { PUSH mutez 0 } |}] +;; let%expect_test "mutez small" = test_expr (mutez 123); @@ -129,6 +142,7 @@ let%expect_test "mutez small" = Optimised: { PUSH mutez 123 } |}] +;; let%expect_test "mutez large" = test_expr (mutez 10000000); @@ -137,6 +151,7 @@ let%expect_test "mutez large" = Optimised: { PUSH mutez 10000000 } |}] +;; (* String Tests *) let%expect_test "string empty" = @@ -146,6 +161,7 @@ let%expect_test "string empty" = Optimised: { PUSH string "" } |}] +;; let%expect_test "string ascii" = test_expr (string "hello"); @@ -154,6 +170,7 @@ let%expect_test "string ascii" = Optimised: { PUSH string "hello" } |}] +;; let%expect_test "string unicode" = test_expr (string "こんにちは"); @@ -162,6 +179,7 @@ let%expect_test "string unicode" = Optimised: { PUSH string "こんにちは" } |}] +;; (* Key Tests *) let%expect_test "key example1" = @@ -172,6 +190,7 @@ let%expect_test "key example1" = Optimised: { PUSH key "edpkExampleKeyString" } |}] +;; (* Key_hash Tests *) let%expect_test "key_hash tz1" = @@ -182,6 +201,7 @@ let%expect_test "key_hash tz1" = Optimised: { PUSH key_hash "tz1abc123abc123abc123" } |}] +;; let%expect_test "key_hash tz2" = test_expr (key_hash "tz2xyz456xyz456xyz456"); @@ -191,6 +211,7 @@ let%expect_test "key_hash tz2" = Optimised: { PUSH key_hash "tz2xyz456xyz456xyz456" } |}] +;; (* Bytes Tests *) let%expect_test "bytes empty" = @@ -200,6 +221,7 @@ let%expect_test "bytes empty" = Optimised: { PUSH bytes 0x3078 } |}] +;; let%expect_test "bytes small" = test_expr (bytes "0xFF"); @@ -209,6 +231,7 @@ let%expect_test "bytes small" = Optimised: { PUSH bytes 0x30784646 } |}] +;; let%expect_test "bytes bigger" = test_expr (bytes "0xDEADBEEF"); @@ -218,6 +241,7 @@ let%expect_test "bytes bigger" = Optimised: { PUSH bytes 0x30784445414442454546 } |}] +;; (* Chain_id Tests *) let%expect_test "chain_id mainnet" = @@ -228,6 +252,7 @@ let%expect_test "chain_id mainnet" = Optimised: { PUSH chain_id "NetXdQprcVkpaWU" } |}] +;; let%expect_test "chain_id ghostnet" = test_expr (chain_id "NetXnHfVqm9iesp"); @@ -237,6 +262,7 @@ let%expect_test "chain_id ghostnet" = Optimised: { PUSH chain_id "NetXnHfVqm9iesp" } |}] +;; (* Address Tests *) let%expect_test "address kt1 contract" = @@ -247,6 +273,7 @@ let%expect_test "address kt1 contract" = Optimised: { PUSH address "KT1ExampleContractAddress" } |}] +;; let%expect_test "address tz1 implicit" = test_expr (address_const "tz1ExampleImplicitAddress"); @@ -256,6 +283,7 @@ let%expect_test "address tz1 implicit" = Optimised: { PUSH address "tz1ExampleImplicitAddress" } |}] +;; (* Timestamp Tests *) let%expect_test "timestamp epoch" = @@ -265,6 +293,7 @@ let%expect_test "timestamp epoch" = Optimised: { PUSH timestamp 0 } |}] +;; (* Large future date, or something well beyond typical usage. *) let%expect_test "timestamp far-future" = @@ -275,6 +304,7 @@ let%expect_test "timestamp far-future" = Optimised: { PUSH timestamp 253402300799 } |}] +;; (* BLS12-381 G1, G2, FR Tests *) let%expect_test "bls12_381_g1 short" = @@ -285,6 +315,7 @@ let%expect_test "bls12_381_g1 short" = Optimised: { PUSH bls12_381_g1 0x424c5331325f3338315f473153686f72744578616d706c65 } |}] +;; let%expect_test "bls12_381_g2 short" = test_expr (bls12_381_g2 "BLS12_381_G2ShortExample"); @@ -294,6 +325,7 @@ let%expect_test "bls12_381_g2 short" = Optimised: { PUSH bls12_381_g2 0x424c5331325f3338315f473253686f72744578616d706c65 } |}] +;; let%expect_test "bls12_381_fr short" = test_expr (bls12_381_fr "BLS12_381_FRShortExample"); @@ -303,6 +335,7 @@ let%expect_test "bls12_381_fr short" = Optimised: { PUSH bls12_381_fr 0x424c5331325f3338315f465253686f72744578616d706c65 } |}] +;; (* Signature Tests *) let%expect_test "signature short" = @@ -313,6 +346,7 @@ let%expect_test "signature short" = Optimised: { PUSH signature "edsigShortExampleSignature" } |}] +;; let%expect_test "signature typical" = test_expr @@ -326,6 +360,7 @@ let%expect_test "signature typical" = Optimised: { PUSH signature "edsigthT3ab6iK1ZPw6u9JN7nUeadfZtQ1Qvo8CeCD3ScH7GpdiQA69rVbX7fNCRbs6Sr9aBii1qmuXun5qRmEuA9N2Dg9LGQdN" } |}] +;; (* let x = 1 in x *) let%expect_test "variable x" = @@ -335,6 +370,7 @@ let%expect_test "variable x" = Optimised: { PUSH nat 1 } |}] +;; (* let x = -42 in x *) let%expect_test "variable usage: let_in (bind + reference)" = @@ -345,7 +381,7 @@ let%expect_test "variable usage: let_in (bind + reference)" = Optimised: { PUSH int -42 } |}] - +;; (* let x = 42 in let y = x + 1 in @@ -368,6 +404,7 @@ let%expect_test "nested let_in (two bindings, referencing each other)" = Optimised: { PUSH nat 42 ; PUSH nat 1 ; ADD } |}] +;; (* let x = 10 in let x = x + 5 in @@ -390,6 +427,7 @@ let%expect_test "let_in variable shadowing" = Optimised: { PUSH nat 10 ; PUSH nat 5 ; ADD } |}] +;; (* let mut x = 0 in let _ = x <- 1 in @@ -412,12 +450,12 @@ let%expect_test "let_mut_in usage (assign, reassign, read)" = Optimised: { PUSH nat 1 } |}] - +;; (* let mut x = 10 in let ignore1 = x <- (x + 1) in let ignore2 = x <- (x + 2) in - x *) + x *) let%expect_test "multiple sequential assign" = let mut_x = mut_var "x" in let expr = @@ -457,13 +495,13 @@ let%expect_test "multiple sequential assign" = Optimised: { PUSH nat 10 ; PUSH nat 1 ; ADD ; PUSH nat 2 ; ADD } |}] - +;; (* let mut x = 0 in let ignored = if 1 = 2 then (x <- x + 100) - else if 3 < 4 then (x <- x + 200) - else (x <- x + 300) in - x *) + else if 3 < 4 then (x <- x + 200) + else (x <- x + 300) in + x *) let%expect_test "assign inside nested if_bool" = let mut_x = mut_var "x" in let nested_if = @@ -503,11 +541,12 @@ let%expect_test "assign inside nested if_bool" = Optimised: { PUSH nat 0 ; PUSH nat 200 ; ADD } |}] +;; (* let mut x = 5 in let ignore1 = x <- 5 in let ignore2 = x <- 5 in - x *) + x *) let%expect_test "assign same value repeatedly" = let mut_x = mut_var "x" in let expr = @@ -543,11 +582,12 @@ let%expect_test "assign same value repeatedly" = Optimised: { PUSH nat 5 } |}] +;; (* let mut x = 10 in let ignore1 = x <- (x + 10) in let ignore2 = x <- (x + x) in - x *) + x *) let%expect_test "assign referencing the updated var" = let mut_x = mut_var "x" in let first_assign = assign mut_x (add (deref mut_x nat_ty) (nat 10)) in @@ -585,11 +625,12 @@ let%expect_test "assign referencing the updated var" = Optimised: { PUSH nat 10 ; DUP ; ADD ; DUP ; ADD } |}] +;; (* let mut x = 0 in let ignore_while = while x < 3 do - x <- (x + x + 1) - done in + x <- (x + x + 1) + done in x *) let%expect_test "assign inside while" = let mut_x = mut_var "x" in @@ -635,6 +676,7 @@ let%expect_test "assign inside while" = COMPARE ; LT ; LOOP { PUSH nat 1 ; SWAP ; DUP ; ADD ; ADD ; PUSH nat 3 ; DUP 2 ; COMPARE ; LT } } |}] +;; (* let mut x = 100 in if x = 100 then x <- (x - 50) @@ -669,14 +711,15 @@ let%expect_test "assign same var multiple branches" = EQ ; IF { PUSH int -50 ; ADD ; DROP } { PUSH int -10 ; ADD ; DROP } ; UNIT } |}] +;; (* let mut x = 0 in let mut i = 0 in - let ignore_for = for i from 0 while i < 4 do - x <- x + i; - i <- i + 1 - done in - x *) + let ignore_for = for i from 0 while i < 4 do + x <- x + i; + i <- i + 1 + done in + x *) let%expect_test "assign inside for loop" = let idx = mut_var "i" in let mut_x = mut_var "x" in @@ -750,6 +793,7 @@ let%expect_test "assign inside for loop" = COMPARE ; LT } ; DROP 2 } |}] +;; (* let mut x = 123 in x <- "changed" *) @@ -764,6 +808,7 @@ let%expect_test "assign same var different type" = Optimised: { UNIT } |}] +;; (* let b = true in if b then 10 else 20 *) let%expect_test "let_in + if_bool" = @@ -780,10 +825,11 @@ let%expect_test "let_in + if_bool" = Optimised: { PUSH nat 10 } |}] +;; (* let x = 1 in let y = 2 in - if true then x else y *) + if true then x else y *) let%expect_test "let_in referencing previous var inside if_bool" = let expr = let_in @@ -809,10 +855,11 @@ let%expect_test "let_in referencing previous var inside if_bool" = Optimised: { PUSH nat 1 } |}] +;; (* let x = 10 in let y = -5 in - (fun z -> z * 2) (y + x) *) + (fun z -> z * 2) (y + x) *) let%expect_test "nested let_in" = let expr = let_in @@ -841,6 +888,7 @@ let%expect_test "nested let_in" = Optimised: { PUSH nat 10 ; PUSH int -5 ; ADD ; PUSH nat 2 ; SWAP ; MUL } |}] +;; (* fun x -> let z = 5 in x + z *) let%expect_test "lambda that uses let_in" = @@ -860,9 +908,10 @@ let%expect_test "lambda that uses let_in" = Optimised: { LAMBDA nat nat { PUSH nat 5 ; ADD } } |}] +;; (* let rec f x = - if x <= 0 then 1 else 1 + f(x - 1) + if x <= 0 then 1 else 1 + f(x - 1) in f *) let%expect_test "recursive lambda usage" = let lam_rec_expr = @@ -901,6 +950,7 @@ let%expect_test "recursive lambda usage" = INT ; LE ; IF { DROP 2 ; PUSH nat 1 } { PUSH int -1 ; ADD ; EXEC } } } |}] +;; (* let mut x = 100 in if false then x := 200 else x := 300 *) @@ -925,6 +975,7 @@ let%expect_test "let_mut_in + assign in if_bool" = Optimised: { UNIT } |}] +;; (* fun (x: bool) -> x *) let%expect_test "lambda returning same type: bool -> bool" = @@ -935,6 +986,7 @@ let%expect_test "lambda returning same type: bool -> bool" = Optimised: { LAMBDA bool bool {} } |}] +;; (* fun (x: string) -> if x = "secret" then true else false *) let%expect_test "lambda returning different type: string -> bool" = @@ -961,6 +1013,7 @@ let%expect_test "lambda returning different type: string -> bool" = Optimised: { LAMBDA string bool { PUSH string "secret" ; COMPARE ; EQ } } |}] +;; (* fun (x: address) -> (now, x) *) let%expect_test "lambda returning tuple" = @@ -977,11 +1030,11 @@ let%expect_test "lambda returning tuple" = Optimised: { LAMBDA address (pair timestamp address) { NOW ; PAIR } } |}] +;; - -(* let rec f (n: int) = - if n <= 1 then 1 - else n * f(n - 1) +(* let rec f (n: int) = + if n <= 1 then 1 + else n * f(n - 1) in f *) let%expect_test "lambda_rec factorial" = let n_var = var "n" in @@ -1024,6 +1077,7 @@ let%expect_test "lambda_rec factorial" = LE ; IF { DROP 2 ; PUSH int 1 } { PUSH int 1 ; DUP 2 ; SUB ; DIG 2 ; SWAP ; EXEC ; SWAP ; MUL } } } |}] +;; (* fun (x: nat) -> (fun (y: nat) -> y + 2) *) let%expect_test "nested lambda" = @@ -1039,6 +1093,7 @@ let%expect_test "nested lambda" = Optimised: { LAMBDA nat (lambda nat nat) { DROP ; LAMBDA nat nat { PUSH nat 2 ; ADD } } } |}] +;; (* let x = (fun (y: nat) -> 3 * y) in x 5 *) let%expect_test "lambda in let" = @@ -1058,6 +1113,7 @@ let%expect_test "lambda in let" = Optimised: { LAMBDA nat nat { PUSH nat 3 ; MUL } ; PUSH nat 5 ; EXEC } |}] +;; (* if 1 <> 2 then (fun (x: nat) -> x + 2) else (fun (y: nat) -> y - 3) *) @@ -1084,6 +1140,7 @@ let%expect_test "if with lambda" = NEQ ; IF { LAMBDA nat nat { PUSH nat 2 ; ADD } } { LAMBDA nat int { PUSH int -3 ; ADD } } } |}] +;; (* (fun (x: string) -> x = "hello") "test" *) let%expect_test "app: lambda (string->bool) applied to a string" = @@ -1101,6 +1158,7 @@ let%expect_test "app: lambda (string->bool) applied to a string" = Optimised: { PUSH string "test" ; PUSH string "hello" ; COMPARE ; EQ } |}] +;; (* let mut s = "hello" in let ignore = s <- "world" in s *) @@ -1128,6 +1186,7 @@ let%expect_test "let_mut_in: assign string" = Optimised: { PUSH string "world" } |}] +;; (* let mut counter = 0 in fun (u: unit) -> counter *) let%expect_test "deref inside lambda body" = @@ -1148,6 +1207,7 @@ let%expect_test "deref inside lambda body" = Optimised: { LAMBDA (pair nat unit) nat { CAR } ; PUSH nat 0 ; APPLY } |}] +;; (* let mut x = 42 in if true then x <- 100 else x <- 200 *) let%expect_test "assign inside if_bool" = @@ -1172,10 +1232,11 @@ let%expect_test "assign inside if_bool" = Optimised: { UNIT } |}] +;; -(* let rec factorial (n: int) = - if n <= 1 then 1 - else n * factorial(n - 1) +(* let rec factorial (n: int) = + if n <= 1 then 1 + else n * factorial(n - 1) in factorial 5 *) let%expect_test "app of lambda_rec factorial with let_in" = let n_var = var "n" in @@ -1224,6 +1285,7 @@ let%expect_test "app of lambda_rec factorial with let_in" = { PUSH int 1 ; DUP 2 ; SUB ; DIG 2 ; SWAP ; EXEC ; SWAP ; MUL } } ; PUSH int 5 ; EXEC } |}] +;; (* if true then "A" else "B" *) let%expect_test "if bool 1" = @@ -1235,6 +1297,7 @@ let%expect_test "if bool 1" = Optimised: { PUSH string "A" } |}] +;; (* if 2 = 2 then 100 else -1 *) let%expect_test "if bool 2" = @@ -1250,6 +1313,7 @@ let%expect_test "if bool 2" = Optimised: { PUSH int 100 } |}] +;; (* if 1 = 2 then (if 1 <= 10 then 1 else 2) else 3 *) let%expect_test "nested if_bool" = @@ -1275,7 +1339,7 @@ let%expect_test "nested if_bool" = Optimised: { PUSH nat 3 } |}] - +;; (* match some 10 with | None -> "none" @@ -1300,6 +1364,7 @@ let%expect_test "if none 1" = { PUSH nat 10 ; SOME ; IF_NONE { PUSH string "none" } { PUSH nat 5 ; ADD } } |}] +;; (* match none with | None -> true @@ -1319,7 +1384,7 @@ let%expect_test "if none 2" = Optimised: { NONE bool ; IF_NONE { PUSH bool True } { NOT } } |}] - +;; (* match [1;2] with | [] -> 0 @@ -1349,6 +1414,7 @@ let%expect_test "if cons 1" = Optimised: { PUSH (list nat) { 1 ; 2 } ; IF_CONS { DROP 2 ; PUSH string "nonempty" } { PUSH nat 0 } } |}] +;; (* match [] with | [] -> "empty" @@ -1374,7 +1440,7 @@ let%expect_test "if cons 2" = Optimised: { NIL string ; IF_CONS { DROP 2 ; PUSH string "nonempty" } { PUSH string "empty" } } |}] - +;; (* match Left false with | Left l -> "left" @@ -1398,6 +1464,7 @@ let%expect_test "if left" = { PUSH bool False ; LEFT bool ; IF_LEFT { DROP ; PUSH string "left" } { DROP ; PUSH string "right" } } |}] +;; (* match Right true with | Left l -> 0 @@ -1421,6 +1488,7 @@ let%expect_test "if left 2" = { PUSH bool True ; RIGHT bool ; IF_LEFT { DROP ; PUSH int 0 } { DROP ; PUSH int 1 } } |}] +;; (* let mut i = 0 in while i < 3 do i := i + 1 done *) let%expect_test "while" = @@ -1461,9 +1529,10 @@ let%expect_test "while" = LOOP { PUSH int 1 ; ADD ; PUSH int 3 ; DUP 2 ; COMPARE ; LT } ; DROP ; UNIT } |}] +;; (* while 0 <= 10 do - let x = 7 in if x >= 5 then x := 2 else x := 2 done *) + let x = 7 in if x >= 5 then x := 2 else x := 2 done *) let%expect_test "while with complex body" = let body_expr = let_in @@ -1499,10 +1568,11 @@ let%expect_test "while with complex body" = Optimised: { PUSH int -1 ; LE ; LOOP { PUSH int -1 ; LE } ; UNIT } |}] +;; (* let start = Left false in while_left start do - if v then Right "done" else Left true done *) + if v then Right "done" else Left true done *) let%expect_test "while left" = let start_val = left (None, None, bool_ty) (bool false) in let e = @@ -1532,6 +1602,7 @@ let%expect_test "while left" = LEFT string ; LOOP_LEFT { IF { PUSH string "done" ; RIGHT string } { PUSH bool True ; LEFT bool } } } |}] +;; (* let mut i = 0 in for i from 0 while i < 3 do "looping" done *) @@ -1581,7 +1652,7 @@ let%expect_test "for" = LOOP { PUSH nat 1 ; ADD ; PUSH nat 3 ; DUP 2 ; COMPARE ; LT } ; DROP ; UNIT } |}] - +;; (* for each s in ["one"; "two"] do true end *) let%expect_test "for each" = @@ -1600,6 +1671,7 @@ let%expect_test "for each" = Optimised: { PUSH (list string) { "one" ; "two" } ; ITER { DROP } ; UNIT } |}] +;; (* map (fun (x: int) -> x + 10) over [1;2] *) let%expect_test "map1" = @@ -1621,6 +1693,7 @@ let%expect_test "map1" = Optimised: { PUSH (list int) { 1 ; 2 } ; MAP { PUSH int 10 ; ADD } } |}] +;; (* map (fun (b: bool) -> not b) over some true *) let%expect_test "map2" = @@ -1637,6 +1710,7 @@ let%expect_test "map2" = Optimised: { PUSH bool True ; SOME ; MAP { NOT } } |}] +;; (* map (fun (x: nat) -> x + 10) over [1;2;3] *) let%expect_test "map with operations" = @@ -1659,6 +1733,7 @@ let%expect_test "map with operations" = Optimised: { PUSH (list nat) { 1 ; 2 ; 3 } ; MAP { PUSH nat 10 ; ADD } } |}] +;; (* fold_left [2;3] ~init:1 ~fold:(fun acc_x -> (car acc_x) * (cdr acc_x)) *) let%expect_test "fold left" = @@ -1695,6 +1770,7 @@ let%expect_test "fold left" = Optimised: { PUSH nat 1 ; PUSH (list nat) { 2 ; 3 } ; ITER { SWAP ; MUL } } |}] +;; (* fold_left [1;2;3] ~init:0 ~fold:(fun acc_x -> (car acc_x) + (cdr acc_x)) *) let%expect_test "fold_left with operations" = @@ -1730,6 +1806,7 @@ let%expect_test "fold_left with operations" = Optimised: { PUSH nat 0 ; PUSH (list nat) { 1 ; 2 ; 3 } ; ITER { ADD } } |}] +;; (* fold_right [1;2] ~init:0 ~fold:(fun (elem_acc: int * int) -> fst elem_acc + snd elem_acc) *) let%expect_test "fold right" = @@ -1773,6 +1850,7 @@ let%expect_test "fold right" = PUSH (list int) { 1 ; 2 } ; ITER { CONS } ; ITER { ADD } } |}] +;; (* fold_right [1;2;3] ~init:0 ~fold:(fun (x_acc: nat * nat) -> snd x_acc - fst x_acc) *) let%expect_test "fold_right with operations" = @@ -1815,6 +1893,7 @@ let%expect_test "fold_right with operations" = PUSH (list nat) { 1 ; 2 ; 3 } ; ITER { CONS } ; ITER { SWAP ; SUB } } |}] +;; (* let (x, b) = (1, true) in if b then x + 10 else 0 *) let%expect_test "let tuple in basic" = @@ -1841,6 +1920,7 @@ let%expect_test "let tuple in basic" = Optimised: { PUSH nat 1 ; PUSH nat 10 ; ADD } |}] +;; (* let (p, flag) = ((2, 5), false) in if flag then fst p else snd p *) let%expect_test "let tuple in nested" = @@ -1880,6 +1960,7 @@ let%expect_test "let tuple in nested" = Optimised: { PUSH nat 5 } |}] +;; (* let (x, y, z) = (1,2,3) in let a = (y, z)[0] in a + x *) let%expect_test "nested tuple and projection" = @@ -1921,6 +2002,7 @@ let%expect_test "nested tuple and projection" = Optimised: { PUSH nat 3 ; PUSH nat 2 ; PUSH nat 1 ; DIG 2 ; DROP ; ADD } |}] +;; (* ("hello", 42, false)[1] *) let%expect_test "proj second element" = @@ -1938,6 +2020,7 @@ let%expect_test "proj second element" = Optimised: { PUSH bool False ; PUSH int 42 ; PUSH string "hello" ; PAIR 3 ; GET 3 } |}] +;; (* ("s", (10, 20))[1][0] *) let%expect_test "proj nested element" = @@ -1952,6 +2035,7 @@ let%expect_test "proj nested element" = Optimised: { PUSH nat 10 } |}] +;; (* update (true, 123) at index 1 with 999 *) let%expect_test "update tuple index" = @@ -1972,6 +2056,7 @@ let%expect_test "update tuple index" = Optimised: { PUSH nat 123 ; PUSH bool True ; PAIR ; PUSH nat 999 ; UPDATE 2 } |}] +;; (* TODO: INJ/MATCH used in SmartPY let%expect_test "inj two branch" = @@ -2061,6 +2146,7 @@ let push_int n = ; Int (Ast_builder.Dummy_range.v, Z.of_int n) ] , [] ) +;; let seq_of_prim prim = Tezos_micheline.Micheline.Seq (Ast_builder.Dummy_range.v, [ prim ]) let seq instrs = Tezos_micheline.Micheline.Seq (Ast_builder.Dummy_range.v, instrs) @@ -2075,6 +2161,7 @@ let%expect_test "raw michelson single push int" = Optimised: { PUSH int 42 } |}] +;; (* raw_michelson { PUSH int 3 ; PUSH int 5 ; ADD } : int *) let%expect_test "raw michelson multiple instructions" = @@ -2092,6 +2179,7 @@ let%expect_test "raw michelson multiple instructions" = Optimised: { PUSH int 8 } |}] +;; (* raw_michelson (args=[2; 8]) { MUL } : int *) let%expect_test "raw michelson with arguments" = @@ -2105,6 +2193,7 @@ let%expect_test "raw michelson with arguments" = Optimised: { PUSH int 16 } |}] +;; (* raw_michelson { PUSH string "hello" } : string *) let%expect_test "raw michelson returning string" = @@ -2130,6 +2219,7 @@ let%expect_test "raw michelson returning string" = Optimised: { PUSH string "hello" } |}] +;; (* raw_michelson { PUSH int 10 ; PUSH int 20 ; PAIR ; DUP } : (int * int) *) let%expect_test "raw michelson complex seq" = @@ -2156,12 +2246,14 @@ let%expect_test "raw michelson complex seq" = Optimised: { PUSH int 10 ; PUSH int 20 ; PAIR ; DUP } |}] +;; let operation_list_ty = list_ty operation_ty let return_no_ops stg_expr stg_ty = ( tuple (mk_row [ Leaf (None, nil operation_ty); Leaf (None, stg_expr) ]) , mk_tuple_ty [ operation_list_ty; stg_ty ] ) +;; (* create_contract: { parameter unit; storage nat } @@ -2170,7 +2262,7 @@ let return_no_ops stg_expr stg_ty = code = fun (p, s) -> let new_s = s + 1 in ([], new_s) - *) +*) let%expect_test "create contract unit nat increment" = let storage_ty = nat_ty in let initial_storage_expr = nat 100 in @@ -2213,7 +2305,7 @@ let%expect_test "create contract unit nat increment" = storage nat ; code { CDR ; PUSH nat 1 ; ADD ; NIL operation ; PAIR } } ; PAIR } |}] - +;; (* create_contract: { parameter bool; storage string } @@ -2224,7 +2316,7 @@ let%expect_test "create contract unit nat increment" = if flag then ([], "param was true") else ([], "param was false") - *) +*) let%expect_test "create contract bool string conditional" = let storage_ty = string_ty in let initial_storage_expr = string "init" in @@ -2283,6 +2375,7 @@ let%expect_test "create contract bool string conditional" = NIL operation ; PAIR } } ; PAIR } |}] +;; (* create_contract: { parameter int; storage int } @@ -2292,7 +2385,7 @@ let%expect_test "create contract bool string conditional" = if p = 0 then ([], 999) else let new_s = p + s in ([], new_s) - *) +*) let%expect_test "create contract int int accumulation" = let storage_ty = int_ty in let initial_storage_expr = int 5 in @@ -2352,13 +2445,14 @@ let%expect_test "create contract int int accumulation" = NIL operation ; PAIR } } ; PAIR } |}] +;; (* create_contract: { parameter nat; storage address } initial_balance = 1234567 mutez initial_storage = KT1InitialAddress code = fun (p, st) -> ([], st) - *) +*) let%expect_test "create contract nat address no change" = let storage_ty = address_ty in let initial_storage_expr = address_const "KT1InitialAddress" in @@ -2400,7 +2494,7 @@ let%expect_test "create contract nat address no change" = CREATE_CONTRACT { parameter nat ; storage address ; code { CDR ; NIL operation ; PAIR } } ; PAIR } |}] - +;; (* create_contract: { parameter unit; storage bool } @@ -2410,7 +2504,7 @@ let%expect_test "create contract nat address no change" = if s then ([], true) else ([], true) - *) +*) let%expect_test "create contract bool flip storage" = let storage_ty = bool_ty in let initial_storage_expr = bool false in @@ -2464,6 +2558,7 @@ let%expect_test "create contract bool flip storage" = NIL operation ; PAIR } } ; PAIR } |}] +;; (* create_contract: { parameter nat; storage nat } @@ -2473,7 +2568,7 @@ let%expect_test "create contract bool flip storage" = let x = 1 in let new_s = x + 2 in ([], new_s) - *) +*) let%expect_test "create contract complex" = let storage_ty = nat_ty in let param_storage_ty = mk_tuple_ty [ nat_ty; nat_ty ] in @@ -2531,6 +2626,7 @@ let%expect_test "create contract complex" = storage nat ; code { DROP ; PUSH nat 1 ; PUSH nat 2 ; ADD ; NIL operation ; PAIR } } ; PAIR } |}] +;; (* ARITY 0 PRIMITIVES *) @@ -2542,6 +2638,7 @@ let%expect_test "amount basic" = Optimised: { AMOUNT } |}] +;; let%expect_test "balance basic" = let e = balance in @@ -2551,6 +2648,7 @@ let%expect_test "balance basic" = Optimised: { BALANCE } |}] +;; let%expect_test "chain_id basic" = let e = chain_id_prim in @@ -2560,6 +2658,7 @@ let%expect_test "chain_id basic" = Optimised: { CHAIN_ID } |}] +;; let%expect_test "level basic" = let e = level in @@ -2569,6 +2668,7 @@ let%expect_test "level basic" = Optimised: { LEVEL } |}] +;; let%expect_test "now basic" = let e = now in @@ -2578,6 +2678,7 @@ let%expect_test "now basic" = Optimised: { NOW } |}] +;; let%expect_test "self without entrypoint" = let contract_type = contract_ty unit_ty in @@ -2588,6 +2689,7 @@ let%expect_test "self without entrypoint" = Optimised: { SELF } |}] +;; let%expect_test "self with entrypoint" = let contract_type = contract_ty nat_ty in @@ -2598,6 +2700,7 @@ let%expect_test "self with entrypoint" = Optimised: { SELF %test_entry } |}] +;; let%expect_test "self_address basic" = let e = self_address in @@ -2607,6 +2710,7 @@ let%expect_test "self_address basic" = Optimised: { SELF_ADDRESS } |}] +;; let%expect_test "sender basic" = let e = sender in @@ -2616,6 +2720,7 @@ let%expect_test "sender basic" = Optimised: { SENDER } |}] +;; let%expect_test "source basic" = let e = source in @@ -2625,6 +2730,7 @@ let%expect_test "source basic" = Optimised: { SOURCE } |}] +;; let%expect_test "total_voting_power basic" = let e = total_voting_power in @@ -2634,6 +2740,7 @@ let%expect_test "total_voting_power basic" = Optimised: { TOTAL_VOTING_POWER } |}] +;; let%expect_test "empty_bigmap nat->int" = let e = empty_bigmap nat_ty int_ty in @@ -2644,6 +2751,7 @@ let%expect_test "empty_bigmap nat->int" = Optimised: { EMPTY_BIG_MAP nat int } |}] +;; let%expect_test "empty_map string->bool" = let e = empty_map string_ty bool_ty in @@ -2654,6 +2762,7 @@ let%expect_test "empty_map string->bool" = Optimised: { EMPTY_MAP string bool } |}] +;; let%expect_test "empty_set address" = let e = empty_set address_ty in @@ -2663,6 +2772,7 @@ let%expect_test "empty_set address" = Optimised: { EMPTY_SET address } |}] +;; let%expect_test "nil int" = let e = nil int_ty in @@ -2672,6 +2782,7 @@ let%expect_test "nil int" = Optimised: { NIL int } |}] +;; let%expect_test "none bool" = let e = none bool_ty in @@ -2681,6 +2792,7 @@ let%expect_test "none bool" = Optimised: { NONE bool } |}] +;; let%expect_test "sapling_empty_state memo8" = let e = sapling_empty_state 8 in @@ -2691,6 +2803,7 @@ let%expect_test "sapling_empty_state memo8" = Optimised: { SAPLING_EMPTY_STATE 8 } |}] +;; let%expect_test "unit prim" = let e = unit_prim in @@ -2700,6 +2813,7 @@ let%expect_test "unit prim" = Optimised: { UNIT } |}] +;; (* ARITY 1/2 PRIMITIVES *) @@ -2713,6 +2827,7 @@ let%expect_test "car on pair" = Optimised: { PUSH int 1 } |}] +;; let%expect_test "cdr on pair" = let pair_expr = pair (None, None) (int 1) (int 2) in @@ -2724,6 +2839,7 @@ let%expect_test "cdr on pair" = Optimised: { PUSH int 2 } |}] +;; let%expect_test "left constructor" = let e = left (None, None, string_ty) (int 42) in @@ -2734,6 +2850,7 @@ let%expect_test "left constructor" = Optimised: { PUSH int 42 ; LEFT string } |}] +;; let%expect_test "right constructor" = let e = right (None, None, bool_ty) (string "test") in @@ -2744,6 +2861,7 @@ let%expect_test "right constructor" = Optimised: { PUSH string "test" ; RIGHT bool } |}] +;; let%expect_test "some constructor" = let e = some (nat 999) in @@ -2753,6 +2871,7 @@ let%expect_test "some constructor" = Optimised: { PUSH nat 999 ; SOME } |}] +;; let%expect_test "abs on negative int" = let e = abs (int (-42)) in @@ -2762,6 +2881,7 @@ let%expect_test "abs on negative int" = Optimised: { PUSH int -42 ; ABS } |}] +;; let%expect_test "neg on nat (coerced to int)" = let e = neg (nat 10) in @@ -2771,6 +2891,7 @@ let%expect_test "neg on nat (coerced to int)" = Optimised: { PUSH int -10 } |}] +;; let%expect_test "nat_prim from int" = let e = nat_prim (int 50) in @@ -2780,6 +2901,7 @@ let%expect_test "nat_prim from int" = Optimised: { PUSH int 50 ; NAT } |}] +;; let%expect_test "int_prim from nat" = let e = int_prim (nat 123) in @@ -2789,6 +2911,7 @@ let%expect_test "int_prim from nat" = Optimised: { PUSH nat 123 ; INT } |}] +;; let%expect_test "bytes_prim from string" = let e = bytes_prim (string "raw") in @@ -2799,6 +2922,7 @@ let%expect_test "bytes_prim from string" = Optimised: { PUSH string "raw" ; BYTES } |}] +;; let%expect_test "is_nat with negative int" = let e = is_nat (int (-100)) in @@ -2809,6 +2933,7 @@ let%expect_test "is_nat with negative int" = Optimised: { PUSH int -100 ; ISNAT } |}] +;; let%expect_test "compare eq int" = let e = eq (int 2) (int 2) in @@ -2819,6 +2944,7 @@ let%expect_test "compare eq int" = Optimised: { PUSH bool True } |}] +;; let%expect_test "compare neq string" = let e = neq (string "hello") (string "world") in @@ -2829,6 +2955,7 @@ let%expect_test "compare neq string" = Optimised: { PUSH string "world" ; PUSH string "hello" ; COMPARE ; NEQ } |}] +;; let%expect_test "compare lt nat" = let e = lt (nat 5) (nat 10) in @@ -2839,6 +2966,7 @@ let%expect_test "compare lt nat" = Optimised: { PUSH bool True } |}] +;; let%expect_test "compare gt int" = let e = gt (int 10) (int 3) in @@ -2849,6 +2977,7 @@ let%expect_test "compare gt int" = Optimised: { PUSH bool True } |}] +;; let%expect_test "compare le int" = let e = le (int 1) (int 1) in @@ -2859,6 +2988,7 @@ let%expect_test "compare le int" = Optimised: { PUSH int 0 ; LE } |}] +;; let%expect_test "compare ge string" = let e = ge (string "a") (string "b") in @@ -2869,6 +2999,7 @@ let%expect_test "compare ge string" = Optimised: { PUSH string "b" ; PUSH string "a" ; COMPARE ; GE } |}] +;; let%expect_test "not bool" = let e = not (bool false) in @@ -2878,6 +3009,7 @@ let%expect_test "not bool" = Optimised: { PUSH bool True } |}] +;; let%expect_test "not int" = let e = not (int 123) in @@ -2887,6 +3019,7 @@ let%expect_test "not int" = Optimised: { PUSH int 123 ; NOT } |}] +;; let%expect_test "size on bytes" = let e = size (bytes "0xABCDEF") in @@ -2897,6 +3030,7 @@ let%expect_test "size on bytes" = Optimised: { PUSH bytes 0x3078414243444546 ; SIZE } |}] +;; let%expect_test "address of contract" = let contract_expr = self None (contract_ty unit_ty) in @@ -2907,6 +3041,7 @@ let%expect_test "address of contract" = Optimised: { SELF_ADDRESS } |}] +;; let%expect_test "implicit_account key_hash" = let e = implicit_account (key_hash "tz1ABC123") in @@ -2939,6 +3074,18 @@ let%expect_test "contract opt (bool_ty) address" = Optimised: { PUSH address "KT1XYZ" ; CONTRACT bool } |}] +;; + +let%expect_test "contract with named ep opt (bool_ty) address" = + let e = contract (Some "%the_ep", bool_ty) (address_const "KT1XYZ") in + test_expr e; + [%expect + {| + { PUSH address "KT1XYZ" ; CONTRACT %the_ep bool } + + Optimised: + { PUSH address "KT1XYZ" ; CONTRACT %the_ep bool } |}] +;; let%expect_test "pack int" = let e = pack (int (-7)) in @@ -2948,6 +3095,7 @@ let%expect_test "pack int" = Optimised: { PUSH int -7 ; PACK } |}] +;; let%expect_test "unpack string" = let e = unpack string_ty (bytes "0xDEADBEEF") in @@ -2958,6 +3106,7 @@ let%expect_test "unpack string" = Optimised: { PUSH bytes 0x30784445414442454546 ; UNPACK string } |}] +;; let%expect_test "hash_key key" = let e = hash_key (key "edpkExampleKey") in @@ -2968,6 +3117,7 @@ let%expect_test "hash_key key" = Optimised: { PUSH key "edpkExampleKey" ; HASH_KEY } |}] +;; let%expect_test "blake2b bytes" = let e = blake2b (bytes "0xAB12") in @@ -2978,6 +3128,7 @@ let%expect_test "blake2b bytes" = Optimised: { PUSH bytes 0x307841423132 ; BLAKE2B } |}] +;; let%expect_test "sha256 bytes" = let e = sha256 (bytes "0xAB12") in @@ -2988,6 +3139,7 @@ let%expect_test "sha256 bytes" = Optimised: { PUSH bytes 0x307841423132 ; SHA256 } |}] +;; let%expect_test "sha512 bytes" = let e = sha512 (bytes "0xAB12") in @@ -2998,6 +3150,7 @@ let%expect_test "sha512 bytes" = Optimised: { PUSH bytes 0x307841423132 ; SHA512 } |}] +;; let%expect_test "keccak bytes" = let e = keccak (bytes "0xAB12") in @@ -3008,6 +3161,7 @@ let%expect_test "keccak bytes" = Optimised: { PUSH bytes 0x307841423132 ; KECCAK } |}] +;; let%expect_test "sha3 bytes" = let e = sha3 (bytes "0xAB12") in @@ -3018,6 +3172,7 @@ let%expect_test "sha3 bytes" = Optimised: { PUSH bytes 0x307841423132 ; SHA3 } |}] +;; let%expect_test "set_delegate none" = let e = set_delegate (none key_hash_ty) in @@ -3028,6 +3183,7 @@ let%expect_test "set_delegate none" = Optimised: { NONE key_hash ; SET_DELEGATE } |}] +;; let%expect_test "read_ticket ticket" = let unwrap_ticket = @@ -3056,6 +3212,7 @@ let%expect_test "read_ticket ticket" = IF_NONE { PUSH string "No ticket" ; FAILWITH } {} ; READ_TICKET ; PAIR } |}] +;; let%expect_test "join_tickets same type" = let t1_opt = ticket (string "C1") (nat 2) in @@ -3095,6 +3252,7 @@ let%expect_test "join_tickets same type" = TICKET ; IF_NONE { PUSH string "no ticket" ; FAILWITH } {} ; JOIN_TICKETS } |}] +;; let%expect_test "pairing_check bls12 list" = let g1 = bls12_381_g1 "G1" in @@ -3121,6 +3279,7 @@ let%expect_test "pairing_check bls12 list" = PAIR ; CONS ; PAIRING_CHECK } |}] +;; let%expect_test "voting_power key_hash" = let e = voting_power (key_hash "tz1Example") in @@ -3131,6 +3290,7 @@ let%expect_test "voting_power key_hash" = Optimised: { PUSH key_hash "tz1Example" ; VOTING_POWER } |}] +;; (*let%expect_test "getn usage" = (* Commented out as getn is not implemented *) @@ -3152,6 +3312,7 @@ let%expect_test "cast from int to int" = Optimised: { PUSH int 42 ; CAST int } |}] +;; let%expect_test "cast from nat to int" = let e = cast int_ty (nat 999) in @@ -3162,6 +3323,7 @@ let%expect_test "cast from nat to int" = Optimised: { PUSH nat 999 ; CAST int } |}] +;; let%expect_test "cast from bool to bool" = let e = cast bool_ty (bool true) in @@ -3172,6 +3334,7 @@ let%expect_test "cast from bool to bool" = Optimised: { PUSH bool True ; CAST bool } |}] +;; let%expect_test "emit basic" = let e = emit (None, None) (string "Event data") in @@ -3182,6 +3345,7 @@ let%expect_test "emit basic" = Optimised: { PUSH string "Event data" ; EMIT } |}] +;; let%expect_test "emit with no annotation" = let e = emit (None, Some string_ty) (string "Event data") in @@ -3192,6 +3356,7 @@ let%expect_test "emit with no annotation" = Optimised: { PUSH string "Event data" ; EMIT string } |}] +;; let%expect_test "emit with no data" = let e = emit (Some "LabelX", None) (string "Data2") in @@ -3202,6 +3367,7 @@ let%expect_test "emit with no data" = Optimised: { PUSH string "Data2" ; EMIT LabelX } |}] +;; let%expect_test "emit with label" = let e = emit (Some "LabelX", Some string_ty) (string "Data2") in @@ -3212,6 +3378,7 @@ let%expect_test "emit with label" = Optimised: { PUSH string "Data2" ; EMIT LabelX string } |}] +;; let%expect_test "failwith basic" = let e = failwith (string "Something went wrong") in @@ -3222,6 +3389,7 @@ let%expect_test "failwith basic" = Optimised: { PUSH string "Something went wrong" ; FAILWITH } |}] +;; let%expect_test "never basic" = let e = never (int 100) in @@ -3232,6 +3400,7 @@ let%expect_test "never basic" = Optimised: { PUSH int 100 ; NEVER } |}] +;; let%expect_test "pair simple" = let e = pair (None, None) (int 1) (int 2) in @@ -3242,6 +3411,7 @@ let%expect_test "pair simple" = Optimised: { PUSH int 2 ; PUSH int 1 ; PAIR } |}] +;; let%expect_test "pair with annotation" = let e = pair (Some "fst", Some "snd") (string "hi") (bool false) in @@ -3252,6 +3422,7 @@ let%expect_test "pair with annotation" = Optimised: { PUSH bool False ; PUSH string "hi" ; PAIR } |}] +;; let%expect_test "add nat nat" = let e = add (nat 3) (nat 5) in @@ -3262,6 +3433,7 @@ let%expect_test "add nat nat" = Optimised: { PUSH nat 5 ; PUSH nat 3 ; ADD } |}] +;; let%expect_test "add int nat" = let e = add (int (-2)) (nat 7) in @@ -3272,6 +3444,7 @@ let%expect_test "add int nat" = Optimised: { PUSH nat 7 ; PUSH int -2 ; ADD } |}] +;; let%expect_test "add timestamp int" = let e = add (timestamp "2023-01-01T00:00:00Z") (int 60) in @@ -3282,6 +3455,7 @@ let%expect_test "add timestamp int" = Optimised: { PUSH int 60 ; PUSH timestamp 1672531200 ; ADD } |}] +;; let%expect_test "mul nat nat" = let e = mul (nat 2) (nat 10) in @@ -3292,6 +3466,7 @@ let%expect_test "mul nat nat" = Optimised: { PUSH nat 10 ; PUSH nat 2 ; MUL } |}] +;; let%expect_test "mul int nat" = let e = mul (int 3) (nat 10) in @@ -3302,6 +3477,7 @@ let%expect_test "mul int nat" = Optimised: { PUSH nat 10 ; PUSH int 3 ; MUL } |}] +;; let%expect_test "mul mutez nat" = let e = mul (mutez 1000) (nat 2) in @@ -3312,6 +3488,7 @@ let%expect_test "mul mutez nat" = Optimised: { PUSH nat 2 ; PUSH mutez 1000 ; MUL } |}] +;; let%expect_test "sub int int" = let e = sub (int 5) (int 10) in @@ -3322,6 +3499,7 @@ let%expect_test "sub int int" = Optimised: { PUSH int -5 } |}] +;; let%expect_test "sub nat nat" = let e = sub (nat 10) (nat 3) in @@ -3332,6 +3510,7 @@ let%expect_test "sub nat nat" = Optimised: { PUSH nat 3 ; PUSH nat 10 ; SUB } |}] +;; let%expect_test "sub timestamp int" = let e = sub (timestamp "2023-01-01T00:00:00Z") (int 3600) in @@ -3342,6 +3521,7 @@ let%expect_test "sub timestamp int" = Optimised: { PUSH int 3600 ; PUSH timestamp 1672531200 ; SUB } |}] +;; let%expect_test "sub mutez" = let e = sub (mutez 2000) (mutez 500) in @@ -3352,6 +3532,7 @@ let%expect_test "sub mutez" = Optimised: { PUSH mutez 500 ; PUSH mutez 2000 ; SUB_MUTEZ } |}] +;; let%expect_test "sub_mutez direct" = let e = sub_mutez (mutez 2000) (mutez 1999) in @@ -3362,6 +3543,7 @@ let%expect_test "sub_mutez direct" = Optimised: { PUSH mutez 1999 ; PUSH mutez 2000 ; SUB_MUTEZ } |}] +;; let%expect_test "lsr nat" = let e = lsr_ (nat 16) (nat 1) in @@ -3372,6 +3554,7 @@ let%expect_test "lsr nat" = Optimised: { PUSH nat 1 ; PUSH nat 16 ; LSR } |}] +;; let%expect_test "lsl nat" = let e = lsl_ (nat 4) (nat 2) in @@ -3382,6 +3565,7 @@ let%expect_test "lsl nat" = Optimised: { PUSH nat 2 ; PUSH nat 4 ; LSL } |}] +;; let%expect_test "xor on nat" = let e = xor (nat 0b1010) (nat 0b0011) in @@ -3392,6 +3576,7 @@ let%expect_test "xor on nat" = Optimised: { PUSH nat 3 ; PUSH nat 10 ; XOR } |}] +;; let%expect_test "ediv nat nat" = let e = ediv (nat 10) (nat 3) in @@ -3402,6 +3587,7 @@ let%expect_test "ediv nat nat" = Optimised: { PUSH nat 3 ; PUSH nat 10 ; EDIV } |}] +;; let%expect_test "ediv mutez nat" = let e = ediv (mutez 1000) (nat 10) in @@ -3412,6 +3598,7 @@ let%expect_test "ediv mutez nat" = Optimised: { PUSH nat 10 ; PUSH mutez 1000 ; EDIV } |}] +;; let%expect_test "div_ with if_none" = let e = div_ (int 10) (int 0) in @@ -3428,6 +3615,7 @@ let%expect_test "div_ with if_none" = PUSH int 10 ; EDIV ; IF_NONE { PUSH string "DIV by 0" ; FAILWITH } { CAR } } |}] +;; let%expect_test "mod_ with if_none" = let e = mod_ (nat 9) (nat 0) in @@ -3444,6 +3632,7 @@ let%expect_test "mod_ with if_none" = PUSH nat 9 ; EDIV ; IF_NONE { PUSH string "MOD by 0" ; FAILWITH } { CDR } } |}] +;; let%expect_test "and_ bool bool" = let e = and_ (bool true) (bool false) in @@ -3454,6 +3643,7 @@ let%expect_test "and_ bool bool" = Optimised: { PUSH bool False } |}] +;; let%expect_test "and_ int int" = let e = and_ (int 0xF0) (int 0xCC) in @@ -3464,6 +3654,7 @@ let%expect_test "and_ int int" = Optimised: { PUSH int 204 ; PUSH int 240 ; AND } |}] +;; let%expect_test "or_ bool bool" = let e = or_ (bool false) (bool false) in @@ -3474,6 +3665,7 @@ let%expect_test "or_ bool bool" = Optimised: { PUSH bool False } |}] +;; let%expect_test "or_ nat nat" = let e = or_ (nat 0b1010) (nat 0b0101) in @@ -3484,6 +3676,7 @@ let%expect_test "or_ nat nat" = Optimised: { PUSH nat 5 ; PUSH nat 10 ; OR } |}] +;; let%expect_test "cons to list" = let tail_list = cons (int 2) (cons (int 3) (nil int_ty)) in @@ -3495,6 +3688,7 @@ let%expect_test "cons to list" = Optimised: { PUSH (list int) { 1 ; 2 ; 3 } } |}] +;; let%expect_test "concat1 strings" = let string_list = cons (string "Hello, ") (cons (string "World!") (nil string_ty)) in @@ -3511,6 +3705,7 @@ let%expect_test "concat1 strings" = Optimised: { PUSH (list string) { "Hello, " ; "World!" } ; CONCAT } |}] +;; let%expect_test "concat2 bytes" = let e = concat2 (bytes "0xABCD") (bytes "0x1234") in @@ -3521,6 +3716,7 @@ let%expect_test "concat2 bytes" = Optimised: { PUSH bytes 0x307831323334 ; PUSH bytes 0x307841424344 ; CONCAT } |}] +;; let%expect_test "get from map" = let m = empty_map nat_ty bool_ty in @@ -3532,6 +3728,7 @@ let%expect_test "get from map" = Optimised: { EMPTY_MAP nat bool ; PUSH nat 10 ; GET } |}] +;; let%expect_test "get from big_map" = let bm = empty_bigmap string_ty int_ty in @@ -3543,6 +3740,7 @@ let%expect_test "get from big_map" = Optimised: { EMPTY_BIG_MAP string int ; PUSH string "hello" ; GET } |}] +;; (* mem(999, empty_map(nat, bool)) *) let%expect_test "mem in map" = @@ -3555,7 +3753,7 @@ let%expect_test "mem in map" = Optimised: { EMPTY_MAP nat bool ; PUSH nat 999 ; MEM } |}] - +;; (* mem(5, empty_bigmap(nat, address)) *) let%expect_test "mem in big_map" = @@ -3568,6 +3766,7 @@ let%expect_test "mem in big_map" = Optimised: { EMPTY_BIG_MAP nat address ; PUSH nat 5 ; MEM } |}] +;; (* mem(42, empty_set(int)) *) let%expect_test "mem in set" = @@ -3580,6 +3779,7 @@ let%expect_test "mem in set" = Optimised: { EMPTY_SET int ; PUSH int 42 ; MEM } |}] +;; (* exec(10, fun (x: nat) -> x + 1) *) let%expect_test "exec function" = @@ -3592,12 +3792,13 @@ let%expect_test "exec function" = Optimised: { LAMBDA nat nat { PUSH nat 1 ; ADD } ; PUSH nat 10 ; EXEC } |}] +;; (* partial application: let f = fun (pair: (int*int)) -> fst pair + snd pair let partial = apply f to 5 exec(7, partial) - *) +*) let%expect_test "apply partial function" = let two_arg_fun = lambda @@ -3625,6 +3826,7 @@ let%expect_test "apply partial function" = APPLY ; PUSH int 7 ; EXEC } |}] +;; (* sapling_verify_update(cast (sapling_transaction 8) 0xDEADBEEF, sapling_empty_state(8)) *) let%expect_test "sapling_verify_update correct types" = @@ -3648,6 +3850,7 @@ let%expect_test "sapling_verify_update correct types" = PUSH bytes 0x30784445414442454546 ; CAST (sapling_transaction 8) ; SAPLING_VERIFY_UPDATE } |}] +;; (* ticket("TicketContent", 3) *) let%expect_test "ticket creation" = @@ -3659,6 +3862,7 @@ let%expect_test "ticket creation" = Optimised: { PUSH nat 3 ; PUSH string "TicketContent" ; TICKET } |}] +;; (* ticket_deprecated(42, 2) *) let%expect_test "ticket_deprecated usage" = @@ -3670,12 +3874,13 @@ let%expect_test "ticket_deprecated usage" = Optimised: { PUSH nat 2 ; PUSH int 42 ; TICKET_DEPRECATED } |}] +;; (* read_ticket ( - if_none (ticket("content",10)) - none => - failwith("No ticket") - some tk => tk) *) + if_none (ticket("content",10)) + none => + failwith("No ticket") + some tk => tk) *) let%expect_test "ticket then read_ticket" = let maybe_ticket = ticket (string "content") (nat 10) in let unwrapped = @@ -3704,11 +3909,11 @@ let%expect_test "ticket then read_ticket" = IF_NONE { PUSH string "No ticket" ; FAILWITH } {} ; READ_TICKET ; PAIR } |}] +;; - -(* split_ticket (if_none (ticket(123,10)) - none => failwith("No ticket") - some tk => tk) (3,7) *) +(* split_ticket (if_none (ticket(123,10)) + none => failwith("No ticket") + some tk => tk) (3,7) *) let%expect_test "split_ticket usage" = let maybe_ticket = ticket (nat 123) (nat 10) in let unwrapped = @@ -3743,14 +3948,15 @@ let%expect_test "split_ticket usage" = TICKET ; IF_NONE { PUSH string "No ticket" ; FAILWITH } {} ; SPLIT_TICKET } |}] +;; (* - Commented out as updaten is not implemented. - let%expect_test "updaten usage" = - let pair_expr = pair (None,None) (int 5) (bool true) in - let expr = updaten 1 (string "replacement") pair_expr in - test_expr expr; - [%expect {||}]*) + Commented out as updaten is not implemented. + let%expect_test "updaten usage" = + let pair_expr = pair (None,None) (int 5) (bool true) in + let expr = updaten 1 (string "replacement") pair_expr in + test_expr expr; + [%expect {||}]*) (* view "myView" ~return=nat ~d=7 ~address=KT1SampleAddress *) let%expect_test "view usage" = @@ -3768,6 +3974,7 @@ let%expect_test "view usage" = Optimised: { PUSH address "KT1SampleAddress" ; PUSH int 7 ; VIEW "myView" nat } |}] +;; (* slice(s="Hello", offset=1, length=3) *) let%expect_test "slice on string" = @@ -3782,6 +3989,7 @@ let%expect_test "slice on string" = Optimised: { PUSH string "Hello" ; PUSH nat 3 ; PUSH nat 1 ; SLICE } |}] +;; (* slice(b=0xDEADBEEF, offset=2, length=4) *) let%expect_test "slice on bytes" = @@ -3796,6 +4004,7 @@ let%expect_test "slice on bytes" = Optimised: { PUSH bytes 0x30784445414442454546 ; PUSH nat 4 ; PUSH nat 2 ; SLICE } |}] +;; (* update(7, Some 100) in empty_map(nat,int) *) let%expect_test "update in a map" = @@ -3808,6 +4017,7 @@ let%expect_test "update in a map" = Optimised: { PUSH (map nat int) { Elt 7 100 } } |}] +;; (* update("test", None) in empty_map(string,bool) *) let%expect_test "update remove key in a map" = @@ -3820,6 +4030,7 @@ let%expect_test "update remove key in a map" = Optimised: { EMPTY_MAP string bool ; NONE bool ; PUSH string "test" ; UPDATE } |}] +;; (* update(3, true) in empty_set(int) *) let%expect_test "update in a set" = @@ -3833,6 +4044,7 @@ let%expect_test "update in a set" = Optimised: { PUSH (set int) { 3 } } |}] +;; (* get_and_update(false, Some 42) in empty_map(bool,nat) *) let%expect_test "get_and_update in map" = @@ -3854,6 +4066,7 @@ let%expect_test "get_and_update in map" = PUSH bool False ; GET_AND_UPDATE ; PAIR } |}] +;; (* get_and_update(99, None) in empty_bigmap(nat,string) *) let%expect_test "get_and_update removing from big_map" = @@ -3873,6 +4086,7 @@ let%expect_test "get_and_update removing from big_map" = PUSH nat 99 ; GET_AND_UPDATE ; PAIR } |}] +;; (* transfer_tokens(param=unit, amount=1000000mutez, contract=KT1Example:unit) *) let%expect_test "transfer_tokens simple" = @@ -3895,6 +4109,7 @@ let%expect_test "transfer_tokens simple" = PUSH mutez 1000000 ; UNIT ; TRANSFER_TOKENS } |}] +;; (* check_signature(key="edpkExample", sig="edsigExampleSig", msg=0xDEADBEEF) *) let%expect_test "check_signature usage" = @@ -3915,6 +4130,7 @@ let%expect_test "check_signature usage" = PUSH signature "edsigExampleSig" ; PUSH key "edpkExample" ; CHECK_SIGNATURE } |}] +;; (* open_chest(chest_key=0xAB, chest=0xCD, time=100) *) let%expect_test "open_chest usage" = @@ -3935,6 +4151,7 @@ let%expect_test "open_chest usage" = PUSH bytes 0x30784344 ; PUSH bytes 0x30784142 ; OPEN_CHEST } |}] +;; (* convert_list [1;2;3] => (1,2,3) as row/tuple *) let%expect_test "convert_list usage" = @@ -3948,6 +4165,7 @@ let%expect_test "convert_list usage" = Optimised: { PUSH int 3 ; PUSH int 2 ; PUSH int 1 ; PAIR 3 } |}] +;; (* x = gen_name; let x = 10 in x *) @@ -3960,6 +4178,7 @@ let%expect_test "gen_name usage" = Optimised: { PUSH nat 10 } |}] +;; (* global_constant "expruExampleHash" [42; false] : int *) let%expect_test "global_constant usage" = @@ -3974,6 +4193,7 @@ let%expect_test "global_constant usage" = Optimised: { PUSH bool False ; PUSH nat 42 ; constant "expruExampleHash" } |}] +;; (* cast(nat, -10) *) let%expect_test "cast int->nat with negative int" = @@ -3986,7 +4206,7 @@ let%expect_test "cast int->nat with negative int" = Optimised: { PUSH int -10 ; CAST nat } |}] - +;; (* fun x -> fun y -> fun z -> if z then x+y else x-y (types: x:int, y:nat, z:bool) *) @@ -4041,6 +4261,7 @@ let%expect_test "lambda -> lambda -> lambda" = APPLY } ; SWAP ; APPLY } } |}] +;; (* partial application with 3-tuple param (int * (int * int)) => int *) let%expect_test "apply function with 3-tuple param" = @@ -4084,13 +4305,13 @@ let%expect_test "apply function with 3-tuple param" = PUSH int 3 ; PAIR ; EXEC } |}] - +;; (* leftover partial application unused: f = fun (p: (nat * nat)) -> fst p + snd p partial = apply f 8 partial not executed - *) +*) let%expect_test "apply leftover function unused" = let two_tuple_ty = mk_tuple_ty [ nat_ty; nat_ty ] in let two_tuple_fun = @@ -4111,6 +4332,7 @@ let%expect_test "apply leftover function unused" = Optimised: { LAMBDA (pair nat nat) nat { UNPAIR ; ADD } ; PUSH nat 8 ; APPLY } |}] +;; (* if "ok" = "fail" then 1 else failwith("Error: " ^ "String mismatch") *) let%expect_test "failwith usage in else branch" = @@ -4139,6 +4361,7 @@ let%expect_test "failwith usage in else branch" = IF {} { PUSH string "String mismatch" ; PUSH string "Error: " ; CONCAT ; FAILWITH } ; PUSH nat 1 } |}] +;; (* update 10 (Some(contract bool)) (empty_bigmap(nat, contract bool)) *) let%expect_test "update big_map of nat->contract(bool)" = @@ -4162,6 +4385,8 @@ let%expect_test "update big_map of nat->contract(bool)" = SOME ; PUSH nat 10 ; UPDATE } |}] +;; + (* cast int (cast nat (cast int 99)) *) let%expect_test "chained cast" = let e = cast int_ty (cast nat_ty (cast int_ty (nat 99))) in @@ -4172,6 +4397,7 @@ let%expect_test "chained cast" = Optimised: { PUSH nat 99 ; CAST int ; CAST nat ; CAST int } |}] +;; (* global_constant "expruCustomHash" [2, -3] : (nat -> int) *) let%expect_test "global_constant returning function" = @@ -4186,7 +4412,7 @@ let%expect_test "global_constant returning function" = Optimised: { PUSH int -3 ; PUSH nat 2 ; constant "expruCustomHash" } |}] - +;; (* apply (global_constant "expruFuncHash" : nat->int) 100 *) let%expect_test "apply global constant function" = @@ -4203,6 +4429,7 @@ let%expect_test "apply global constant function" = Optimised: { PUSH nat 100 ; constant "expruFuncHash" } |}] +;; (* let x = 10 in (fun (y: nat) -> x + y) 5 *) let%expect_test "lambda capturing external let var" = @@ -4236,12 +4463,12 @@ let%expect_test "lambda capturing external let var" = APPLY ; SWAP ; EXEC } |}] +;; - -(* let a = 2, - let b = 3 in - fun x -> fun y -> - x + y + (a + b) *) +(* let a = 2, + let b = 3 in + fun x -> fun y -> + x + y + (a + b) *) let%expect_test "nested lambdas referencing outer variable" = let expr = let_in @@ -4307,6 +4534,7 @@ let%expect_test "nested lambdas referencing outer variable" = APPLY ; SWAP ; APPLY } |}] +;; (* let factor = 10 in fun x -> fun y -> (x*y) * factor *) let%expect_test "nested lambdas returning another referencing an external var" = @@ -4353,13 +4581,13 @@ let%expect_test "nested lambdas returning another referencing an external var" = APPLY } ; PUSH nat 10 ; APPLY } |}] - +;; (* let a = 42 in let f = fun p -> a + (fst p + snd p) in let applied = f 5 in applied 7 - *) +*) let%expect_test "partial application capturing environment" = let pair_ty = mk_tuple_ty [ nat_ty; nat_ty ] in @@ -4408,6 +4636,7 @@ let%expect_test "partial application capturing environment" = APPLY ; PUSH nat 7 ; EXEC } |}] +;; (* let z = 9 in fun z -> z + 1 *) let%expect_test "inner param overshadowing outer var name" = @@ -4424,6 +4653,7 @@ let%expect_test "inner param overshadowing outer var name" = Optimised: { LAMBDA nat nat { PUSH nat 1 ; ADD } } |}] +;; (* let_mut m = 10 in fun x -> x + m *) let%expect_test "lambda capturing a mut var read" = @@ -4447,11 +4677,12 @@ let%expect_test "lambda capturing a mut var read" = Optimised: { LAMBDA (pair nat nat) nat { UNPAIR ; ADD } ; PUSH nat 10 ; APPLY } |}] +;; (* let_mut c = 0 in fun inc -> - let ignore_assign = c <- c + inc in - c - *) + let ignore_assign = c <- c + inc in + c +*) let%expect_test "lambda capturing mut var and assigning" = let mut_c = mut_var "c" in let expr = @@ -4481,16 +4712,16 @@ let%expect_test "lambda capturing mut var and assigning" = Optimised: { LAMBDA (pair nat nat) nat { UNPAIR ; ADD } ; PUSH nat 0 ; APPLY } |}] +;; - -(* +(* let a = 3 in let outer = fun (p: (int*int)) -> - let sum = (fst p + snd p) + a in - fun leftover -> sum + leftover + let sum = (fst p + snd p) + a in + fun leftover -> sum + leftover let applied_outer = outer(7,5) applied_outer(10) - *) +*) let%expect_test "partial apply nested lambda env capture" = let param_ty = mk_tuple_ty [ int_ty; int_ty ] in let outer_lam = @@ -4583,6 +4814,7 @@ let%expect_test "partial apply nested lambda env capture" = EXEC ; PUSH int 10 ; EXEC } |}] +;; (* let q = 123 in fun x -> fun y -> x + y + q *) let%expect_test "return environment capturing function unused" = @@ -4629,11 +4861,12 @@ let%expect_test "return environment capturing function unused" = APPLY } ; PUSH int 123 ; APPLY } |}] +;; (* let x=1 in fun (y:int) -> - let x = y + x in - x + 100 - *) + let x = y + x in + x + 100 +*) let%expect_test "deeper let_in overshadowing environment var" = let expr = let_in @@ -4663,3 +4896,4 @@ let%expect_test "deeper let_in overshadowing environment var" = { LAMBDA (pair int int) int { UNPAIR ; ADD ; PUSH int 100 ; ADD } ; PUSH int 1 ; APPLY } |}] +;; diff --git a/test/test_used_vars.ml b/test/test_used_vars.ml index 15219e7..885bcde 100644 --- a/test/test_used_vars.ml +++ b/test/test_used_vars.ml @@ -1,9 +1,9 @@ -(* In this module, we test the `Last_vars.collect_used_vars` function computing set of all variables that were used. +(* In this module, we test the `Last_vars.collect_used_vars` function computing set of all variables that were used. - The concrete syntaxes are written with a OCaml-like syntax. - In LLTZ, we can only copy the value of variables not their reference, - therefore even for mutable variable we don't use 'ref' which is present in OCaml - to simplify the syntax. Assignments are done with the '<-' operator. + The concrete syntaxes are written with a OCaml-like syntax. + In LLTZ, we can only copy the value of variables not their reference, + therefore even for mutable variable we don't use 'ref' which is present in OCaml + to simplify the syntax. Assignments are done with the '<-' operator. *) open Core open Lltz_ir.Ast_builder.With_dummy @@ -16,6 +16,7 @@ let print_used expr = |> List.sort ~compare:String.compare |> String.concat ~sep:", " |> print_endline +;; (* x *) let%expect_test "used var simple" = @@ -24,6 +25,7 @@ let%expect_test "used var simple" = [%expect {| x |}] +;; (* m *) let%expect_test "used deref free" = @@ -32,12 +34,14 @@ let%expect_test "used deref free" = [%expect {| m |}] +;; (* 42 *) let%expect_test "used const" = let expr = int 42 in print_used expr; [%expect {| |}] +;; (* let x = 1 in x + x *) let%expect_test "used let_in overshadow" = @@ -51,6 +55,7 @@ let%expect_test "used let_in overshadow" = [%expect {| x |}] +;; (* let mut m = 10 in m <- (!m + x) @@ -69,6 +74,7 @@ let%expect_test "used let_mut_in referencing var in body" = [%expect {| m, x |}] +;; (* fun (p : nat) -> p + freeVar *) let%expect_test "used lambda referencing outer var not bound" = @@ -81,10 +87,11 @@ let%expect_test "used lambda referencing outer var not bound" = [%expect {| freeVar, p |}] +;; -(* - let rec f = fun (n : nat) -> - if n <= freeN then f else f(n) +(* + let rec f = fun (n : nat) -> + if n <= freeN then f else f(n) *) let%expect_test "used lambda_rec referencing free var" = let expr = @@ -104,6 +111,7 @@ let%expect_test "used lambda_rec referencing free var" = [%expect {| f, freeN, n |}] +;; (* (fun (z : nat) -> 5) (0 + unboundArg) *) let%expect_test "used app overshadow in abs + free var in arg" = @@ -114,13 +122,14 @@ let%expect_test "used app overshadow in abs + free var in arg" = [%expect {| unboundArg |}] +;; (* - let outer = 100 in - let two_arg_fun = fun (p : (int*int)) -> - outer + (fst p + snd p) - let applied1 = two_arg_fun 10 - applied1 20 + let outer = 100 in + let two_arg_fun = fun (p : (int*int)) -> + outer + (fst p + snd p) + let applied1 = two_arg_fun 10 + applied1 20 *) let%expect_test "used partial application overshadow outer var" = let pair_ty = mk_tuple_ty [ int_ty; int_ty ] in @@ -154,16 +163,17 @@ let%expect_test "used partial application overshadow outer var" = [%expect {| applied1, outer, p, two_arg_fun |}] +;; (* - let a = 8 in - let f = fun (p : (int*int)) -> - a + (fst p + snd p) - let partial = f 2 - let leftover = - let a = 999 in partial - in - leftover 3 + let a = 8 in + let f = fun (p : (int*int)) -> + a + (fst p + snd p) + let partial = f 2 + let leftover = + let a = 999 in partial + in + leftover 3 *) let%expect_test "used partial apply overshadow leftover function" = let pair_ty = mk_tuple_ty [ int_ty; int_ty ] in @@ -202,6 +212,7 @@ let%expect_test "used partial apply overshadow leftover function" = in print_used expr; [%expect {| a, f, leftover, p, partial |}] +;; (* x + y *) let%expect_test "used prim add" = @@ -210,6 +221,7 @@ let%expect_test "used prim add" = [%expect {| x, y |}] +;; (* let a=9 in a eq a *) let%expect_test "used prim eq overshadow usage" = @@ -220,10 +232,11 @@ let%expect_test "used prim eq overshadow usage" = [%expect {| a |}] +;; (* - let x=50 in - div_ x (let x=5 in x) + let x=50 in + div_ x (let x=5 in x) *) let%expect_test "used div_ overshadow local var" = let expr = @@ -239,9 +252,10 @@ let%expect_test "used div_ overshadow local var" = [%expect {| name_var_4sfa9wjas80, x |}] +;; (* - mod_ (let n=7 in n+2) y + mod_ (let n=7 in n+2) y *) let%expect_test "used mod_ overshadow in lhs" = let lhs_expr = @@ -252,9 +266,10 @@ let%expect_test "used mod_ overshadow in lhs" = [%expect {| n, name_var_4sfa9wjas81, y |}] +;; (* - div_ (let_mut m= (x+1) in m) (let v=2 in v) + div_ (let_mut m= (x+1) in m) (let v=2 in v) *) let%expect_test "used div_ with mutable var + overshadow in rhs" = let lhs_expr = @@ -269,9 +284,10 @@ let%expect_test "used div_ with mutable var + overshadow in rhs" = [%expect {| m, name_var_4sfa9wjas82, v, x |}] +;; (* - mod_ (div_ (let a=10 in a) (let b=2 in b)) b + mod_ (div_ (let a=10 in a) (let b=2 in b)) b *) let%expect_test "used both div_ and mod_ combined" = let a_expr = let_in (var "a") ~rhs:(int 10) ~in_:(variable (var "a") int_ty) in @@ -282,6 +298,7 @@ let%expect_test "used both div_ and mod_ combined" = [%expect {| a, b, name_var_4sfa9wjas83, name_var_4sfa9wjas84 |}] +;; (* if condX=0 then thenVar else elseVar *) let%expect_test "used if_bool distinct free vars" = @@ -293,10 +310,11 @@ let%expect_test "used if_bool distinct free vars" = [%expect {| condX, elseVar, thenVar |}] +;; (* - let x=10 in - if (let a=20 in a = x) then (let x=99 in x) else x + let x=10 in + if (let a=20 in a = x) then (let x=99 in x) else x *) let%expect_test "used if_bool overshadow in condition + overshadow in then branch" = let condition_expr = @@ -315,11 +333,12 @@ let%expect_test "used if_bool overshadow in condition + overshadow in then branc in print_used full_expr; [%expect {| a, x |}] +;; (* - match optVal with - None -> 100 - | Some v -> v + x + match optVal with + None -> 100 + | Some v -> v + x *) let%expect_test "used if_none referencing subject + some" = let expr = @@ -335,11 +354,12 @@ let%expect_test "used if_none referencing subject + some" = [%expect {| optVal, v, x |}] +;; (* - match lst with - [] -> 0 - | hd::hd -> hd + 2 + match lst with + [] -> 0 + | hd::hd -> hd + 2 *) let%expect_test "used if_cons overshadow lam_var1/lam_var2" = let expr = @@ -356,11 +376,12 @@ let%expect_test "used if_cons overshadow lam_var1/lam_var2" = [%expect {| hd, lst |}] +;; (* - match s with - Left l -> let l=999 in 1 - | Right l -> l + 2 + match s with + Left l -> let l=999 in 1 + | Right l -> l + 2 *) let%expect_test "used if_left overshadow lam_var" = let subject = @@ -377,6 +398,7 @@ let%expect_test "used if_left overshadow lam_var" = [%expect {| l, s |}] +;; (* while x < 5 do m <- x done *) let%expect_test "used while referencing cond, body" = @@ -389,10 +411,11 @@ let%expect_test "used while referencing cond, body" = [%expect {| x |}] +;; (* - while_left (Left 10) do - Right(flag) + while_left (Left 10) do + Right(flag) *) let%expect_test "used while_left overshadow lam_var" = let cond_expr = left (None, None, int_ty) (int 10) in @@ -408,12 +431,13 @@ let%expect_test "used while_left overshadow lam_var" = [%expect {| flag |}] +;; (* - for i=0 while i<5 do - m <- i - i <- i+1 - done + for i=0 while i<5 do + m <- i + i <- i+1 + done *) let%expect_test "used for usage" = let expr = @@ -428,14 +452,15 @@ let%expect_test "used for usage" = [%expect {| i |}] +;; (* - let outer=50 in - for i=0 while i<3 do - let i = outer in - i + 1 - i <- i+1 - done + let outer=50 in + for i=0 while i<3 do + let i = outer in + i + 1 + i <- i+1 + done *) let%expect_test "used for overshadow in body referencing outer var" = let mut_i = mut_var "i" in @@ -454,6 +479,7 @@ let%expect_test "used for overshadow in body referencing outer var" = let full_expr = let_in (var "outer") ~rhs:(nat 50) ~in_:for_expr in print_used full_expr; [%expect {| i, outer |}] +;; (* for_each [] do elem -> let elem=999 in elem *) let%expect_test "used for_each overshadow lam_var" = @@ -470,10 +496,11 @@ let%expect_test "used for_each overshadow lam_var" = [%expect {| elem |}] +;; (* - let outer=2 in - map [1] (x-> x + outer) + let outer=2 in + map [1] (x-> x + outer) *) let%expect_test "used map referencing outer var" = let list_expr = cons (nat 1) (nil nat_ty) in @@ -488,9 +515,10 @@ let%expect_test "used map referencing outer var" = [%expect {| outer, x |}] +;; (* - fold_left [1] init=10 (acc_x -> let acc_x=999 in 0) + fold_left [1] init=10 (acc_x -> let acc_x=999 in 0) *) let%expect_test "used fold_left overshadow lam_var" = let coll = cons (nat 1) (nil nat_ty) in @@ -507,10 +535,11 @@ let%expect_test "used fold_left overshadow lam_var" = in print_used expr; [%expect {| |}] +;; (* - let outer=100 in - fold_right [1] init=0 (p -> fst p + snd p + outer) + let outer=100 in + fold_right [1] init=0 (p -> fst p + snd p + outer) *) let%expect_test "used fold_right referencing outer var" = let coll = cons (int 1) (nil int_ty) in @@ -537,10 +566,10 @@ let%expect_test "used fold_right referencing outer var" = [%expect {| outer, p |}] - +;; (* - let_tuple_in (a,b,a)=(1,2,3) in a + b + let_tuple_in (a,b,a)=(1,2,3) in a + b *) let%expect_test "used let_tuple_in overshadow" = let triple = @@ -556,7 +585,7 @@ let%expect_test "used let_tuple_in overshadow" = [%expect {| a, b |}] - +;; (* (x,y) *) let%expect_test "used tuple referencing x,y inside row" = @@ -571,6 +600,7 @@ let%expect_test "used tuple referencing x,y inside row" = [%expect {| x, y |}] +;; (* ( (alpha, 20) )[0] *) let%expect_test "used proj referencing some var in the tuple" = @@ -582,6 +612,7 @@ let%expect_test "used proj referencing some var in the tuple" = [%expect {| alpha |}] +;; (* update_tuple (10,20) (idx=1) (let u=999 in u) *) let%expect_test "used update overshadow" = @@ -592,8 +623,9 @@ let%expect_test "used update overshadow" = [%expect {| u |}] +;; -module MA = Michelson.Ast +module MA = Lltz_michelson.Ast let push_int n = Tezos_micheline.Micheline.Prim @@ -601,6 +633,7 @@ let push_int n = , "PUSH" , [ Tezos_micheline.Micheline.Int (Ast_builder.Dummy_range.v, Z.of_int n) ] , [] ) +;; (* raw_michelson { PUSH 42 } [ a1, let a1=100 in a1 ] : int *) let%expect_test "used raw_michelson overshadow" = @@ -614,17 +647,17 @@ let%expect_test "used raw_michelson overshadow" = [%expect {| a1 |}] - +;; (* - create_contract - storage=nat - code= fun(args: (nat*nat)) -> - let (p,s)=args in p + s - delegate= del - initial_balance= bal - initial_storage= let args=5 in 6 - *) + create_contract + storage=nat + code= fun(args: (nat*nat)) -> + let (p,s)=args in p + s + delegate= del + initial_balance= bal + initial_storage= let args=5 in 6 +*) let%expect_test "used create_contract overshadow binder_var" = let param_storage_ty = mk_tuple_ty [ nat_ty; nat_ty ] in let code_body = @@ -645,10 +678,11 @@ let%expect_test "used create_contract overshadow binder_var" = [%expect {| args, bal, del, p, s |}] +;; (* - global_constant "myHash" - [ let g=10 in g, + global_constant "myHash" + [ let g=10 in g, g ] : int *) @@ -665,5 +699,6 @@ let%expect_test "used global_constant overshadow" = [%expect {| g |}] +;; (* TODO: Inj/Match *)