diff --git a/src/lib_ligo/meta-michelson/.gitignore b/src/lib_ligo/meta-michelson/.gitignore
new file mode 100644
index 000000000..46d12ff04
--- /dev/null
+++ b/src/lib_ligo/meta-michelson/.gitignore
@@ -0,0 +1,6 @@
+_build/*
+*/_build
+*~
+.merlin
+*/.merlin
+*.install
\ No newline at end of file
diff --git a/src/lib_ligo/meta-michelson/alpha_wrap.ml b/src/lib_ligo/meta-michelson/alpha_wrap.ml
new file mode 100644
index 000000000..196f6a9c4
--- /dev/null
+++ b/src/lib_ligo/meta-michelson/alpha_wrap.ml
@@ -0,0 +1,30 @@
+open Tezos_utils.Error_monad
+
+let dummy_environment = force_lwt ~msg:"getting dummy env" @@ Misc.init_environment ()
+
+let tc = dummy_environment.tezos_context
+
+module Proto_alpha = Tezos_utils.Memory_proto_alpha
+open Proto_alpha
+open Alpha_context
+open Alpha_environment
+
+let pack ty v = fst @@ force_lwt_alpha ~msg:"packing" @@ Script_ir_translator.pack_data tc ty v
+let unpack_opt (type a) : a Script_typed_ir.ty -> MBytes.t -> a option = fun ty bytes ->
+  force_lwt ~msg:"unpacking : parse" (
+    if Compare.Int.(MBytes.length bytes >= 1) &&
+       Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then
+      let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
+      match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
+      | None -> return None
+      | Some expr ->
+        Script_ir_translator.parse_data tc ty (Micheline.root expr) >>=?? fun x -> return (Some (fst x))
+    else
+      return None
+  )
+
+let unpack ty a = match unpack_opt ty a with
+  | None -> raise @@ Failure "unpacking : of_bytes"
+  | Some x -> x
+
+let blake2b b = Alpha_environment.Raw_hashes.blake2b b
diff --git a/src/lib_ligo/meta-michelson/contract.ml b/src/lib_ligo/meta-michelson/contract.ml
new file mode 100644
index 000000000..d5ce41d4c
--- /dev/null
+++ b/src/lib_ligo/meta-michelson/contract.ml
@@ -0,0 +1,310 @@
+open Misc
+
+open Tezos_utils.Error_monad
+open Memory_proto_alpha
+open Alpha_context
+
+open Script_ir_translator
+open Script_typed_ir
+
+module Option = Tezos_utils.Option
+module Cast = Tezos_utils.Cast
+
+type ('param, 'storage) toplevel = {
+  param_type : 'param ty ;
+  storage_type : 'storage ty ;
+  code : ('param * 'storage, packed_internal_operation list * 'storage) lambda
+}
+
+type ex_toplevel =
+    Ex_toplevel : ('a, 'b) toplevel -> ex_toplevel
+
+let get_toplevel ?environment toplevel_path claimed_storage_type claimed_parameter_type =
+  let toplevel_str = Streams.read_file toplevel_path in
+  contextualize ?environment ~msg:"toplevel" @@ fun {tezos_context = context ; _ } ->
+  let toplevel_expr = Cast.tl_of_string toplevel_str in
+  let (param_ty_node, storage_ty_node, code_field) =
+    force_ok_alpha ~msg:"parsing toplevel" @@
+    parse_toplevel toplevel_expr in
+  let (Ex_ty param_type, _) =
+    force_ok_alpha ~msg:"parse arg ty" @@
+    Script_ir_translator.parse_ty context ~allow_big_map:false ~allow_operation:false param_ty_node in
+  let (Ex_ty storage_type, _) =
+    force_ok_alpha ~msg:"parse storage ty" @@
+    parse_storage_ty context storage_ty_node in
+  let _ = force_ok_alpha ~msg:"storage eq" @@ Script_ir_translator.ty_eq context storage_type claimed_storage_type in
+  let _ = force_ok_alpha ~msg:"param eq" @@ Script_ir_translator.ty_eq context param_type claimed_parameter_type in
+  let param_type_full = Pair_t ((claimed_parameter_type, None, None),
+                                (claimed_storage_type, None, None), None) in
+  let ret_type_full =
+    Pair_t ((List_t (Operation_t None, None), None, None),
+            (claimed_storage_type, None, None), None) in
+  parse_returning (Toplevel { storage_type = claimed_storage_type ; param_type = claimed_parameter_type })
+    context (param_type_full, None) ret_type_full code_field >>=?? fun (code, _) ->
+  Error_monad.return {
+    param_type = claimed_parameter_type;
+    storage_type = claimed_storage_type;
+    code ;
+  }
+
+let make_toplevel code storage_type param_type =
+  { param_type ; storage_type ; code }
+
+module type ENVIRONMENT = sig
+  val identities : identity list
+  val tezos_context : t
+end
+
+type ex_typed_stack = Ex_typed_stack : ('a stack_ty * 'a Script_interpreter.stack) -> ex_typed_stack
+
+open Error_monad
+
+module Step (Env: ENVIRONMENT) = struct
+  open Env
+
+  type config = {
+    source : Contract.t option ;
+    payer : Contract.t option ;
+    self : Contract.t option ;
+    visitor : (Script_interpreter.ex_descr_stack -> unit) option ;
+    timestamp : Script_timestamp.t option ;
+    debug_visitor : (ex_typed_stack -> unit) option ;
+    amount : Tez.t option ;
+  }
+
+  let no_config = {
+    source = None ;
+    payer = None ;
+    self = None ;
+    visitor = None ;
+    debug_visitor = None ;
+    timestamp = None ;
+    amount = None ;
+  }
+
+  let of_param base param = match param with
+    | None -> base
+    | Some _ as x -> x
+
+  let make_config ?base_config ?source ?payer ?self ?visitor ?debug_visitor ?timestamp ?amount () =
+    let base_config = Option.unopt ~default:no_config base_config in {
+      source = Option.first_some source base_config.source ;
+      payer = Option.first_some payer base_config.payer ;
+      self = Option.first_some self base_config.self ;
+      visitor = Option.first_some visitor base_config.visitor ;
+      debug_visitor = Option.first_some debug_visitor base_config.debug_visitor ;
+      timestamp = Option.first_some timestamp base_config.timestamp ;
+      amount = Option.first_some amount base_config.amount ;
+    }
+
+  open Error_monad
+
+  let debug_visitor ?f () =
+    let open Script_interpreter in
+    let aux (Ex_descr_stack (descr, stack)) =
+      (match (descr.instr, descr.bef) with
+       | Nop, Item_t (String_t _, stack_ty, _) -> (
+           let (Item (s, stack)) = stack in
+           if s = "_debug"
+           then (
+             match f with
+             | None -> Format.printf "debug: %s\n%!" @@ Cast.stack_to_string stack_ty stack
+             | Some f -> f (Ex_typed_stack(stack_ty, stack))
+           ) else ()
+         )
+       | _ -> ()) ;
+      () in
+    aux
+
+  let step_lwt ?(config=no_config) (stack:'a Script_interpreter.stack) (code:('a, 'b) descr) =
+    let source = Option.unopt
+        ~default:(List.nth identities 0).implicit_contract config.source in
+    let payer = Option.unopt
+        ~default:(List.nth identities 1).implicit_contract config.payer in
+    let self = Option.unopt
+        ~default:(List.nth identities 2).implicit_contract config.self in
+    let amount = Option.unopt ~default:(Tez.one) config.amount in
+    let visitor =
+      let default = debug_visitor ?f:config.debug_visitor () in
+      Option.unopt ~default config.visitor in
+    let tezos_context = match config.timestamp with
+      | None -> tezos_context
+      | Some s -> Alpha_context.Script_timestamp.set_now tezos_context s in
+    Script_interpreter.step tezos_context ~source ~payer ~self ~visitor amount code stack >>=?? fun (stack, _) ->
+    return stack
+
+  let step_1_2 ?config (a:'a) (descr:('a * end_of_stack, 'b * ('c * end_of_stack)) descr) =
+    let open Script_interpreter in
+    step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Item(c, Empty))) ->
+    return (b, c)
+
+  let step_3_1 ?config (a:'a) (b:'b) (c:'c)
+      (descr:('a * ('b * ('c * end_of_stack)), 'd * end_of_stack) descr) =
+    let open Script_interpreter in
+    step_lwt ?config (Item(a, Item(b, Item(c, Empty)))) descr >>=? fun (Item(d, Empty)) ->
+    return d
+
+  let step_2_1 ?config (a:'a) (b:'b) (descr:('a * ('b * end_of_stack), 'c * end_of_stack) descr) =
+    let open Script_interpreter in
+    step_lwt ?config (Item(a, Item(b, Empty))) descr >>=? fun (Item(c, Empty)) ->
+    return c
+
+  let step_1_1 ?config (a:'a) (descr:('a * end_of_stack, 'b * end_of_stack) descr) =
+    let open Script_interpreter in
+    step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Empty)) ->
+    return b
+
+  let step_value ?config (a:'a) (descr:('a * end_of_stack, 'a * end_of_stack) descr) =
+    step_1_1 ?config a descr
+
+  let step ?config stack code =
+    force_lwt ~msg:"running a step" @@ step_lwt ?config stack code
+
+end
+
+let run_lwt_full ?source ?payer ?self toplevel storage param {identities ; tezos_context = context} =
+  let { code ; _ } = toplevel in
+
+  let source = Option.unopt
+      ~default:(List.nth identities 0).implicit_contract source in
+  let payer = Option.unopt
+      ~default:(List.nth identities 1).implicit_contract payer in
+  let self = Option.unopt
+      ~default:(List.nth identities 2).implicit_contract self in
+  let amount = Tez.one in
+
+  Script_interpreter.interp context ~source ~payer ~self amount code (param, storage)
+  >>=?? fun ((ops, storage), new_ctxt) ->
+  let gas = Alpha_context.Gas.consumed ~since:context ~until:new_ctxt in
+  return (storage, ops, gas)
+
+let run_lwt ?source ?payer ?self toplevel storage param env =
+  run_lwt_full ?source ?payer ?self toplevel storage param env >>=? fun (storage, _ops, _gas) ->
+  return storage
+
+let run ?environment toplevel storage param =
+  contextualize ?environment ~msg:"run toplevel" @@ run_lwt toplevel storage param
+
+let run_node ?environment toplevel storage_node param_node =
+  contextualize ?environment ~msg:"run toplevel" @@ fun {tezos_context = context ; _} ->
+  let {param_type ; storage_type ; _ } = toplevel in
+  parse_data context param_type param_node >>=?? fun (param, _) ->
+  parse_data context storage_type storage_node >>=?? fun (storage, _) ->
+  let storage = run toplevel storage param in
+  unparse_data context Readable storage_type storage >>=?? fun (storage_node, _) ->
+  return storage_node
+
+let run_str toplevel storage_str param_str =
+  let param_node = Cast.node_of_string param_str in
+  let storage_node = Cast.node_of_string storage_str in
+  run_node toplevel storage_node param_node
+
+type input = {
+  toplevel_path : string ;
+  storage : string ;
+  parameter : string
+}
+
+let parse_json json_str : input =
+  let json = force_ok_str ~msg:"main_contract: invalid json" @@ Tezos_utils.Data_encoding.Json.from_string json_str in
+  let json = match json with
+    | `O json ->  json
+    | _ -> raise @@ Failure "main_contract: not recorD"
+  in
+  let open Json in
+  let toplevel_path = force_string ~msg:"main_contract, top_level" @@ List.assoc "top_level" json in
+  let parameter = force_string ~msg:"main_contract, param" @@ List.assoc "param" json in
+  let storage = force_string ~msg:"main_contract, storage" @@ List.assoc "storage" json in
+  { toplevel_path ; storage ; parameter }
+
+let generate_json (storage_node:Script.node) : string =
+  let storage_expr = Tezos_micheline.Micheline.strip_locations storage_node in
+  let json = Data_encoding.Json.construct Script.expr_encoding storage_expr in
+  Format.fprintf Format.str_formatter "%a" Data_encoding.Json.pp json ;
+  Format.flush_str_formatter ()
+
+module Types = struct
+  open Script_typed_ir
+
+  let union a b = Union_t ((a, None), (b, None), None)
+  let assert_union = function
+    | Union_t ((a, _), (b, _), _) -> (a, b)
+    | _ -> assert false
+
+  let pair a b = Pair_t ((a, None, None), (b, None, None), None)
+  let assert_pair = function
+    | Pair_t ((a, _, _), ((b, _, _)), _) -> (a, b)
+    | _ -> assert false
+  let assert_pair_ex ?(msg="assert pair") (Ex_ty ty) = match ty with
+    | Pair_t ((a, _, _), ((b, _, _)), _) -> (Ex_ty a, Ex_ty b)
+    | _ -> raise (Failure msg)
+
+  let unit = Unit_t None
+
+  let bytes = Bytes_t None
+  let bytes_k = Bytes_key None
+
+  let nat = Nat_t None
+  let int = Int_t None
+  let nat_k = Nat_key None
+
+  let big_map k v = Big_map_t (k, v, None)
+
+  let signature = Signature_t None
+
+  let bool = Bool_t None
+
+  let mutez = Mutez_t None
+
+  let string = String_t None
+  let string_k = String_key None
+
+  let key = Key_t None
+
+  let list a = List_t (a, None)
+  let assert_list = function
+    | List_t (a, _) -> a
+    | _ -> assert false
+
+  let option a = Option_t ((a, None), None, None)
+  let assert_option = function
+    | Option_t ((a, _), _, _) -> a
+    | _ -> assert false
+
+  let address = Address_t None
+
+  let lambda a b = Lambda_t (a, b, None)
+  let assert_lambda = function
+    | Lambda_t (a, b, _) -> (a, b)
+    | _ -> assert false
+  type ex_lambda = Ex_lambda : (_, _) lambda ty -> ex_lambda
+  let is_lambda : type a . a ty -> ex_lambda option = function
+    | Lambda_t (_, _, _) as x -> Some (Ex_lambda x)
+    | _ -> None
+
+  let timestamp = Timestamp_t None
+  let timestamp_k = Timestamp_key None
+
+  let map a b = Map_t (a, b, None)
+
+  let assert_type (_:'a ty) (_:'a) = ()
+end
+
+module Values = struct
+  let empty_map t = empty_map t
+
+  let empty_big_map key_type comparable_key_ty value_type : ('a, 'b) big_map = {
+    key_type ; value_type ; diff = empty_map comparable_key_ty ;
+  }
+
+  let int n = Script_int.of_int n
+
+  let nat n = Script_int.abs @@ Script_int.of_int n
+  let nat_to_int n = Option.unopt_exn (Failure "nat_to_int") @@ Script_int.to_int n
+
+  let tez n = Option.unopt_exn (Failure "Values.tez") @@ Tez.of_mutez @@ Int64.of_int n
+
+  let left a = L a
+
+  let right b = R b
+end
diff --git a/src/lib_ligo/meta-michelson/dune b/src/lib_ligo/meta-michelson/dune
new file mode 100644
index 000000000..7187c4cc2
--- /dev/null
+++ b/src/lib_ligo/meta-michelson/dune
@@ -0,0 +1,9 @@
+(library
+ (name meta_michelson)
+ (public_name meta-michelson)
+ (libraries
+   tezos-utils
+   michelson-parser
+   tezos-micheline
+ )
+)
diff --git a/src/lib_ligo/meta-michelson/json.ml b/src/lib_ligo/meta-michelson/json.ml
new file mode 100644
index 000000000..9ed070d0c
--- /dev/null
+++ b/src/lib_ligo/meta-michelson/json.ml
@@ -0,0 +1,7 @@
+let force_record ~msg json = match json with
+  | `O json -> json
+  | _ -> raise @@ Failure ("not json record : " ^ msg)
+
+let force_string ~msg json = match json with
+  | `String str -> str
+  | _ -> raise @@ Failure ("not json str : " ^ msg)
diff --git a/src/lib_ligo/meta-michelson/meta-michelson.opam b/src/lib_ligo/meta-michelson/meta-michelson.opam
new file mode 100644
index 000000000..fc81bfadb
--- /dev/null
+++ b/src/lib_ligo/meta-michelson/meta-michelson.opam
@@ -0,0 +1,22 @@
+name: "meta-michelson"
+opam-version: "2.0"
+version: "1.0"
+maintainer: "gabriel.alfour@gmail.com"
+authors: [ "Galfour" ]
+homepage: "https://gitlab.com/gabriel.alfour/tezos"
+bug-reports: "https://gitlab.com/gabriel.alfour/tezos/issues"
+dev-repo: "git+https://gitlab.com/gabriel.alfour/tezos.git"
+license: "MIT"
+depends: [
+  "ocamlfind" { build }
+  "dune" { build & >= "1.0.1" }
+  "tezos-utils"
+  "michelson-parser"
+]
+build: [
+  [ "dune" "build" "-p" name "-j" jobs ]
+  [ "mv" "src/lib_ligo/meta-michelson/meta-michelson.install" "." ]
+]
+url {
+  src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz"
+}
diff --git a/src/lib_ligo/meta-michelson/meta_michelson.ml b/src/lib_ligo/meta-michelson/meta_michelson.ml
new file mode 100644
index 000000000..f9cba1a8d
--- /dev/null
+++ b/src/lib_ligo/meta-michelson/meta_michelson.ml
@@ -0,0 +1,4 @@
+module Wrap = Michelson_wrap
+module Contract = Contract
+
+let init_environment = Misc.init_environment
diff --git a/src/lib_ligo/meta-michelson/michelson_wrap.ml b/src/lib_ligo/meta-michelson/michelson_wrap.ml
new file mode 100644
index 000000000..63d43a369
--- /dev/null
+++ b/src/lib_ligo/meta-michelson/michelson_wrap.ml
@@ -0,0 +1,514 @@
+open Tezos_utils.Memory_proto_alpha
+module AC = Alpha_context
+
+module Types = Contract.Types
+module Option = Tezos_utils.Option
+module MBytes = Alpha_environment.MBytes
+
+module Stack = struct
+  open Script_typed_ir
+
+  let descr bef aft instr =
+    {
+      loc = 0 ;
+      bef ; aft ; instr
+    }
+
+  type nonrec 'a ty = 'a ty
+  type 'a t = 'a stack_ty
+  type nonrec ('a, 'b) descr = ('a, 'b) descr
+  type ('a, 'b) code = ('a t) -> ('a, 'b) descr
+
+  type ex_stack_ty = Ex_stack_ty : 'a t -> ex_stack_ty
+  type ex_descr = Ex_descr : ('a, 'b) descr -> ex_descr
+  type ex_code = Ex_code : ('a, 'b) code -> ex_code
+
+  let stack ?annot a b = Item_t (a, b, annot)
+  let unstack (item: (('a * 'rest) stack_ty)) : ('a ty * 'rest stack_ty) =
+    let Item_t (hd, tl, _) = item in
+    (hd, tl)
+
+  let nil = Empty_t
+  let head x = fst @@ unstack x
+  let tail x = snd @@ unstack x
+
+  let seq a b bef =
+    let a_descr = a bef in
+    let b_descr = b a_descr.aft in
+    let aft = b_descr.aft in
+    descr bef aft @@ Seq (a_descr, b_descr)
+
+  let (@>) (stack : 'b t) (code : ('a, 'b) code) = code stack
+  let (@|) = seq
+  let (@:) = stack
+
+  let (!:) : ('a, 'b) descr -> ('a, 'b) code = fun d _ -> d
+
+  let (<.) (stack:'a t) (code: ('a, 'b) code): ('a, 'b) descr = code stack
+
+  let (<::) : ('a, 'b) descr -> ('b, 'c) descr -> ('a, 'c) descr = fun ab bc ->
+    descr ab.bef bc.aft @@ Seq(ab, bc)
+
+  let (<:) (ab_descr:('a, 'b) descr) (code:('b, 'c) code) : ('a, 'c) descr =
+    let bc_descr = code ab_descr.aft in
+    ab_descr <:: bc_descr
+
+end
+
+open Stack
+
+type nat = AC.Script_int.n AC.Script_int.num
+type int_num = AC.Script_int.z AC.Script_int.num
+type bytes = MBytes.t
+type address = AC.Contract.t Script_typed_ir.ty
+type mutez = AC.Tez.t Script_typed_ir.ty
+
+
+module Stack_ops = struct
+  open Script_typed_ir
+  let dup : ('a * 'rest, 'a * ('a * 'rest)) code = fun bef ->
+    let Item_t (ty, rest, _) = bef in
+    descr bef (Item_t (ty, Item_t (ty, rest, None), None)) Dup
+
+  let drop : ('a * 'rest, 'rest) code = fun bef ->
+    let aft = snd @@ unstack bef in
+    descr bef aft Drop
+
+  let swap (bef : (('a * ('b * 'c)) stack_ty)) =
+    let Item_t (a, Item_t (b, rest, _), _) = bef in
+    descr bef (Item_t (b, (Item_t (a, rest, None)), None)) Swap
+
+  let dip code (bef : ('ty * 'rest) stack_ty) =
+    let Item_t (ty, rest, _) = bef in
+    let applied = code rest in
+    let aft = Item_t (ty, applied.aft, None) in
+    descr bef aft (Dip (code rest))
+
+  let noop : ('r, 'r) code = fun bef ->
+    descr bef bef Nop
+
+  let exec : (_, _) code = fun bef ->
+    let lambda = head @@ tail bef in
+    let (_, ret) = Types.assert_lambda lambda in
+    let aft = ret @: (tail @@ tail bef) in
+    descr bef aft Exec
+
+  let fail aft : ('a * 'r, 'b) code = fun bef ->
+    let head = fst @@ unstack bef in
+    descr bef aft (Failwith head)
+
+  let push_string str (bef : 'rest stack_ty) : (_, (string * 'rest)) descr =
+    let aft = Item_t (Types.string, bef, None) in
+    descr bef aft (Const (str))
+
+  let push_none (a:'a ty) : ('rest, 'a option * 'rest) code = fun r ->
+    let aft = stack (Types.option a) r in
+    descr r aft (Const None)
+
+  let push_unit : ('rest, unit * 'rest) code = fun r ->
+    let aft = stack Types.unit r in
+    descr r aft (Const ())
+
+  let push_nat n (bef : 'rest stack_ty) : (_, (nat * 'rest)) descr =
+    let aft = Item_t (Types.nat, bef, None) in
+    descr bef aft (Const (Contract.Values.nat n))
+
+  let push_int n (bef : 'rest stack_ty) : (_, (int_num * 'rest)) descr =
+    let aft = Types.int @: bef in
+    descr bef aft (Const (Contract.Values.int n))
+
+  let push_tez n (bef : 'rest stack_ty) : (_, (AC.Tez.tez * 'rest)) descr =
+    let aft = Types.mutez @: bef in
+    descr bef aft (Const (Contract.Values.tez n))
+
+  let push_bool b : ('s, bool * 's) code = fun bef ->
+    let aft = stack Types.bool bef in
+    descr bef aft (Const b)
+
+  let push_generic ty v : ('s, _ * 's) code = fun bef ->
+    let aft = stack ty bef in
+    descr bef aft (Const v)
+
+  let failstring str aft =
+    push_string str @| fail aft
+
+end
+
+module Stack_shortcuts = struct
+  open Stack_ops
+
+  let diip c x = dip (dip c) x
+  let diiip c x = dip (diip c) x
+  let diiiip c x = dip (diiip c) x
+
+  let bubble_1 = swap
+  let bubble_down_1 = swap
+
+  let bubble_2 : ('a * ('b * ('c * 'r)), 'c * ('a * ('b * 'r))) code = fun bef ->
+    bef <. dip swap <: swap
+  let bubble_down_2 : ('a * ('b * ('c * 'r)), ('b * ('c * ('a * 'r)))) code = fun bef ->
+    bef <. swap <: dip swap
+
+  let bubble_3 : ('a * ('b * ('c * ('d * 'r))), 'd * ('a * ('b * ('c * 'r)))) code = fun bef ->
+    bef <. diip swap <: dip swap <: swap
+
+  let keep_1 : type r s . ('a * r, s) code -> ('a * r, 'a * s) code = fun code bef ->
+    bef <. dup <: dip code
+
+  let save_1_1 : type r . ('a * r, 'b * r) code -> ('a * r, 'b * ('a * r)) code = fun code s ->
+    s <. keep_1 code <: swap
+
+  let keep_2 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), ('a * ('b * s))) code = fun code bef ->
+    (dup @| dip (swap @| dup @| dip (swap @| code))) bef
+
+  let keep_2_1 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), 'b * s) code = fun code bef ->
+    (dip dup @| swap @| dip code) bef
+
+  let relativize_1_1 : ('a * unit, 'b * unit) descr -> ('a * 'r, 'b * 'r) code = fun d s ->
+    let aft = head d.aft @: tail s in
+    descr s aft d.instr
+
+end
+
+module Pair_ops = struct
+  let car (bef : (('a * 'b) * 'rest) Stack.t) =
+    let (pair, rest) = unstack bef in
+    let (a, _) = Contract.Types.assert_pair pair in
+    descr bef (stack a rest) Car
+
+  let cdr (bef : (('a * 'b) * 'rest) Stack.t) =
+    let (pair, rest) = unstack bef in
+    let (_, b) = Contract.Types.assert_pair pair in
+    descr bef (stack b rest) Cdr
+
+  let pair (bef : ('a * ('b * 'rest)) Stack.t) =
+    let (a, rest) = unstack bef in
+    let (b, rest) = unstack rest in
+    let aft = (Types.pair a b) @: rest in
+    descr bef aft Cons_pair
+
+  open Stack_ops
+  let carcdr s = s <. car <: Stack_ops.dip cdr
+
+  let cdrcar s = s <. cdr <: dip car
+
+  let cdrcdr s = s <. cdr <: dip cdr
+
+  let carcar s = s <. car <: dip car
+
+  let cdar s = s <. cdr <: car
+
+  let unpair s = s <. dup <: car <: dip cdr
+end
+
+module Option_ops = struct
+  open Script_typed_ir
+
+  let cons bef =
+    let (hd, tl) = unstack bef in
+    descr bef (stack (Contract.Types.option hd) tl) Cons_some
+
+  let cond ?target none_branch some_branch : ('a option * 'r, 'b) code = fun bef ->
+    let (a_opt, base) = unstack bef in
+    let a = Types.assert_option a_opt in
+    let target = Option.unopt ~default:(none_branch base).aft target in
+    descr bef target (If_none (none_branch base, some_branch (stack a base)))
+
+  let force_some ?msg : ('a option * 'r, 'a * 'r) code = fun s ->
+    let (a_opt, base) = unstack s in
+    let a = Types.assert_option a_opt in
+    let target = a @: base in
+    cond ~target
+      (Stack_ops.failstring ("force_some : " ^ Option.unopt ~default:"" msg) target)
+      Stack_ops.noop s
+end
+
+module Union_ops = struct
+  open Script_typed_ir
+
+  let left (b:'b ty) : ('a * 'r, ('a, 'b) union * 'r) code = fun bef ->
+    let (a, base) = unstack bef in
+    let aft = Types.union a b @: base in
+    descr bef aft Left
+
+  let right (a:'a ty) : ('b * 'r, ('a, 'b) union * 'r) code = fun bef ->
+    let (b, base) = unstack bef in
+    let aft = Types.union a b @: base in
+    descr bef aft Right
+
+
+  let loop ?after (code: ('a * 'r, ('a, 'b) union * 'r) code): (('a, 'b) union * 'r, 'b * 'r) code = fun bef ->
+    let (union, base) = unstack bef in
+    let (a, b) = Types.assert_union union in
+    let code_stack = a @: base in
+    let aft = Option.unopt ~default:(b @: base) after in
+    descr bef aft (Loop_left (code code_stack))
+
+end
+
+module Arithmetic = struct
+  let neq : (int_num * 'r, bool *'r) code = fun bef ->
+    let aft = stack Types.bool @@ snd @@ unstack bef in
+    descr bef aft Neq
+
+  let neg : (int_num * 'r, int_num *'r) code = fun bef ->
+    let aft = stack Types.int @@ snd @@ unstack bef in
+    descr bef aft Neg_int
+
+  let abs : (int_num * 'r, nat *'r) code = fun bef ->
+    let aft = stack Types.nat @@ snd @@ unstack bef in
+    descr bef aft Abs_int
+
+  let int : (nat * 'r, int_num*'r) code = fun bef ->
+    let aft = stack Types.int @@ snd @@ unstack bef in
+    descr bef aft Int_nat
+
+  let nat_opt : (int_num * 'r, nat option * 'r) code = fun bef ->
+    let aft = stack Types.(option nat) @@ tail bef in
+    descr bef aft Is_nat
+
+  let nat_neq = fun s -> (int @| neq) s
+
+  let add_natnat (bef : (nat * (nat * 'rest)) Stack.t) =
+    let (nat, rest) = unstack bef in
+    let rest = tail rest in
+    let aft = stack nat rest in
+    descr bef aft Add_natnat
+
+  let add_intint (bef : (int_num * (int_num * 'rest)) Stack.t) =
+    let (nat, rest) = unstack bef in
+    let rest = tail rest in
+    let aft = stack nat rest in
+    descr bef aft Add_intint
+
+  let add_teztez : (AC.Tez.tez * (AC.Tez.tez * 'rest), _) code = fun bef ->
+    let aft = tail bef in
+    descr bef aft Add_tez
+
+  let mul_natnat (bef : (nat * (nat * 'rest)) Stack.t) =
+    let nat = head bef in
+    let rest = tail @@ tail bef in
+    let aft = stack nat rest in
+    descr bef aft Mul_natnat
+
+  let mul_intint (bef : (int_num * (int_num * 'rest)) Stack.t) =
+    let nat = head bef in
+    let rest = tail @@ tail bef in
+    let aft = stack nat rest in
+    descr bef aft Mul_intint
+
+  let sub_intint : (int_num * (int_num * 'r), int_num * 'r) code = fun bef ->
+    let aft = tail bef in
+    descr bef aft Sub_int
+
+  let sub_natnat : (nat * (nat * 'r), int_num * 'r) code =
+    fun bef -> bef <. int <: Stack_ops.dip int <: sub_intint
+
+  let ediv : (nat * (nat * 'r), (nat * nat) option * 'r) code = fun s ->
+    let (n, base) = unstack @@ snd @@ unstack s in
+    let aft = Types.option (Types.pair n n) @: base in
+    descr s aft Ediv_natnat
+
+  let ediv_tez = fun s ->
+    let aft = Types.(option @@ pair (head s) (head s)) @: tail @@ tail s in
+    descr s aft Ediv_teznat
+
+  open Option_ops
+  let force_ediv x = x <. ediv <: force_some
+  let force_ediv_tez x = (ediv_tez @| force_some) x
+
+  open Pair_ops
+  let div x = x <. force_ediv <: car
+
+  open Stack_ops
+  let div_n n s = s <. push_nat n <: swap <: div
+  let add_n n s = s <. push_nat n <: swap <: add_natnat
+  let add_teztez_n n s = s <. push_tez n <: swap <: add_teztez
+  let sub_n n s = s <. push_nat n <: swap <: sub_natnat
+
+  let force_nat s = s <. nat_opt <: force_some ~msg:"force nat"
+end
+
+module Boolean = struct
+  let bool_and (type r) : (bool * (bool * r), bool * r) code = fun bef ->
+    let aft = Types.bool @: tail @@ tail bef in
+    descr bef aft And
+
+  let bool_or (type r) : (bool * (bool * r), bool * r) code = fun bef ->
+    let aft = Types.bool @: tail @@ tail bef in
+    descr bef aft Or
+
+  open Script_typed_ir
+  let cond ?target true_branch false_branch : (bool * 'r, 's) code = fun bef ->
+    let base = tail bef in
+    let aft = Option.unopt ~default:((true_branch base).aft) target in
+    descr bef aft (If (true_branch base, false_branch base))
+
+  let loop (code : ('s, bool * 's) code) : ((bool * 's), 's) code = fun bef ->
+    let aft = tail bef in
+    descr bef aft @@ Loop (code aft)
+
+end
+
+module Comparison_ops = struct
+  let cmp c_ty : _ code = fun bef ->
+    let aft = stack Contract.Types.int @@ tail @@ tail @@ bef in
+    descr bef aft (Compare c_ty)
+
+  let cmp_bytes = fun x -> cmp (Bytes_key None) x
+
+  let eq : (int_num * 'r, bool *'r) code = fun bef ->
+    let aft = stack Contract.Types.bool @@ snd @@ unstack bef in
+    descr bef aft Eq
+
+  open Arithmetic
+  let eq_n n s = s <. sub_n n <: eq
+
+  let ge : (int_num * 'r, bool * 'r) code = fun bef ->
+    let base = tail bef in
+    let aft = stack Types.bool base in
+    descr bef aft Ge
+
+  let gt : (int_num * 'r, bool * 'r) code = fun bef ->
+    let base = tail bef in
+    let aft = stack Types.bool base in
+    descr bef aft Gt
+
+  let lt : (int_num * 'r, bool * 'r) code = fun bef ->
+    let base = tail bef in
+    let aft = stack Types.bool base in
+    descr bef aft Lt
+
+  let gt_nat s = s <. int <: gt
+
+  open Stack_ops
+  let assert_positive_nat s = s <. dup <: gt_nat <: Boolean.cond noop (failstring "positive" s)
+
+  let cmp_ge_nat : (nat * (nat * 'r), bool * 'r) code = fun bef ->
+    bef <. sub_natnat <: ge
+
+  let cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), bool * 'r) code = fun bef ->
+    bef <. cmp Types.timestamp_k <: ge
+
+  let assert_cmp_ge_nat : (nat * (nat * 'r), 'r) code = fun bef ->
+    bef <. cmp_ge_nat <: Boolean.cond noop (failstring "assert cmp ge nat" (tail @@ tail bef))
+
+  let assert_cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), 'r) code = fun bef ->
+    bef <. cmp_ge_timestamp <: Boolean.cond noop (failstring "assert cmp ge timestamp" (tail @@ tail bef))
+end
+
+
+module Bytes = struct
+
+  open Script_typed_ir
+
+  let pack (ty:'a ty) : ('a * 'r, bytes * 'r) code = fun bef ->
+    let aft = stack Types.bytes @@ tail bef in
+    descr bef aft (Pack ty)
+
+  let unpack_opt : type a . a ty -> (bytes * 'r, a option * 'r) code = fun ty bef ->
+    let aft = stack (Types.option ty) (tail bef) in
+    descr bef aft (Unpack ty)
+
+  let unpack ty s = s <. unpack_opt ty <: Option_ops.force_some
+
+  let concat : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) code = fun bef ->
+    let aft = tail bef in
+    descr bef aft Concat_bytes_pair
+
+  let sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef ->
+    descr bef bef Sha256
+
+  let blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef ->
+    descr bef bef Blake2b
+end
+
+
+module Map = struct
+  open Script_typed_ir
+
+  type ('a, 'b) t = ('a, 'b) map
+
+  let empty c_ty = Script_ir_translator.empty_map c_ty
+  let set (type a b) m (k:a) (v:b) = Script_ir_translator.map_update k (Some v) m
+
+  module Ops = struct
+    let update (bef : (('a * ('b option * (('a, 'b) map * ('rest)))) Stack.t)) : (_, ('a, 'b) map * 'rest) descr =
+      let Item_t (_, Item_t (_, Item_t (map, rest, _), _), _) = bef in
+      let aft = Item_t (map, rest, None) in
+      descr bef aft Map_update
+
+    let get : ?a:('a ty) -> 'b ty -> ('a * (('a, 'b) map * 'r), 'b option * 'r) code = fun ?a b bef ->
+      let _ = a in
+      let base = snd @@ unstack @@ snd @@ unstack bef in
+      let aft = stack (Types.option b) base in
+      descr bef aft Map_get
+
+    let big_get : 'a ty -> 'b ty -> ('a * (('a, 'b) big_map * 'r), 'b option * 'r) code = fun _a b bef ->
+      let base = snd @@ unstack @@ snd @@ unstack bef in
+      let aft = stack (Types.option b) base in
+      descr bef aft Big_map_get
+
+    let big_update : ('a * ('b option * (('a, 'b) big_map * 'r)), ('a, 'b) big_map * 'r) code = fun bef ->
+      let base = tail @@ tail bef in
+      descr bef base Big_map_update
+  end
+end
+
+module List_ops = struct
+  let nil ele bef =
+    let aft = stack (Types.list ele) bef in
+    descr bef aft Nil
+
+  let cons bef =
+    let aft = tail bef in
+    descr bef aft Cons_list
+
+  let cond ~target cons_branch nil_branch bef =
+    let (lst, aft) = unstack bef in
+    let a = Types.assert_list lst in
+    let cons_descr = cons_branch (a @: Types.list a @: aft) in
+    let nil_descr = nil_branch aft in
+    descr bef target (If_cons (cons_descr, nil_descr))
+
+  let list_iter : type a r . (a * r, r) code -> (a list * r, r) code = fun code bef ->
+    let (a_lst, aft) = unstack bef in
+    let a = Types.assert_list a_lst in
+    descr bef aft (List_iter (code (a @: aft)))
+
+end
+
+module Tez = struct
+
+  let amount : ('r, AC.Tez.t * 'r) code = fun bef ->
+    let aft = Types.mutez @: bef in
+    descr bef aft Amount
+
+  open Bytes
+
+  let tez_nat s = s <. pack Types.mutez <: unpack Types.nat
+  let amount_nat s = s <. amount <: pack Types.mutez <: unpack Types.nat
+end
+
+module Misc = struct
+
+  open Stack_ops
+  open Stack_shortcuts
+  open Comparison_ops
+  let min_nat : (nat * (nat * 'r), nat * 'r) code = fun s -> 
+    s <.
+    keep_2 cmp_ge_nat <: bubble_2 <:
+    Boolean.cond drop (dip drop)
+
+  let debug ~msg () s = s <. push_string msg <: push_string "_debug" <: noop <: drop <: drop
+
+  let debug_msg msg = debug ~msg ()
+
+  let now : ('r, AC.Script_timestamp.t * 'r) code = fun bef ->
+    let aft = stack Types.timestamp bef in
+    descr bef aft Now
+
+end
+
+
+
diff --git a/src/lib_ligo/meta-michelson/misc.ml b/src/lib_ligo/meta-michelson/misc.ml
new file mode 100644
index 000000000..622b283d7
--- /dev/null
+++ b/src/lib_ligo/meta-michelson/misc.ml
@@ -0,0 +1,300 @@
+module Signature = Tezos_base.TzPervasives.Signature
+open Tezos_utils.Memory_proto_alpha
+module Data_encoding = Alpha_environment.Data_encoding
+module MBytes = Alpha_environment.MBytes
+module Error_monad = Tezos_utils.Error_monad
+open Error_monad
+
+module Context_init = struct
+
+  type account = {
+      pkh : Signature.Public_key_hash.t ;
+      pk :  Signature.Public_key.t ;
+      sk :  Signature.Secret_key.t ;
+    }
+
+  let generate_accounts n : (account * Tez_repr.t) list =
+    let amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in
+    List.map (fun _ ->
+        let (pkh, pk, sk) = Signature.generate_key () in
+        let account = { pkh ; pk ; sk } in
+        account, amount)
+      (Tezos_utils.List.range n)
+
+  let make_shell
+        ~level ~predecessor ~timestamp ~fitness ~operations_hash =
+    Tezos_base.Block_header.{
+        level ;
+        predecessor ;
+        timestamp ;
+        fitness ;
+        operations_hash ;
+        (* We don't care of the following values, only the shell validates them. *)
+        proto_level = 0 ;
+        validation_passes = 0 ;
+        context = Alpha_environment.Context_hash.zero ;
+    }
+
+  let default_proof_of_work_nonce =
+    MBytes.create Alpha_context.Constants.proof_of_work_nonce_size
+
+  let protocol_param_key = [ "protocol_parameters" ]
+
+  let check_constants_consistency constants =
+    let open Constants_repr in
+    let open Error_monad in
+    let { blocks_per_cycle ; blocks_per_commitment ;
+          blocks_per_roll_snapshot ; _ } = constants in
+    Error_monad.unless (blocks_per_commitment <= blocks_per_cycle)
+      (fun () -> failwith "Inconsistent constants : blocks per commitment must be \
+                           less than blocks per cycle") >>=? fun () ->
+    Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot)
+      (fun () -> failwith "Inconsistent constants : blocks per cycle \
+                           must be superior than blocks per roll snapshot") >>=?
+      return
+
+
+  let initial_context
+        constants
+        header
+        commitments
+        initial_accounts
+        security_deposit_ramp_up_cycles
+        no_reward_cycles
+    =
+    let open Tezos_base.TzPervasives.Error_monad in
+    let bootstrap_accounts =
+      List.map (fun ({ pk ; pkh ; _ }, amount) ->
+          Parameters_repr.{ public_key_hash = pkh ; public_key = Some pk ; amount }
+        ) initial_accounts
+    in
+    let json =
+      Data_encoding.Json.construct
+        Parameters_repr.encoding
+        Parameters_repr.{
+          bootstrap_accounts ;
+          bootstrap_contracts = [] ;
+          commitments ;
+          constants ;
+          security_deposit_ramp_up_cycles ;
+          no_reward_cycles ;
+      }
+    in
+    let proto_params =
+      Data_encoding.Binary.to_bytes_exn Data_encoding.json json
+    in
+    Tezos_protocol_environment_memory.Context.(
+      set empty ["version"] (MBytes.of_string "genesis")
+    ) >>= fun ctxt ->
+    Tezos_protocol_environment_memory.Context.(
+      set ctxt protocol_param_key proto_params
+    ) >>= fun ctxt ->
+    Main.init ctxt header
+    >|= Alpha_environment.wrap_error >>=? fun { context; _ } ->
+    return context
+
+  let genesis
+        ?(preserved_cycles = Constants_repr.default.preserved_cycles)
+        ?(blocks_per_cycle = Constants_repr.default.blocks_per_cycle)
+        ?(blocks_per_commitment = Constants_repr.default.blocks_per_commitment)
+        ?(blocks_per_roll_snapshot = Constants_repr.default.blocks_per_roll_snapshot)
+        ?(blocks_per_voting_period = Constants_repr.default.blocks_per_voting_period)
+        ?(time_between_blocks = Constants_repr.default.time_between_blocks)
+        ?(endorsers_per_block = Constants_repr.default.endorsers_per_block)
+        ?(hard_gas_limit_per_operation = Constants_repr.default.hard_gas_limit_per_operation)
+        ?(hard_gas_limit_per_block = Constants_repr.default.hard_gas_limit_per_block)
+        ?(proof_of_work_threshold = Int64.(neg one))
+        ?(tokens_per_roll = Constants_repr.default.tokens_per_roll)
+        ?(michelson_maximum_type_size = Constants_repr.default.michelson_maximum_type_size)
+        ?(seed_nonce_revelation_tip = Constants_repr.default.seed_nonce_revelation_tip)
+        ?(origination_size = Constants_repr.default.origination_size)
+        ?(block_security_deposit = Constants_repr.default.block_security_deposit)
+        ?(endorsement_security_deposit = Constants_repr.default.endorsement_security_deposit)
+        ?(block_reward = Constants_repr.default.block_reward)
+        ?(endorsement_reward = Constants_repr.default.endorsement_reward)
+        ?(cost_per_byte = Constants_repr.default.cost_per_byte)
+        ?(hard_storage_limit_per_operation = Constants_repr.default.hard_storage_limit_per_operation)
+        ?(commitments = [])
+        ?(security_deposit_ramp_up_cycles = None)
+        ?(no_reward_cycles = None)
+        (initial_accounts : (account * Tez_repr.t) list)
+    =
+    if initial_accounts = [] then
+      Pervasives.failwith "Must have one account with a roll to bake";
+
+    (* Check there is at least one roll *)
+    let open Tezos_base.TzPervasives.Error_monad in
+    begin try
+        let (>>?=) x y = match x with
+          | Ok(a) -> y a
+          | Error(b) -> fail @@ List.hd b in
+        fold_left_s (fun acc (_, amount) ->
+            Alpha_environment.wrap_error @@
+              Tez_repr.(+?) acc amount >>?= fun acc ->
+                                            if acc >= tokens_per_roll then
+                                              raise Exit
+                                            else return acc
+          ) Tez_repr.zero initial_accounts >>=? fun _ ->
+      failwith "Insufficient tokens in initial accounts to create one roll"
+    with Exit -> return ()
+    end >>=? fun () ->
+
+    let constants : Constants_repr.parametric = {
+        preserved_cycles ;
+        blocks_per_cycle ;
+        blocks_per_commitment ;
+        blocks_per_roll_snapshot ;
+        blocks_per_voting_period ;
+        time_between_blocks ;
+        endorsers_per_block ;
+        hard_gas_limit_per_operation ;
+        hard_gas_limit_per_block ;
+        proof_of_work_threshold ;
+        tokens_per_roll ;
+        michelson_maximum_type_size ;
+        seed_nonce_revelation_tip ;
+        origination_size ;
+        block_security_deposit ;
+        endorsement_security_deposit ;
+        block_reward ;
+        endorsement_reward ;
+        cost_per_byte ;
+        hard_storage_limit_per_operation ;
+      } in
+    check_constants_consistency constants >>=? fun () ->
+
+    let hash =
+      Alpha_environment.Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
+    in
+    let shell = make_shell
+                  ~level:0l
+                  ~predecessor:hash
+                  ~timestamp:Tezos_utils.Time.epoch
+                  ~fitness: (Fitness_repr.from_int64 0L)
+                  ~operations_hash: Alpha_environment.Operation_list_list_hash.zero in
+    initial_context
+      constants
+      shell
+      commitments
+      initial_accounts
+      security_deposit_ramp_up_cycles
+      no_reward_cycles
+    >>=? fun context ->
+    return (context, shell, hash)
+
+  let init
+        ?(slow=false)
+        ?preserved_cycles
+        ?endorsers_per_block
+        ?commitments
+        n =
+    let open Error_monad in
+    let accounts = generate_accounts n in
+    let contracts = List.map (fun (a, _) ->
+                        Alpha_context.Contract.implicit_contract (a.pkh)) accounts in
+    begin
+      if slow then
+        genesis
+          ?preserved_cycles
+          ?endorsers_per_block
+          ?commitments
+          accounts
+      else
+        genesis
+          ?preserved_cycles
+          ~blocks_per_cycle:32l
+          ~blocks_per_commitment:4l
+          ~blocks_per_roll_snapshot:8l
+          ~blocks_per_voting_period:(Int32.mul 32l 8l)
+          ?endorsers_per_block
+          ?commitments
+          accounts
+    end >>=? fun ctxt ->
+    return (ctxt, accounts, contracts)
+
+  let contents
+        ?(proof_of_work_nonce = default_proof_of_work_nonce)
+        ?(priority = 0) ?seed_nonce_hash () =
+    Alpha_context.Block_header.({
+      priority ;
+      proof_of_work_nonce ;
+      seed_nonce_hash ;
+    })
+
+
+  let begin_construction ?(priority=0) ~timestamp ~(header:Alpha_context.Block_header.shell_header) ~hash ctxt =
+    let contents = contents ~priority () in
+    let protocol_data = Alpha_context.Block_header.{
+        contents ;
+        signature = Signature.zero ;
+      } in
+    let header = {
+        Alpha_context.Block_header.shell = {
+          predecessor = hash ;
+          proto_level = header.proto_level ;
+          validation_passes = header.validation_passes ;
+          fitness = header.fitness ;
+          timestamp ;
+          level = header.level ;
+          context = Alpha_environment.Context_hash.zero ;
+          operations_hash = Alpha_environment.Operation_list_list_hash.zero ;
+        } ;
+        protocol_data = {
+            contents ;
+            signature = Signature.zero ;
+          } ;
+      } in
+    Main.begin_construction
+      ~chain_id: Alpha_environment.Chain_id.zero
+      ~predecessor_context: ctxt
+      ~predecessor_timestamp: header.shell.timestamp
+      ~predecessor_fitness: header.shell.fitness
+      ~predecessor_level: header.shell.level
+      ~predecessor:hash
+      ~timestamp
+      ~protocol_data
+      () >>= fun x -> Lwt.return @@ Alpha_environment.wrap_error x >>=? fun state ->
+    return state.ctxt
+
+  let main n =
+    init n >>=? fun ((ctxt, header, hash), accounts, contracts) ->
+    let timestamp = Tezos_base.Time.now () in
+    begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt ->
+    return (ctxt, accounts, contracts)
+
+end
+
+type identity = {
+  public_key_hash : Signature.public_key_hash;
+  public_key : Signature.public_key;
+  secret_key : Signature.secret_key;
+  implicit_contract : Alpha_context.Contract.t;
+}
+
+type environment = {
+  tezos_context : Alpha_context.t ;
+  identities : identity list ;
+}
+
+let init_environment () =
+  Context_init.main 10 >>=? fun (tezos_context, accounts, contracts) ->
+  let accounts = List.map fst accounts in
+  let tezos_context = Alpha_context.Gas.set_limit tezos_context @@ Z.of_int 350000 in
+  let identities =
+    List.map (fun ((a:Context_init.account), c) -> {
+          public_key = a.pk ;
+          public_key_hash = a.pkh ;
+          secret_key = a.sk ;
+          implicit_contract = c ;
+        }) @@
+    List.combine accounts contracts in
+  return {tezos_context ; identities}
+
+let contextualize ~msg ?environment f =
+  let lwt =
+    let environment = match environment with
+      | None -> init_environment ()
+      | Some x -> return x in
+    environment >>=? f
+  in
+  force_ok ~msg @@ Lwt_main.run lwt
diff --git a/src/lib_ligo/meta-michelson/streams.ml b/src/lib_ligo/meta-michelson/streams.ml
new file mode 100644
index 000000000..b45176516
--- /dev/null
+++ b/src/lib_ligo/meta-michelson/streams.ml
@@ -0,0 +1,18 @@
+let read_file f =
+  let ic = open_in f in
+  let n = in_channel_length ic in
+  let s = Bytes.create n in
+  really_input ic s 0 n;
+  close_in ic;
+  Bytes.to_string s
+
+let read_lines filename = 
+  let lines = ref [] in
+  let chan = open_in filename in
+  try
+    while true; do
+      lines := input_line chan :: !lines
+    done; !lines
+  with End_of_file ->
+    close_in chan;
+    List.rev !lines
diff --git a/src/ligo/meta-michelson/alpha_wrap.ml b/src/ligo/meta-michelson/alpha_wrap.ml
new file mode 100644
index 000000000..196f6a9c4
--- /dev/null
+++ b/src/ligo/meta-michelson/alpha_wrap.ml
@@ -0,0 +1,30 @@
+open Tezos_utils.Error_monad
+
+let dummy_environment = force_lwt ~msg:"getting dummy env" @@ Misc.init_environment ()
+
+let tc = dummy_environment.tezos_context
+
+module Proto_alpha = Tezos_utils.Memory_proto_alpha
+open Proto_alpha
+open Alpha_context
+open Alpha_environment
+
+let pack ty v = fst @@ force_lwt_alpha ~msg:"packing" @@ Script_ir_translator.pack_data tc ty v
+let unpack_opt (type a) : a Script_typed_ir.ty -> MBytes.t -> a option = fun ty bytes ->
+  force_lwt ~msg:"unpacking : parse" (
+    if Compare.Int.(MBytes.length bytes >= 1) &&
+       Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then
+      let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
+      match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
+      | None -> return None
+      | Some expr ->
+        Script_ir_translator.parse_data tc ty (Micheline.root expr) >>=?? fun x -> return (Some (fst x))
+    else
+      return None
+  )
+
+let unpack ty a = match unpack_opt ty a with
+  | None -> raise @@ Failure "unpacking : of_bytes"
+  | Some x -> x
+
+let blake2b b = Alpha_environment.Raw_hashes.blake2b b
diff --git a/src/ligo/meta-michelson/contract.ml b/src/ligo/meta-michelson/contract.ml
new file mode 100644
index 000000000..d5ce41d4c
--- /dev/null
+++ b/src/ligo/meta-michelson/contract.ml
@@ -0,0 +1,310 @@
+open Misc
+
+open Tezos_utils.Error_monad
+open Memory_proto_alpha
+open Alpha_context
+
+open Script_ir_translator
+open Script_typed_ir
+
+module Option = Tezos_utils.Option
+module Cast = Tezos_utils.Cast
+
+type ('param, 'storage) toplevel = {
+  param_type : 'param ty ;
+  storage_type : 'storage ty ;
+  code : ('param * 'storage, packed_internal_operation list * 'storage) lambda
+}
+
+type ex_toplevel =
+    Ex_toplevel : ('a, 'b) toplevel -> ex_toplevel
+
+let get_toplevel ?environment toplevel_path claimed_storage_type claimed_parameter_type =
+  let toplevel_str = Streams.read_file toplevel_path in
+  contextualize ?environment ~msg:"toplevel" @@ fun {tezos_context = context ; _ } ->
+  let toplevel_expr = Cast.tl_of_string toplevel_str in
+  let (param_ty_node, storage_ty_node, code_field) =
+    force_ok_alpha ~msg:"parsing toplevel" @@
+    parse_toplevel toplevel_expr in
+  let (Ex_ty param_type, _) =
+    force_ok_alpha ~msg:"parse arg ty" @@
+    Script_ir_translator.parse_ty context ~allow_big_map:false ~allow_operation:false param_ty_node in
+  let (Ex_ty storage_type, _) =
+    force_ok_alpha ~msg:"parse storage ty" @@
+    parse_storage_ty context storage_ty_node in
+  let _ = force_ok_alpha ~msg:"storage eq" @@ Script_ir_translator.ty_eq context storage_type claimed_storage_type in
+  let _ = force_ok_alpha ~msg:"param eq" @@ Script_ir_translator.ty_eq context param_type claimed_parameter_type in
+  let param_type_full = Pair_t ((claimed_parameter_type, None, None),
+                                (claimed_storage_type, None, None), None) in
+  let ret_type_full =
+    Pair_t ((List_t (Operation_t None, None), None, None),
+            (claimed_storage_type, None, None), None) in
+  parse_returning (Toplevel { storage_type = claimed_storage_type ; param_type = claimed_parameter_type })
+    context (param_type_full, None) ret_type_full code_field >>=?? fun (code, _) ->
+  Error_monad.return {
+    param_type = claimed_parameter_type;
+    storage_type = claimed_storage_type;
+    code ;
+  }
+
+let make_toplevel code storage_type param_type =
+  { param_type ; storage_type ; code }
+
+module type ENVIRONMENT = sig
+  val identities : identity list
+  val tezos_context : t
+end
+
+type ex_typed_stack = Ex_typed_stack : ('a stack_ty * 'a Script_interpreter.stack) -> ex_typed_stack
+
+open Error_monad
+
+module Step (Env: ENVIRONMENT) = struct
+  open Env
+
+  type config = {
+    source : Contract.t option ;
+    payer : Contract.t option ;
+    self : Contract.t option ;
+    visitor : (Script_interpreter.ex_descr_stack -> unit) option ;
+    timestamp : Script_timestamp.t option ;
+    debug_visitor : (ex_typed_stack -> unit) option ;
+    amount : Tez.t option ;
+  }
+
+  let no_config = {
+    source = None ;
+    payer = None ;
+    self = None ;
+    visitor = None ;
+    debug_visitor = None ;
+    timestamp = None ;
+    amount = None ;
+  }
+
+  let of_param base param = match param with
+    | None -> base
+    | Some _ as x -> x
+
+  let make_config ?base_config ?source ?payer ?self ?visitor ?debug_visitor ?timestamp ?amount () =
+    let base_config = Option.unopt ~default:no_config base_config in {
+      source = Option.first_some source base_config.source ;
+      payer = Option.first_some payer base_config.payer ;
+      self = Option.first_some self base_config.self ;
+      visitor = Option.first_some visitor base_config.visitor ;
+      debug_visitor = Option.first_some debug_visitor base_config.debug_visitor ;
+      timestamp = Option.first_some timestamp base_config.timestamp ;
+      amount = Option.first_some amount base_config.amount ;
+    }
+
+  open Error_monad
+
+  let debug_visitor ?f () =
+    let open Script_interpreter in
+    let aux (Ex_descr_stack (descr, stack)) =
+      (match (descr.instr, descr.bef) with
+       | Nop, Item_t (String_t _, stack_ty, _) -> (
+           let (Item (s, stack)) = stack in
+           if s = "_debug"
+           then (
+             match f with
+             | None -> Format.printf "debug: %s\n%!" @@ Cast.stack_to_string stack_ty stack
+             | Some f -> f (Ex_typed_stack(stack_ty, stack))
+           ) else ()
+         )
+       | _ -> ()) ;
+      () in
+    aux
+
+  let step_lwt ?(config=no_config) (stack:'a Script_interpreter.stack) (code:('a, 'b) descr) =
+    let source = Option.unopt
+        ~default:(List.nth identities 0).implicit_contract config.source in
+    let payer = Option.unopt
+        ~default:(List.nth identities 1).implicit_contract config.payer in
+    let self = Option.unopt
+        ~default:(List.nth identities 2).implicit_contract config.self in
+    let amount = Option.unopt ~default:(Tez.one) config.amount in
+    let visitor =
+      let default = debug_visitor ?f:config.debug_visitor () in
+      Option.unopt ~default config.visitor in
+    let tezos_context = match config.timestamp with
+      | None -> tezos_context
+      | Some s -> Alpha_context.Script_timestamp.set_now tezos_context s in
+    Script_interpreter.step tezos_context ~source ~payer ~self ~visitor amount code stack >>=?? fun (stack, _) ->
+    return stack
+
+  let step_1_2 ?config (a:'a) (descr:('a * end_of_stack, 'b * ('c * end_of_stack)) descr) =
+    let open Script_interpreter in
+    step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Item(c, Empty))) ->
+    return (b, c)
+
+  let step_3_1 ?config (a:'a) (b:'b) (c:'c)
+      (descr:('a * ('b * ('c * end_of_stack)), 'd * end_of_stack) descr) =
+    let open Script_interpreter in
+    step_lwt ?config (Item(a, Item(b, Item(c, Empty)))) descr >>=? fun (Item(d, Empty)) ->
+    return d
+
+  let step_2_1 ?config (a:'a) (b:'b) (descr:('a * ('b * end_of_stack), 'c * end_of_stack) descr) =
+    let open Script_interpreter in
+    step_lwt ?config (Item(a, Item(b, Empty))) descr >>=? fun (Item(c, Empty)) ->
+    return c
+
+  let step_1_1 ?config (a:'a) (descr:('a * end_of_stack, 'b * end_of_stack) descr) =
+    let open Script_interpreter in
+    step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Empty)) ->
+    return b
+
+  let step_value ?config (a:'a) (descr:('a * end_of_stack, 'a * end_of_stack) descr) =
+    step_1_1 ?config a descr
+
+  let step ?config stack code =
+    force_lwt ~msg:"running a step" @@ step_lwt ?config stack code
+
+end
+
+let run_lwt_full ?source ?payer ?self toplevel storage param {identities ; tezos_context = context} =
+  let { code ; _ } = toplevel in
+
+  let source = Option.unopt
+      ~default:(List.nth identities 0).implicit_contract source in
+  let payer = Option.unopt
+      ~default:(List.nth identities 1).implicit_contract payer in
+  let self = Option.unopt
+      ~default:(List.nth identities 2).implicit_contract self in
+  let amount = Tez.one in
+
+  Script_interpreter.interp context ~source ~payer ~self amount code (param, storage)
+  >>=?? fun ((ops, storage), new_ctxt) ->
+  let gas = Alpha_context.Gas.consumed ~since:context ~until:new_ctxt in
+  return (storage, ops, gas)
+
+let run_lwt ?source ?payer ?self toplevel storage param env =
+  run_lwt_full ?source ?payer ?self toplevel storage param env >>=? fun (storage, _ops, _gas) ->
+  return storage
+
+let run ?environment toplevel storage param =
+  contextualize ?environment ~msg:"run toplevel" @@ run_lwt toplevel storage param
+
+let run_node ?environment toplevel storage_node param_node =
+  contextualize ?environment ~msg:"run toplevel" @@ fun {tezos_context = context ; _} ->
+  let {param_type ; storage_type ; _ } = toplevel in
+  parse_data context param_type param_node >>=?? fun (param, _) ->
+  parse_data context storage_type storage_node >>=?? fun (storage, _) ->
+  let storage = run toplevel storage param in
+  unparse_data context Readable storage_type storage >>=?? fun (storage_node, _) ->
+  return storage_node
+
+let run_str toplevel storage_str param_str =
+  let param_node = Cast.node_of_string param_str in
+  let storage_node = Cast.node_of_string storage_str in
+  run_node toplevel storage_node param_node
+
+type input = {
+  toplevel_path : string ;
+  storage : string ;
+  parameter : string
+}
+
+let parse_json json_str : input =
+  let json = force_ok_str ~msg:"main_contract: invalid json" @@ Tezos_utils.Data_encoding.Json.from_string json_str in
+  let json = match json with
+    | `O json ->  json
+    | _ -> raise @@ Failure "main_contract: not recorD"
+  in
+  let open Json in
+  let toplevel_path = force_string ~msg:"main_contract, top_level" @@ List.assoc "top_level" json in
+  let parameter = force_string ~msg:"main_contract, param" @@ List.assoc "param" json in
+  let storage = force_string ~msg:"main_contract, storage" @@ List.assoc "storage" json in
+  { toplevel_path ; storage ; parameter }
+
+let generate_json (storage_node:Script.node) : string =
+  let storage_expr = Tezos_micheline.Micheline.strip_locations storage_node in
+  let json = Data_encoding.Json.construct Script.expr_encoding storage_expr in
+  Format.fprintf Format.str_formatter "%a" Data_encoding.Json.pp json ;
+  Format.flush_str_formatter ()
+
+module Types = struct
+  open Script_typed_ir
+
+  let union a b = Union_t ((a, None), (b, None), None)
+  let assert_union = function
+    | Union_t ((a, _), (b, _), _) -> (a, b)
+    | _ -> assert false
+
+  let pair a b = Pair_t ((a, None, None), (b, None, None), None)
+  let assert_pair = function
+    | Pair_t ((a, _, _), ((b, _, _)), _) -> (a, b)
+    | _ -> assert false
+  let assert_pair_ex ?(msg="assert pair") (Ex_ty ty) = match ty with
+    | Pair_t ((a, _, _), ((b, _, _)), _) -> (Ex_ty a, Ex_ty b)
+    | _ -> raise (Failure msg)
+
+  let unit = Unit_t None
+
+  let bytes = Bytes_t None
+  let bytes_k = Bytes_key None
+
+  let nat = Nat_t None
+  let int = Int_t None
+  let nat_k = Nat_key None
+
+  let big_map k v = Big_map_t (k, v, None)
+
+  let signature = Signature_t None
+
+  let bool = Bool_t None
+
+  let mutez = Mutez_t None
+
+  let string = String_t None
+  let string_k = String_key None
+
+  let key = Key_t None
+
+  let list a = List_t (a, None)
+  let assert_list = function
+    | List_t (a, _) -> a
+    | _ -> assert false
+
+  let option a = Option_t ((a, None), None, None)
+  let assert_option = function
+    | Option_t ((a, _), _, _) -> a
+    | _ -> assert false
+
+  let address = Address_t None
+
+  let lambda a b = Lambda_t (a, b, None)
+  let assert_lambda = function
+    | Lambda_t (a, b, _) -> (a, b)
+    | _ -> assert false
+  type ex_lambda = Ex_lambda : (_, _) lambda ty -> ex_lambda
+  let is_lambda : type a . a ty -> ex_lambda option = function
+    | Lambda_t (_, _, _) as x -> Some (Ex_lambda x)
+    | _ -> None
+
+  let timestamp = Timestamp_t None
+  let timestamp_k = Timestamp_key None
+
+  let map a b = Map_t (a, b, None)
+
+  let assert_type (_:'a ty) (_:'a) = ()
+end
+
+module Values = struct
+  let empty_map t = empty_map t
+
+  let empty_big_map key_type comparable_key_ty value_type : ('a, 'b) big_map = {
+    key_type ; value_type ; diff = empty_map comparable_key_ty ;
+  }
+
+  let int n = Script_int.of_int n
+
+  let nat n = Script_int.abs @@ Script_int.of_int n
+  let nat_to_int n = Option.unopt_exn (Failure "nat_to_int") @@ Script_int.to_int n
+
+  let tez n = Option.unopt_exn (Failure "Values.tez") @@ Tez.of_mutez @@ Int64.of_int n
+
+  let left a = L a
+
+  let right b = R b
+end
diff --git a/src/ligo/meta-michelson/dune b/src/ligo/meta-michelson/dune
new file mode 100644
index 000000000..7187c4cc2
--- /dev/null
+++ b/src/ligo/meta-michelson/dune
@@ -0,0 +1,9 @@
+(library
+ (name meta_michelson)
+ (public_name meta-michelson)
+ (libraries
+   tezos-utils
+   michelson-parser
+   tezos-micheline
+ )
+)
diff --git a/src/ligo/meta-michelson/json.ml b/src/ligo/meta-michelson/json.ml
new file mode 100644
index 000000000..9ed070d0c
--- /dev/null
+++ b/src/ligo/meta-michelson/json.ml
@@ -0,0 +1,7 @@
+let force_record ~msg json = match json with
+  | `O json -> json
+  | _ -> raise @@ Failure ("not json record : " ^ msg)
+
+let force_string ~msg json = match json with
+  | `String str -> str
+  | _ -> raise @@ Failure ("not json str : " ^ msg)
diff --git a/src/ligo/meta-michelson/meta-michelson.opam b/src/ligo/meta-michelson/meta-michelson.opam
new file mode 100644
index 000000000..3543c7772
--- /dev/null
+++ b/src/ligo/meta-michelson/meta-michelson.opam
@@ -0,0 +1,21 @@
+name: "meta-michelson"
+opam-version: "2.0"
+version: "1.0"
+maintainer: "gabriel.alfour@gmail.com"
+authors: [ "Galfour" ]
+homepage: "https://gitlab.com/gabriel.alfour/tezos"
+bug-reports: "https://gitlab.com/gabriel.alfour/tezos/issues"
+dev-repo: "git+https://gitlab.com/gabriel.alfour/tezos.git"
+license: "MIT"
+depends: [
+  "ocamlfind" { build }
+  "dune" { build & >= "1.0.1" }
+  "tezos-utils"
+  "michelson-parser"
+]
+build: [
+  [ "dune" "build" "-p" name "-j" jobs ]
+]
+url {
+  src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz"
+}
diff --git a/src/ligo/meta-michelson/meta_michelson.ml b/src/ligo/meta-michelson/meta_michelson.ml
new file mode 100644
index 000000000..f9cba1a8d
--- /dev/null
+++ b/src/ligo/meta-michelson/meta_michelson.ml
@@ -0,0 +1,4 @@
+module Wrap = Michelson_wrap
+module Contract = Contract
+
+let init_environment = Misc.init_environment
diff --git a/src/ligo/meta-michelson/michelson_wrap.ml b/src/ligo/meta-michelson/michelson_wrap.ml
new file mode 100644
index 000000000..63d43a369
--- /dev/null
+++ b/src/ligo/meta-michelson/michelson_wrap.ml
@@ -0,0 +1,514 @@
+open Tezos_utils.Memory_proto_alpha
+module AC = Alpha_context
+
+module Types = Contract.Types
+module Option = Tezos_utils.Option
+module MBytes = Alpha_environment.MBytes
+
+module Stack = struct
+  open Script_typed_ir
+
+  let descr bef aft instr =
+    {
+      loc = 0 ;
+      bef ; aft ; instr
+    }
+
+  type nonrec 'a ty = 'a ty
+  type 'a t = 'a stack_ty
+  type nonrec ('a, 'b) descr = ('a, 'b) descr
+  type ('a, 'b) code = ('a t) -> ('a, 'b) descr
+
+  type ex_stack_ty = Ex_stack_ty : 'a t -> ex_stack_ty
+  type ex_descr = Ex_descr : ('a, 'b) descr -> ex_descr
+  type ex_code = Ex_code : ('a, 'b) code -> ex_code
+
+  let stack ?annot a b = Item_t (a, b, annot)
+  let unstack (item: (('a * 'rest) stack_ty)) : ('a ty * 'rest stack_ty) =
+    let Item_t (hd, tl, _) = item in
+    (hd, tl)
+
+  let nil = Empty_t
+  let head x = fst @@ unstack x
+  let tail x = snd @@ unstack x
+
+  let seq a b bef =
+    let a_descr = a bef in
+    let b_descr = b a_descr.aft in
+    let aft = b_descr.aft in
+    descr bef aft @@ Seq (a_descr, b_descr)
+
+  let (@>) (stack : 'b t) (code : ('a, 'b) code) = code stack
+  let (@|) = seq
+  let (@:) = stack
+
+  let (!:) : ('a, 'b) descr -> ('a, 'b) code = fun d _ -> d
+
+  let (<.) (stack:'a t) (code: ('a, 'b) code): ('a, 'b) descr = code stack
+
+  let (<::) : ('a, 'b) descr -> ('b, 'c) descr -> ('a, 'c) descr = fun ab bc ->
+    descr ab.bef bc.aft @@ Seq(ab, bc)
+
+  let (<:) (ab_descr:('a, 'b) descr) (code:('b, 'c) code) : ('a, 'c) descr =
+    let bc_descr = code ab_descr.aft in
+    ab_descr <:: bc_descr
+
+end
+
+open Stack
+
+type nat = AC.Script_int.n AC.Script_int.num
+type int_num = AC.Script_int.z AC.Script_int.num
+type bytes = MBytes.t
+type address = AC.Contract.t Script_typed_ir.ty
+type mutez = AC.Tez.t Script_typed_ir.ty
+
+
+module Stack_ops = struct
+  open Script_typed_ir
+  let dup : ('a * 'rest, 'a * ('a * 'rest)) code = fun bef ->
+    let Item_t (ty, rest, _) = bef in
+    descr bef (Item_t (ty, Item_t (ty, rest, None), None)) Dup
+
+  let drop : ('a * 'rest, 'rest) code = fun bef ->
+    let aft = snd @@ unstack bef in
+    descr bef aft Drop
+
+  let swap (bef : (('a * ('b * 'c)) stack_ty)) =
+    let Item_t (a, Item_t (b, rest, _), _) = bef in
+    descr bef (Item_t (b, (Item_t (a, rest, None)), None)) Swap
+
+  let dip code (bef : ('ty * 'rest) stack_ty) =
+    let Item_t (ty, rest, _) = bef in
+    let applied = code rest in
+    let aft = Item_t (ty, applied.aft, None) in
+    descr bef aft (Dip (code rest))
+
+  let noop : ('r, 'r) code = fun bef ->
+    descr bef bef Nop
+
+  let exec : (_, _) code = fun bef ->
+    let lambda = head @@ tail bef in
+    let (_, ret) = Types.assert_lambda lambda in
+    let aft = ret @: (tail @@ tail bef) in
+    descr bef aft Exec
+
+  let fail aft : ('a * 'r, 'b) code = fun bef ->
+    let head = fst @@ unstack bef in
+    descr bef aft (Failwith head)
+
+  let push_string str (bef : 'rest stack_ty) : (_, (string * 'rest)) descr =
+    let aft = Item_t (Types.string, bef, None) in
+    descr bef aft (Const (str))
+
+  let push_none (a:'a ty) : ('rest, 'a option * 'rest) code = fun r ->
+    let aft = stack (Types.option a) r in
+    descr r aft (Const None)
+
+  let push_unit : ('rest, unit * 'rest) code = fun r ->
+    let aft = stack Types.unit r in
+    descr r aft (Const ())
+
+  let push_nat n (bef : 'rest stack_ty) : (_, (nat * 'rest)) descr =
+    let aft = Item_t (Types.nat, bef, None) in
+    descr bef aft (Const (Contract.Values.nat n))
+
+  let push_int n (bef : 'rest stack_ty) : (_, (int_num * 'rest)) descr =
+    let aft = Types.int @: bef in
+    descr bef aft (Const (Contract.Values.int n))
+
+  let push_tez n (bef : 'rest stack_ty) : (_, (AC.Tez.tez * 'rest)) descr =
+    let aft = Types.mutez @: bef in
+    descr bef aft (Const (Contract.Values.tez n))
+
+  let push_bool b : ('s, bool * 's) code = fun bef ->
+    let aft = stack Types.bool bef in
+    descr bef aft (Const b)
+
+  let push_generic ty v : ('s, _ * 's) code = fun bef ->
+    let aft = stack ty bef in
+    descr bef aft (Const v)
+
+  let failstring str aft =
+    push_string str @| fail aft
+
+end
+
+module Stack_shortcuts = struct
+  open Stack_ops
+
+  let diip c x = dip (dip c) x
+  let diiip c x = dip (diip c) x
+  let diiiip c x = dip (diiip c) x
+
+  let bubble_1 = swap
+  let bubble_down_1 = swap
+
+  let bubble_2 : ('a * ('b * ('c * 'r)), 'c * ('a * ('b * 'r))) code = fun bef ->
+    bef <. dip swap <: swap
+  let bubble_down_2 : ('a * ('b * ('c * 'r)), ('b * ('c * ('a * 'r)))) code = fun bef ->
+    bef <. swap <: dip swap
+
+  let bubble_3 : ('a * ('b * ('c * ('d * 'r))), 'd * ('a * ('b * ('c * 'r)))) code = fun bef ->
+    bef <. diip swap <: dip swap <: swap
+
+  let keep_1 : type r s . ('a * r, s) code -> ('a * r, 'a * s) code = fun code bef ->
+    bef <. dup <: dip code
+
+  let save_1_1 : type r . ('a * r, 'b * r) code -> ('a * r, 'b * ('a * r)) code = fun code s ->
+    s <. keep_1 code <: swap
+
+  let keep_2 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), ('a * ('b * s))) code = fun code bef ->
+    (dup @| dip (swap @| dup @| dip (swap @| code))) bef
+
+  let keep_2_1 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), 'b * s) code = fun code bef ->
+    (dip dup @| swap @| dip code) bef
+
+  let relativize_1_1 : ('a * unit, 'b * unit) descr -> ('a * 'r, 'b * 'r) code = fun d s ->
+    let aft = head d.aft @: tail s in
+    descr s aft d.instr
+
+end
+
+module Pair_ops = struct
+  let car (bef : (('a * 'b) * 'rest) Stack.t) =
+    let (pair, rest) = unstack bef in
+    let (a, _) = Contract.Types.assert_pair pair in
+    descr bef (stack a rest) Car
+
+  let cdr (bef : (('a * 'b) * 'rest) Stack.t) =
+    let (pair, rest) = unstack bef in
+    let (_, b) = Contract.Types.assert_pair pair in
+    descr bef (stack b rest) Cdr
+
+  let pair (bef : ('a * ('b * 'rest)) Stack.t) =
+    let (a, rest) = unstack bef in
+    let (b, rest) = unstack rest in
+    let aft = (Types.pair a b) @: rest in
+    descr bef aft Cons_pair
+
+  open Stack_ops
+  let carcdr s = s <. car <: Stack_ops.dip cdr
+
+  let cdrcar s = s <. cdr <: dip car
+
+  let cdrcdr s = s <. cdr <: dip cdr
+
+  let carcar s = s <. car <: dip car
+
+  let cdar s = s <. cdr <: car
+
+  let unpair s = s <. dup <: car <: dip cdr
+end
+
+module Option_ops = struct
+  open Script_typed_ir
+
+  let cons bef =
+    let (hd, tl) = unstack bef in
+    descr bef (stack (Contract.Types.option hd) tl) Cons_some
+
+  let cond ?target none_branch some_branch : ('a option * 'r, 'b) code = fun bef ->
+    let (a_opt, base) = unstack bef in
+    let a = Types.assert_option a_opt in
+    let target = Option.unopt ~default:(none_branch base).aft target in
+    descr bef target (If_none (none_branch base, some_branch (stack a base)))
+
+  let force_some ?msg : ('a option * 'r, 'a * 'r) code = fun s ->
+    let (a_opt, base) = unstack s in
+    let a = Types.assert_option a_opt in
+    let target = a @: base in
+    cond ~target
+      (Stack_ops.failstring ("force_some : " ^ Option.unopt ~default:"" msg) target)
+      Stack_ops.noop s
+end
+
+module Union_ops = struct
+  open Script_typed_ir
+
+  let left (b:'b ty) : ('a * 'r, ('a, 'b) union * 'r) code = fun bef ->
+    let (a, base) = unstack bef in
+    let aft = Types.union a b @: base in
+    descr bef aft Left
+
+  let right (a:'a ty) : ('b * 'r, ('a, 'b) union * 'r) code = fun bef ->
+    let (b, base) = unstack bef in
+    let aft = Types.union a b @: base in
+    descr bef aft Right
+
+
+  let loop ?after (code: ('a * 'r, ('a, 'b) union * 'r) code): (('a, 'b) union * 'r, 'b * 'r) code = fun bef ->
+    let (union, base) = unstack bef in
+    let (a, b) = Types.assert_union union in
+    let code_stack = a @: base in
+    let aft = Option.unopt ~default:(b @: base) after in
+    descr bef aft (Loop_left (code code_stack))
+
+end
+
+module Arithmetic = struct
+  let neq : (int_num * 'r, bool *'r) code = fun bef ->
+    let aft = stack Types.bool @@ snd @@ unstack bef in
+    descr bef aft Neq
+
+  let neg : (int_num * 'r, int_num *'r) code = fun bef ->
+    let aft = stack Types.int @@ snd @@ unstack bef in
+    descr bef aft Neg_int
+
+  let abs : (int_num * 'r, nat *'r) code = fun bef ->
+    let aft = stack Types.nat @@ snd @@ unstack bef in
+    descr bef aft Abs_int
+
+  let int : (nat * 'r, int_num*'r) code = fun bef ->
+    let aft = stack Types.int @@ snd @@ unstack bef in
+    descr bef aft Int_nat
+
+  let nat_opt : (int_num * 'r, nat option * 'r) code = fun bef ->
+    let aft = stack Types.(option nat) @@ tail bef in
+    descr bef aft Is_nat
+
+  let nat_neq = fun s -> (int @| neq) s
+
+  let add_natnat (bef : (nat * (nat * 'rest)) Stack.t) =
+    let (nat, rest) = unstack bef in
+    let rest = tail rest in
+    let aft = stack nat rest in
+    descr bef aft Add_natnat
+
+  let add_intint (bef : (int_num * (int_num * 'rest)) Stack.t) =
+    let (nat, rest) = unstack bef in
+    let rest = tail rest in
+    let aft = stack nat rest in
+    descr bef aft Add_intint
+
+  let add_teztez : (AC.Tez.tez * (AC.Tez.tez * 'rest), _) code = fun bef ->
+    let aft = tail bef in
+    descr bef aft Add_tez
+
+  let mul_natnat (bef : (nat * (nat * 'rest)) Stack.t) =
+    let nat = head bef in
+    let rest = tail @@ tail bef in
+    let aft = stack nat rest in
+    descr bef aft Mul_natnat
+
+  let mul_intint (bef : (int_num * (int_num * 'rest)) Stack.t) =
+    let nat = head bef in
+    let rest = tail @@ tail bef in
+    let aft = stack nat rest in
+    descr bef aft Mul_intint
+
+  let sub_intint : (int_num * (int_num * 'r), int_num * 'r) code = fun bef ->
+    let aft = tail bef in
+    descr bef aft Sub_int
+
+  let sub_natnat : (nat * (nat * 'r), int_num * 'r) code =
+    fun bef -> bef <. int <: Stack_ops.dip int <: sub_intint
+
+  let ediv : (nat * (nat * 'r), (nat * nat) option * 'r) code = fun s ->
+    let (n, base) = unstack @@ snd @@ unstack s in
+    let aft = Types.option (Types.pair n n) @: base in
+    descr s aft Ediv_natnat
+
+  let ediv_tez = fun s ->
+    let aft = Types.(option @@ pair (head s) (head s)) @: tail @@ tail s in
+    descr s aft Ediv_teznat
+
+  open Option_ops
+  let force_ediv x = x <. ediv <: force_some
+  let force_ediv_tez x = (ediv_tez @| force_some) x
+
+  open Pair_ops
+  let div x = x <. force_ediv <: car
+
+  open Stack_ops
+  let div_n n s = s <. push_nat n <: swap <: div
+  let add_n n s = s <. push_nat n <: swap <: add_natnat
+  let add_teztez_n n s = s <. push_tez n <: swap <: add_teztez
+  let sub_n n s = s <. push_nat n <: swap <: sub_natnat
+
+  let force_nat s = s <. nat_opt <: force_some ~msg:"force nat"
+end
+
+module Boolean = struct
+  let bool_and (type r) : (bool * (bool * r), bool * r) code = fun bef ->
+    let aft = Types.bool @: tail @@ tail bef in
+    descr bef aft And
+
+  let bool_or (type r) : (bool * (bool * r), bool * r) code = fun bef ->
+    let aft = Types.bool @: tail @@ tail bef in
+    descr bef aft Or
+
+  open Script_typed_ir
+  let cond ?target true_branch false_branch : (bool * 'r, 's) code = fun bef ->
+    let base = tail bef in
+    let aft = Option.unopt ~default:((true_branch base).aft) target in
+    descr bef aft (If (true_branch base, false_branch base))
+
+  let loop (code : ('s, bool * 's) code) : ((bool * 's), 's) code = fun bef ->
+    let aft = tail bef in
+    descr bef aft @@ Loop (code aft)
+
+end
+
+module Comparison_ops = struct
+  let cmp c_ty : _ code = fun bef ->
+    let aft = stack Contract.Types.int @@ tail @@ tail @@ bef in
+    descr bef aft (Compare c_ty)
+
+  let cmp_bytes = fun x -> cmp (Bytes_key None) x
+
+  let eq : (int_num * 'r, bool *'r) code = fun bef ->
+    let aft = stack Contract.Types.bool @@ snd @@ unstack bef in
+    descr bef aft Eq
+
+  open Arithmetic
+  let eq_n n s = s <. sub_n n <: eq
+
+  let ge : (int_num * 'r, bool * 'r) code = fun bef ->
+    let base = tail bef in
+    let aft = stack Types.bool base in
+    descr bef aft Ge
+
+  let gt : (int_num * 'r, bool * 'r) code = fun bef ->
+    let base = tail bef in
+    let aft = stack Types.bool base in
+    descr bef aft Gt
+
+  let lt : (int_num * 'r, bool * 'r) code = fun bef ->
+    let base = tail bef in
+    let aft = stack Types.bool base in
+    descr bef aft Lt
+
+  let gt_nat s = s <. int <: gt
+
+  open Stack_ops
+  let assert_positive_nat s = s <. dup <: gt_nat <: Boolean.cond noop (failstring "positive" s)
+
+  let cmp_ge_nat : (nat * (nat * 'r), bool * 'r) code = fun bef ->
+    bef <. sub_natnat <: ge
+
+  let cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), bool * 'r) code = fun bef ->
+    bef <. cmp Types.timestamp_k <: ge
+
+  let assert_cmp_ge_nat : (nat * (nat * 'r), 'r) code = fun bef ->
+    bef <. cmp_ge_nat <: Boolean.cond noop (failstring "assert cmp ge nat" (tail @@ tail bef))
+
+  let assert_cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), 'r) code = fun bef ->
+    bef <. cmp_ge_timestamp <: Boolean.cond noop (failstring "assert cmp ge timestamp" (tail @@ tail bef))
+end
+
+
+module Bytes = struct
+
+  open Script_typed_ir
+
+  let pack (ty:'a ty) : ('a * 'r, bytes * 'r) code = fun bef ->
+    let aft = stack Types.bytes @@ tail bef in
+    descr bef aft (Pack ty)
+
+  let unpack_opt : type a . a ty -> (bytes * 'r, a option * 'r) code = fun ty bef ->
+    let aft = stack (Types.option ty) (tail bef) in
+    descr bef aft (Unpack ty)
+
+  let unpack ty s = s <. unpack_opt ty <: Option_ops.force_some
+
+  let concat : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) code = fun bef ->
+    let aft = tail bef in
+    descr bef aft Concat_bytes_pair
+
+  let sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef ->
+    descr bef bef Sha256
+
+  let blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef ->
+    descr bef bef Blake2b
+end
+
+
+module Map = struct
+  open Script_typed_ir
+
+  type ('a, 'b) t = ('a, 'b) map
+
+  let empty c_ty = Script_ir_translator.empty_map c_ty
+  let set (type a b) m (k:a) (v:b) = Script_ir_translator.map_update k (Some v) m
+
+  module Ops = struct
+    let update (bef : (('a * ('b option * (('a, 'b) map * ('rest)))) Stack.t)) : (_, ('a, 'b) map * 'rest) descr =
+      let Item_t (_, Item_t (_, Item_t (map, rest, _), _), _) = bef in
+      let aft = Item_t (map, rest, None) in
+      descr bef aft Map_update
+
+    let get : ?a:('a ty) -> 'b ty -> ('a * (('a, 'b) map * 'r), 'b option * 'r) code = fun ?a b bef ->
+      let _ = a in
+      let base = snd @@ unstack @@ snd @@ unstack bef in
+      let aft = stack (Types.option b) base in
+      descr bef aft Map_get
+
+    let big_get : 'a ty -> 'b ty -> ('a * (('a, 'b) big_map * 'r), 'b option * 'r) code = fun _a b bef ->
+      let base = snd @@ unstack @@ snd @@ unstack bef in
+      let aft = stack (Types.option b) base in
+      descr bef aft Big_map_get
+
+    let big_update : ('a * ('b option * (('a, 'b) big_map * 'r)), ('a, 'b) big_map * 'r) code = fun bef ->
+      let base = tail @@ tail bef in
+      descr bef base Big_map_update
+  end
+end
+
+module List_ops = struct
+  let nil ele bef =
+    let aft = stack (Types.list ele) bef in
+    descr bef aft Nil
+
+  let cons bef =
+    let aft = tail bef in
+    descr bef aft Cons_list
+
+  let cond ~target cons_branch nil_branch bef =
+    let (lst, aft) = unstack bef in
+    let a = Types.assert_list lst in
+    let cons_descr = cons_branch (a @: Types.list a @: aft) in
+    let nil_descr = nil_branch aft in
+    descr bef target (If_cons (cons_descr, nil_descr))
+
+  let list_iter : type a r . (a * r, r) code -> (a list * r, r) code = fun code bef ->
+    let (a_lst, aft) = unstack bef in
+    let a = Types.assert_list a_lst in
+    descr bef aft (List_iter (code (a @: aft)))
+
+end
+
+module Tez = struct
+
+  let amount : ('r, AC.Tez.t * 'r) code = fun bef ->
+    let aft = Types.mutez @: bef in
+    descr bef aft Amount
+
+  open Bytes
+
+  let tez_nat s = s <. pack Types.mutez <: unpack Types.nat
+  let amount_nat s = s <. amount <: pack Types.mutez <: unpack Types.nat
+end
+
+module Misc = struct
+
+  open Stack_ops
+  open Stack_shortcuts
+  open Comparison_ops
+  let min_nat : (nat * (nat * 'r), nat * 'r) code = fun s -> 
+    s <.
+    keep_2 cmp_ge_nat <: bubble_2 <:
+    Boolean.cond drop (dip drop)
+
+  let debug ~msg () s = s <. push_string msg <: push_string "_debug" <: noop <: drop <: drop
+
+  let debug_msg msg = debug ~msg ()
+
+  let now : ('r, AC.Script_timestamp.t * 'r) code = fun bef ->
+    let aft = stack Types.timestamp bef in
+    descr bef aft Now
+
+end
+
+
+
diff --git a/src/ligo/meta-michelson/misc.ml b/src/ligo/meta-michelson/misc.ml
new file mode 100644
index 000000000..622b283d7
--- /dev/null
+++ b/src/ligo/meta-michelson/misc.ml
@@ -0,0 +1,300 @@
+module Signature = Tezos_base.TzPervasives.Signature
+open Tezos_utils.Memory_proto_alpha
+module Data_encoding = Alpha_environment.Data_encoding
+module MBytes = Alpha_environment.MBytes
+module Error_monad = Tezos_utils.Error_monad
+open Error_monad
+
+module Context_init = struct
+
+  type account = {
+      pkh : Signature.Public_key_hash.t ;
+      pk :  Signature.Public_key.t ;
+      sk :  Signature.Secret_key.t ;
+    }
+
+  let generate_accounts n : (account * Tez_repr.t) list =
+    let amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in
+    List.map (fun _ ->
+        let (pkh, pk, sk) = Signature.generate_key () in
+        let account = { pkh ; pk ; sk } in
+        account, amount)
+      (Tezos_utils.List.range n)
+
+  let make_shell
+        ~level ~predecessor ~timestamp ~fitness ~operations_hash =
+    Tezos_base.Block_header.{
+        level ;
+        predecessor ;
+        timestamp ;
+        fitness ;
+        operations_hash ;
+        (* We don't care of the following values, only the shell validates them. *)
+        proto_level = 0 ;
+        validation_passes = 0 ;
+        context = Alpha_environment.Context_hash.zero ;
+    }
+
+  let default_proof_of_work_nonce =
+    MBytes.create Alpha_context.Constants.proof_of_work_nonce_size
+
+  let protocol_param_key = [ "protocol_parameters" ]
+
+  let check_constants_consistency constants =
+    let open Constants_repr in
+    let open Error_monad in
+    let { blocks_per_cycle ; blocks_per_commitment ;
+          blocks_per_roll_snapshot ; _ } = constants in
+    Error_monad.unless (blocks_per_commitment <= blocks_per_cycle)
+      (fun () -> failwith "Inconsistent constants : blocks per commitment must be \
+                           less than blocks per cycle") >>=? fun () ->
+    Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot)
+      (fun () -> failwith "Inconsistent constants : blocks per cycle \
+                           must be superior than blocks per roll snapshot") >>=?
+      return
+
+
+  let initial_context
+        constants
+        header
+        commitments
+        initial_accounts
+        security_deposit_ramp_up_cycles
+        no_reward_cycles
+    =
+    let open Tezos_base.TzPervasives.Error_monad in
+    let bootstrap_accounts =
+      List.map (fun ({ pk ; pkh ; _ }, amount) ->
+          Parameters_repr.{ public_key_hash = pkh ; public_key = Some pk ; amount }
+        ) initial_accounts
+    in
+    let json =
+      Data_encoding.Json.construct
+        Parameters_repr.encoding
+        Parameters_repr.{
+          bootstrap_accounts ;
+          bootstrap_contracts = [] ;
+          commitments ;
+          constants ;
+          security_deposit_ramp_up_cycles ;
+          no_reward_cycles ;
+      }
+    in
+    let proto_params =
+      Data_encoding.Binary.to_bytes_exn Data_encoding.json json
+    in
+    Tezos_protocol_environment_memory.Context.(
+      set empty ["version"] (MBytes.of_string "genesis")
+    ) >>= fun ctxt ->
+    Tezos_protocol_environment_memory.Context.(
+      set ctxt protocol_param_key proto_params
+    ) >>= fun ctxt ->
+    Main.init ctxt header
+    >|= Alpha_environment.wrap_error >>=? fun { context; _ } ->
+    return context
+
+  let genesis
+        ?(preserved_cycles = Constants_repr.default.preserved_cycles)
+        ?(blocks_per_cycle = Constants_repr.default.blocks_per_cycle)
+        ?(blocks_per_commitment = Constants_repr.default.blocks_per_commitment)
+        ?(blocks_per_roll_snapshot = Constants_repr.default.blocks_per_roll_snapshot)
+        ?(blocks_per_voting_period = Constants_repr.default.blocks_per_voting_period)
+        ?(time_between_blocks = Constants_repr.default.time_between_blocks)
+        ?(endorsers_per_block = Constants_repr.default.endorsers_per_block)
+        ?(hard_gas_limit_per_operation = Constants_repr.default.hard_gas_limit_per_operation)
+        ?(hard_gas_limit_per_block = Constants_repr.default.hard_gas_limit_per_block)
+        ?(proof_of_work_threshold = Int64.(neg one))
+        ?(tokens_per_roll = Constants_repr.default.tokens_per_roll)
+        ?(michelson_maximum_type_size = Constants_repr.default.michelson_maximum_type_size)
+        ?(seed_nonce_revelation_tip = Constants_repr.default.seed_nonce_revelation_tip)
+        ?(origination_size = Constants_repr.default.origination_size)
+        ?(block_security_deposit = Constants_repr.default.block_security_deposit)
+        ?(endorsement_security_deposit = Constants_repr.default.endorsement_security_deposit)
+        ?(block_reward = Constants_repr.default.block_reward)
+        ?(endorsement_reward = Constants_repr.default.endorsement_reward)
+        ?(cost_per_byte = Constants_repr.default.cost_per_byte)
+        ?(hard_storage_limit_per_operation = Constants_repr.default.hard_storage_limit_per_operation)
+        ?(commitments = [])
+        ?(security_deposit_ramp_up_cycles = None)
+        ?(no_reward_cycles = None)
+        (initial_accounts : (account * Tez_repr.t) list)
+    =
+    if initial_accounts = [] then
+      Pervasives.failwith "Must have one account with a roll to bake";
+
+    (* Check there is at least one roll *)
+    let open Tezos_base.TzPervasives.Error_monad in
+    begin try
+        let (>>?=) x y = match x with
+          | Ok(a) -> y a
+          | Error(b) -> fail @@ List.hd b in
+        fold_left_s (fun acc (_, amount) ->
+            Alpha_environment.wrap_error @@
+              Tez_repr.(+?) acc amount >>?= fun acc ->
+                                            if acc >= tokens_per_roll then
+                                              raise Exit
+                                            else return acc
+          ) Tez_repr.zero initial_accounts >>=? fun _ ->
+      failwith "Insufficient tokens in initial accounts to create one roll"
+    with Exit -> return ()
+    end >>=? fun () ->
+
+    let constants : Constants_repr.parametric = {
+        preserved_cycles ;
+        blocks_per_cycle ;
+        blocks_per_commitment ;
+        blocks_per_roll_snapshot ;
+        blocks_per_voting_period ;
+        time_between_blocks ;
+        endorsers_per_block ;
+        hard_gas_limit_per_operation ;
+        hard_gas_limit_per_block ;
+        proof_of_work_threshold ;
+        tokens_per_roll ;
+        michelson_maximum_type_size ;
+        seed_nonce_revelation_tip ;
+        origination_size ;
+        block_security_deposit ;
+        endorsement_security_deposit ;
+        block_reward ;
+        endorsement_reward ;
+        cost_per_byte ;
+        hard_storage_limit_per_operation ;
+      } in
+    check_constants_consistency constants >>=? fun () ->
+
+    let hash =
+      Alpha_environment.Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
+    in
+    let shell = make_shell
+                  ~level:0l
+                  ~predecessor:hash
+                  ~timestamp:Tezos_utils.Time.epoch
+                  ~fitness: (Fitness_repr.from_int64 0L)
+                  ~operations_hash: Alpha_environment.Operation_list_list_hash.zero in
+    initial_context
+      constants
+      shell
+      commitments
+      initial_accounts
+      security_deposit_ramp_up_cycles
+      no_reward_cycles
+    >>=? fun context ->
+    return (context, shell, hash)
+
+  let init
+        ?(slow=false)
+        ?preserved_cycles
+        ?endorsers_per_block
+        ?commitments
+        n =
+    let open Error_monad in
+    let accounts = generate_accounts n in
+    let contracts = List.map (fun (a, _) ->
+                        Alpha_context.Contract.implicit_contract (a.pkh)) accounts in
+    begin
+      if slow then
+        genesis
+          ?preserved_cycles
+          ?endorsers_per_block
+          ?commitments
+          accounts
+      else
+        genesis
+          ?preserved_cycles
+          ~blocks_per_cycle:32l
+          ~blocks_per_commitment:4l
+          ~blocks_per_roll_snapshot:8l
+          ~blocks_per_voting_period:(Int32.mul 32l 8l)
+          ?endorsers_per_block
+          ?commitments
+          accounts
+    end >>=? fun ctxt ->
+    return (ctxt, accounts, contracts)
+
+  let contents
+        ?(proof_of_work_nonce = default_proof_of_work_nonce)
+        ?(priority = 0) ?seed_nonce_hash () =
+    Alpha_context.Block_header.({
+      priority ;
+      proof_of_work_nonce ;
+      seed_nonce_hash ;
+    })
+
+
+  let begin_construction ?(priority=0) ~timestamp ~(header:Alpha_context.Block_header.shell_header) ~hash ctxt =
+    let contents = contents ~priority () in
+    let protocol_data = Alpha_context.Block_header.{
+        contents ;
+        signature = Signature.zero ;
+      } in
+    let header = {
+        Alpha_context.Block_header.shell = {
+          predecessor = hash ;
+          proto_level = header.proto_level ;
+          validation_passes = header.validation_passes ;
+          fitness = header.fitness ;
+          timestamp ;
+          level = header.level ;
+          context = Alpha_environment.Context_hash.zero ;
+          operations_hash = Alpha_environment.Operation_list_list_hash.zero ;
+        } ;
+        protocol_data = {
+            contents ;
+            signature = Signature.zero ;
+          } ;
+      } in
+    Main.begin_construction
+      ~chain_id: Alpha_environment.Chain_id.zero
+      ~predecessor_context: ctxt
+      ~predecessor_timestamp: header.shell.timestamp
+      ~predecessor_fitness: header.shell.fitness
+      ~predecessor_level: header.shell.level
+      ~predecessor:hash
+      ~timestamp
+      ~protocol_data
+      () >>= fun x -> Lwt.return @@ Alpha_environment.wrap_error x >>=? fun state ->
+    return state.ctxt
+
+  let main n =
+    init n >>=? fun ((ctxt, header, hash), accounts, contracts) ->
+    let timestamp = Tezos_base.Time.now () in
+    begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt ->
+    return (ctxt, accounts, contracts)
+
+end
+
+type identity = {
+  public_key_hash : Signature.public_key_hash;
+  public_key : Signature.public_key;
+  secret_key : Signature.secret_key;
+  implicit_contract : Alpha_context.Contract.t;
+}
+
+type environment = {
+  tezos_context : Alpha_context.t ;
+  identities : identity list ;
+}
+
+let init_environment () =
+  Context_init.main 10 >>=? fun (tezos_context, accounts, contracts) ->
+  let accounts = List.map fst accounts in
+  let tezos_context = Alpha_context.Gas.set_limit tezos_context @@ Z.of_int 350000 in
+  let identities =
+    List.map (fun ((a:Context_init.account), c) -> {
+          public_key = a.pk ;
+          public_key_hash = a.pkh ;
+          secret_key = a.sk ;
+          implicit_contract = c ;
+        }) @@
+    List.combine accounts contracts in
+  return {tezos_context ; identities}
+
+let contextualize ~msg ?environment f =
+  let lwt =
+    let environment = match environment with
+      | None -> init_environment ()
+      | Some x -> return x in
+    environment >>=? f
+  in
+  force_ok ~msg @@ Lwt_main.run lwt
diff --git a/src/ligo/meta-michelson/streams.ml b/src/ligo/meta-michelson/streams.ml
new file mode 100644
index 000000000..b45176516
--- /dev/null
+++ b/src/ligo/meta-michelson/streams.ml
@@ -0,0 +1,18 @@
+let read_file f =
+  let ic = open_in f in
+  let n = in_channel_length ic in
+  let s = Bytes.create n in
+  really_input ic s 0 n;
+  close_in ic;
+  Bytes.to_string s
+
+let read_lines filename = 
+  let lines = ref [] in
+  let chan = open_in filename in
+  try
+    while true; do
+      lines := input_line chan :: !lines
+    done; !lines
+  with End_of_file ->
+    close_in chan;
+    List.rev !lines