module Bc = struct
  [@@@warning "-32"]
  type t = {
    buf : Buffer.t;
    out : out_channel;
  }

  let make out =
    { buf = Buffer.create 256; out }

  let flush t =
    output_string t.out (Buffer.contents t.buf);
    Buffer.clear t.buf

  let wr_u8 t xs =
    List.iter (Buffer.add_uint8 t.buf) xs

  let wr_u16 t xs =
    List.iter (Buffer.add_uint16_le t.buf) xs

  let wr_i32 t xs =
    List.iter (Buffer.add_int32_le t.buf)
      (List.map Int32.of_int xs)

  type r = [`R of int]
  type v = [r | `K of int]
  type i = [r | `O of int]
  type l = [`L of r * i]

  let reg v =
    match v with
    | `R i -> assert (0 <= i && i <= 0xff); i

  let cst i =
    assert (0 <= i && i <= 0xff); i

  let arg v b0 =
    match v with
    | #r as v -> b0,            reg v
    | `K i ->    (b0 lor 0x80), cst i

  let ofs v =
    assert ((-0x80) <= v && v <= 0x7f);
    v land 0xff

  let loc v b0 =
    match v with
    | `L (r, (#r as i)) -> b0,            reg r lor (reg i lsl 8)
    | `L (r, `O i)      -> (b0 lor 0x40), reg r lor (ofs i lsl 8)

  let wr_ins_v b0 t (a : v) =
    let b0, b1 = arg a b0 in
    wr_u8 t [b0; b1]

  let wr_ins_rv b0 b1 t (a : r) (b : v) =
    let     b2 = reg a in
    let b0, b3 = arg b b0 in
    wr_u8 t [b0; b1; b2; b3]

  let wr_ins_rl b0 t (a : r) (b : l) =
    let     b1 = reg a in
    let b0, s2 = loc b b0 in
    wr_u8 t [b0; b1]; wr_u16 t [s2]

  let wr_ins_lv b0 t (b : l) (a : v) =
    let b0, b1 = arg a b0 in
    let b0, s2 = loc b b0 in
    wr_u8 t [b0; b1]; wr_u16 t [s2]

  let wr_op o t a b =
    assert (o >= 0x0 && o <= 0xf);
    wr_ins_rv 0x07 o t a b

  let wr_cb c t a b =
    assert (c >= 0xa && c <= 0xf);
    wr_ins_rv 0x17 c t a b

  let mov t a b =
    match a, b with
    | (#r as a), (#v as b) -> wr_ins_rv 0x01 0x00 t a b
    | (#r as a), (#l as b) -> wr_ins_rl 0x03 t a b
    | (#l as a), (#v as b) -> wr_ins_lv 0x05 t a b
    | #l, #l -> failwith "'mov L, L' mode unsupported"

  let jmp t d =
    let b0 = 0xff in
    let w0 = b0 lor (d lsl 8) in
    wr_i32 t [w0]

  let ret = wr_ins_v 0x00
  let btr = wr_ins_v 0x04
  let bfl = wr_ins_v 0x14
  let con = wr_op 0x0
  let not_= wr_op 0x1
  let neg = wr_op 0x2
  let add = wr_op 0x3
  let sub = wr_op 0x4
  let mul = wr_op 0x5
  let div = wr_op 0x6
  let mod_= wr_op 0x7
  let ceq = wr_op 0xa let beq = wr_cb 0xa
  let cne = wr_op 0xb let bne = wr_cb 0xb
  let clt = wr_op 0xc let blt = wr_cb 0xc
  let cge = wr_op 0xd let bge = wr_cb 0xd
  let cgt = wr_op 0xe let bgt = wr_cb 0xe
  let cle = wr_op 0xf let ble = wr_cb 0xf
end

let bc = Bc.make stdout

let () =
  begin
    Bc.mov bc (`R 0) (`K 0); (*      0 *)
    Bc.mov bc (`R 1) (`K 1); (*      2 *)
    Bc.bgt bc (`R 0) (`R 1); (*      4 *)
    Bc.jmp bc (+9 (* L3 *)); (*      6 *)
    Bc.jmp bc (+3 (* L2 *)); (*      8 *)
    Bc.ret bc (`R 1);        (* L1: 10 *)
    Bc.add bc (`R 1) (`K 2); (* L2: 11 *)
    Bc.jmp bc (-3 (* L1 *)); (*     13 *)
    Bc.mul bc (`R 1) (`R 1); (* L3: 15 *)
    Bc.jmp bc (-7 (* L1 *)); (*     17 *)
  end

let () =
  Bc.flush bc