DouKaku?

let parse = function
  | '>' -> "stackincr p;"
  | '<' -> "stackdecr p;"
  | '+' -> "incr code.(!p);"
  | '-' -> "decr code.(!p);"
  | '.' -> "print_char (char_of_int !(code.(!p)));"
  | ',' -> "code.(!p) := read_char ();"
  | '[' -> "while 0 <> !(code.(!p)) do"
  | ']' -> "done;;"
  |  _  -> ""  ;;

let main ?(stacksize=256) filename =
  let file = open_in filename in
  Printf.printf "\
    let stackincr x = if %d < (incr x; !x) then x:=0;;\n\
    let stackdecr x = if 0 > (decr x; !x) then x:=%d;;\n\
    let read_char () = int_of_char (read_line () ).[0];;\n\
    let code = Array.init %d (fun i -> ref 0);;\n\
    let p = ref 0;;\n\n"
    (stacksize-1) (stacksize-1) stacksize;
      
  let rec read_loop () =
    try
      let next = input_line file in
      String.iter (fun x -> print_endline (parse x)) next;
      read_loop ();
    with
      End_of_file -> close_in file   
  in read_loop ();;
  

if !(Sys.interactive)=false then
  match (Array.length Sys.argv) with
  | n when n=2 -> main Sys.argv.(1)
  | n when 2<n -> main ~stacksize:(int_of_string Sys.argv.(2)) Sys.argv.(1)
  | n          -> print_endline "usage: ocaml bf2ml.ml [stacksize] filename"
;;

open Camlp4.PreCast

module MyLexer = struct
  module Loc = Loc
  module Token = Token
  module Error = Token.Error

  let mk () loc sc =
    let rec next n = match Stream.peek sc with
      | None   -> Some(EOI, loc)
      | Some x -> let _ = Stream.junk sc in (match x with
        |'>'|'<'|'+'|'-'|'.'|','|'['|']'-> Some((SYMBOL (Printf.sprintf "%c" x)), loc)
        | _                             -> next n)
    in Stream.from next
end

module BF = MakeGram MyLexer

let expr = BF.Entry.mk "expr"
let repr = BF.Entry.mk "repr"
let term = BF.Entry.mk "term"

EXTEND BF
  expr: [[
      t = repr; `EOI     -> <:str_item<
        let p = ref 0 in
        let a = Array.create 1024 0 in
        let inc a p = a.(!p) := a.(!p) + 1 in
        let dec a p = a.(!p) := a.(!p) - 1 in
        let prt a p = print_char (char_of_int a.(!p)) in
        ( $t$ )
      >>
  ]];

  repr: [[
      t = term           -> t
    | t = term; u = repr -> <:expr< $t$; $u$ >>
  ]];

  term: [[
      ">"                -> <:expr< incr  p >>
    | "<"                -> <:expr< decr  p >>
    | "+"                -> <:expr< inc a p >>
    | "-"                -> <:expr< dec a p >>
    | "."                -> <:expr< prt a p >>
    | ","                -> <:expr< a.(!p) := input_byte stdin >>
    | "["; t = repr; "]" -> <:expr< while a.(!p) <> 0 do ( $t$ ) done >>
  ]];
END

let myparse  ?(directive_handler = fun _ -> None) _loc cs = BF.parse expr _loc cs
let myparse2 ?(directive_handler = fun _ -> None) _loc _  = <:sig_item< >>

let _ = Camlp4.Register.register_parser myparse myparse2;

(* lexer.mll *)
{
exception Eof
type instruction =
| PINCR of int | PDECR of int
| VINCR of int | VDECR of int
| OUTPUT | INPUT | FJUMP | BJUMP
}

rule token = parse
   | ('>' +) as s { PINCR (String.length s) }
   | ('<' +) as s { PDECR (String.length s) }
   | ('+' +) as s { VINCR (String.length s) }
   | ('-' +) as s { VDECR (String.length s) }
   | ('.' +)      { OUTPUT }
   | (',' +)      { INPUT }
   | ('[' +)      { FJUMP }
   | (']' +)      { BJUMP }
   | ['\n' '\r']  { token lexbuf }
   | eof          { raise Eof }

(* bf.ml *)
let runtime = "\
(* runtime *)
let p = ref 0
let buf_size = 256
let make_buf () = Array.make buf_size 0
let buf = ref (make_buf ())
let extend () = buf := Array.append !buf (make_buf ())
let pincr n = p := !p + n; if Array.length !buf >= !p then extend ()
let pdecr n = p := !p - n; if !p < 0 then failwith \"invalid pointer address!\"
type vtype = INCR | DECR
let vset v n = !buf.(!p) <- !buf.(!p) + (match v with INCR -> n | DECR -> -n)
let output () = print_char (char_of_int !buf.(!p))
let input () = !buf.(!p) <- int_of_char (input_char stdin)
(* end of runtime *)
"
let code_begin = "\
let () =
(* begin of code *)
"
let code_end = "\
(* end of code *)
()
"

open Lexer

let code_of_instruction token =
   let to_s = string_of_int in
   match token with
   | PINCR i -> "pincr " ^ (to_s i) ^ ";\n"
   | PDECR i -> "pdecr " ^ (to_s i) ^ ";\n"
   | VINCR i -> "vset INCR " ^ (to_s i) ^ ";\n"
   | VDECR i -> "vset DECR " ^ (to_s i) ^ ";\n"
   | OUTPUT  -> "output ();\n"
   | INPUT   -> "input ();\n"
   | FJUMP   -> "while !buf.(!p) <> 0 do\n"
   | BJUMP   -> "done;\n"

let translate str =
   let buf = Buffer.create ((String.length runtime) * 2) in
   let add = Buffer.add_string buf in
   let ()  = add runtime; add code_begin in
   let lexbuf = Lexing.from_string str in
   try
      while true do
         add (code_of_instruction (Lexer.token lexbuf))
      done;
      failwith "unreached"
   with Lexer.Eof ->
      add code_end;
      Buffer.contents buf

let main () =
   match Sys.argv with
   | [|_; fname |] -> begin
        let out_file_name =
           try (Filename.chop_extension fname) ^ ".ml"
           with _ -> fname ^ ".ml"
        in
        let in_ch = open_in fname in
        let buf = Buffer.create 10 in
        try
           while true do
              Buffer.add_string buf (input_line in_ch)
           done
        with End_of_file ->
           close_in in_ch;
           let code = translate (Buffer.contents buf) in
           let out_ch = open_out out_file_name in
           output_string out_ch code;
           close_out out_ch
     end
   | _ ->
        print_endline ("usage: " ^ Sys.argv.(0) ^ " BF_file")
let () = if not !Sys.interactive then main ()

type inst = Inc of int | Shift of int | Input | Output | Loop of inst list

let count_while c s =
  let rec loop m =
    match Stream.peek s with
      | Some c' when c = c' -> Stream.junk s; loop (m+1)
      | _ -> m
  in loop 1

let rec parse1 s =
  match Stream.next s with
    | '+' -> Inc (count_while '+' s)
    | '-' -> Inc (- (count_while '-' s))
    | '>' -> Shift (count_while '>' s)
    | '<' -> Shift (- (count_while '<' s))
    | '.' -> Output
    | ',' -> Input
    | '[' -> Loop (parseloop s [])
    | _   -> parse1 s
and parse s acc =
  try let i = parse1 s in parse s (i :: acc)
  with Stream.Failure -> List.rev acc
and parseloop s acc =
  if Stream.peek s = Some ']' then (Stream.junk s; List.rev acc)
  else parseloop s (parse1 s :: acc)

type state = { mutable ptr : int; array : int array; array_size : int; }

let rec trans1 i s =
  match i with
    | Inc n   -> .< (.~s).array.((.~s).ptr) <- (.~s).array.((.~s).ptr) + n >.
    | Shift n -> .< (.~s).ptr <- ((.~s).ptr + n) mod (.~s).array_size >.
    | Output  -> .< output_char stdout (Char.chr (.~s).array.((.~s).ptr)) >.
    | Input   -> .< (.~s).array.((.~s).ptr) <- Char.code (input_char stdin) >.
    | Loop is ->
        .< while (.~s).array.((.~s).ptr) <> 0 do .~(trans is s) done >.
and trans insts s =
  let f i code = .< let _ = .~(trans1 i s) in .~code >.
  in List.fold_right f insts .<()>.

let make_state n = { ptr = 0; array = Array.create n 0; array_size = n; }
let compile str =
  .<fun s -> .~(trans (parse (Stream.of_string str) []) .<s>.)>.
let execute str = (.! compile str) (make_state 100)