BF-Interpreter

use "M.sml";

fun writeHeap xs = let
        fun wH nil p = p
          | wH (x::xr) p = wH xr (con x::p)
    in
         wH xs [new (length xs)]
    end

fun bf #"<" = 0
  | bf #">" = 1
  | bf #"+" = 2
  | bf #"-" = 3
  | bf #"[" = 4
  | bf #"]" = 5
  | bf #"!" = 7
  | bf _ = 6
val bfToInt = (map bf) o explode

val init = writeHeap (bfToInt "+++++!") (* 5 *)
val init = writeHeap (bfToInt "->-->--->>>!") (* ~1 ~2 ~3 *)
val init = writeHeap (bfToInt "++-+++---!") (* 1 *)
val init = writeHeap (bfToInt "+>++++>+++<+<+!") (* 2 5 3 *)
val init = writeHeap (bfToInt "++>[+++]++<++!") (* 4 2 *)
val init = writeHeap (bfToInt "+[++++]++!") (* divergence *)
val init = writeHeap (bfToInt "+[>+++<-]++>++!") (* 2 5 *)
val init = writeHeap (bfToInt "+++[>+>+<<-]!") (* 0 3 3 *)
val init = writeHeap (bfToInt "+++>++<[->[>+>+<<-]>>[-<<+>>]<<<]!") (* 0 2 6 *)
(*
++>++<[->
    [>+>+<<-]
    >>[-<<+>>]
    <<<
]
*)

val pc  = 0
val mem = 1
val cmd = 2
val interpret = [
label("goRight"), procS(0,"goRightEnd"),
getS pc, con 1, add, putS pc,                      (* inc pc *)
con 5, getS pc, getH 0, leq, cbranchS "gRelse",
getS pc, getH 0, con 5, leq, cbranchS "gRelse2",
con 0, return,                                     (*bei ]*)
label "gRelse2",                                   (* test auf [ *)
getS pc, getH 0, con 4, leq, cbranchS "gRelse",
callS "goRight",                                   (* noch ein [ *)
label "gRelse", callRS "goRight",
con 0, return, label("goRightEnd"),

label("goLeft"), procS(0,"goLeftEnd"),
con 1, getS pc, sub, putS pc,                      (* dec pc *)
getS pc, getH 0, con 4, leq, cbranchS "gLelse",
con 4, getS pc, getH 0, leq, cbranchS "gLelse2",
con 0, return,                                     (*bei [*)
label "gLelse2",                                   (* test auf ] *)
con 5, getS pc, getH 0, leq, cbranchS "gLelse",
callS "goLeft",                                    (* noch ein [ *)
label "gLelse", callRS "goLeft",
con 0, return, label("goLeftEnd"),

(* STACK 0 program counter *)                      (* var pc *)
con ~1, con 0, con 0, new 3,                       (* STACK 1 memory queue+list *) (* var mem:=H(3) *)
getS mem, getS mem, putH 0,
getS pc,                                           (* copy pc *)
getH 0, (* STACK 3 *)                              (* var x:= getCMD *)
label("while"), con 6, getS cmd, leq, cbranchS "end", (* while x<=6 *)
label("<"), con 0, getS cmd, leq, cbranchS "n<",   (* if x<=0 *)
getS mem, getH 0, putS mem,                        (* go Left *)
branchS "after",
label("n<"), con 1, getS cmd, leq, cbranchS "n>",  (* elif x<=1 *)
getS mem, getH 2, (* stack 3 *)                    (* getNextAddress *)
con ~1, getS 3, leq, cbranchS "goahead",           (* if a<=~1 *)
con ~1, con 0, con 0, new 3, (* stack 4 *)         (* createNewMemoryCell *)
getS 4, getS mem, putH 2, putS 3,
 getS mem, getS 3, putH 0,                         (* override prev reference *)
                                                   (* next mem is in 3, ss=0-3 *)
label "goahead", putS mem,                         (* ss=0-2 *)
branchS "after",
label("n>"), con 2, getS cmd, leq, cbranchS "n+",  (* elif x<=2 *)
getS mem, getH 1, con 1, add, getS mem, putH 1,    (* increase memory cell *)
branchS "after",
label("n+"), con 3, getS cmd, leq, cbranchS "n-",  (* elif x<=3 *)
con 1, getS mem, getH 1, sub, getS mem, putH 1,    (* decrease memory cell *)
branchS "after",
label("n-"), con 4, getS cmd, leq, cbranchS "n[",  (* elif x<=4 *)
getS mem, getH 1, con 0, leq, cbranchS "saveW",    (* if memory content=0 *)
con 0, getS mem, getH 1, leq, cbranchS "saveW",
callS "goRight", add, branchS "after",             (* move to ] *)
label("saveW"),
branchS "after",
label("n["), con 5, getS cmd, leq, cbranchS "n]",  (* elif x<=5 *)
callS "goLeft", add, branchS "getCMD",             (* move to [ *)
label("n]"),label("after"),
getS pc, con 1, add, putS pc,                      (* increase pc *)
label("getCMD"),getS cmd, sub, add, (* ss=0-2 *)   (* remove cmd from stack *)
getS pc, getH 0, branchS "while",                  (* get next command *)
label("end")
]

val cleanUp = [
con 0, putS pc,
label("goHeapLeft"), getS mem, getH 0, getS (cmd+1), getS mem, leq, cbranchS "notFoundBorder",
branchS "foundLeftBorder",
label("notFoundBorder"),
putS mem,branchS "goHeapLeft",
label("foundLeftBorder"), getS (cmd+1), sub, add,
label("writeGoRight"),
getS mem, getH 1, getS pc, putH 0,
getS pc, con 1, add, putS pc,
getS mem, getH 2, getS (cmd+1), con 0, leq, cbranchS "foundEnd",
putS mem, branchS "writeGoRight",
label("foundEnd")
]
val prog = init@interpret@cleanUp

;(load o preProcess) (prog@[halt]);