nand2tetris/compiler/lib/be_translate.ml

open Base
open Be_ast
open Be_predef

let parse s =
  let lexbuf = Lexing.from_string s in
  let ast = Be_parser.prog Be_lexer.read lexbuf in
  ast
;;

let generate_exprs lines = List.map lines ~f:parse

let a_command loc a =
  let suffix = Int.to_string loc in
  match a with
  | "add" -> _add
  | "sub" -> _sub
  | "neg" -> _neg
  | "eq" -> _eq suffix
  | "gt" -> _gt suffix
  | "lt" -> _lt suffix
  | "and" -> _and
  | "or" -> _or
  | "not" -> _not
  | _ -> failwith "a_command: Invalid Command"
;;

let process_push cn sp a =
  match sp with
  | "local" | "argument" | "this" | "that" -> push_common a sp
  | "constant" -> push_constant a
  | "temp" -> push_temp a
  | "static" -> push_static a cn
  | "pointer" -> push_pointer a
  | _ -> failwith "PROCESS PUSH: Invalid Segment"
;;

let process_pop cn sp a =
  match sp with
  | "local" | "argument" | "this" | "that" -> pop_common a sp
  | "temp" -> pop_temp a
  | "static" -> pop_static a cn
  | "pointer" -> pop_pointer a
  | _ -> failwith "PROCESS POP: Invalid Segment"
;;

let m_command cn (c, s, a) =
  match c with
  | "pop" -> process_pop cn s a
  | "push" -> process_push cn s a
  | _ -> failwith "m_command: Invalid Command"
;;

let rec _translate expr cn loc tt =
  match expr with
  | [] -> tt
  | Acommand a :: t -> a_command loc a @ _translate t cn (loc + 1) tt
  | Mcommand (c, s, a) :: t -> m_command cn (c, s, a) @ _translate t cn loc tt
  | _ :: t -> _translate t cn loc tt
;;

let translate cn lines =
  let exprs = generate_exprs lines in
  _translate exprs cn 0 [] @ _end
;;