finish project eight backend compiler

- modify existing implementation to use variant types for a more
  accurate representation of the vm byte code
- switch to fold from recursion for the main translate function
- use separate modules for translating different vm commands
- move static arithmetic command translations to a map

compiler/backend/.ocamlformat

@@ -1,2 +1,2 @@
 profile = janestreet
-version = 0.24.1
+version = 0.26.2

compiler/backend/bin/compiler.ml

@@ -0,0 +1,61 @@
+open Core
+open Backend
+
+let read_file file =
+  let lines = In_channel.read_lines file in
+  let not_empty str = not (String.is_empty str) in
+  List.filter lines ~f:not_empty
+
+
+let is_vm_file f =
+  match Filename.split_extension f with
+  | _, Some ext -> String.equal ext "vm"
+  | _, None -> false
+
+
+let generate_hack f =
+  let bytecode = read_file f in
+  let class_name = Filename.basename f in
+  Translate.translate class_name bytecode
+
+
+let write_hack path hack =
+  let output_channel = Out_channel.create path in
+  Out_channel.output_lines output_channel hack;
+  Out_channel.close output_channel
+
+
+let compile path =
+  let ext = ".asm" in
+  let absolute_path x = path ^ x in
+  let open Filename_base in
+    if Sys_unix.is_directory_exn path then
+      let output_file = concat path (basename path ^ ext) in
+      let hack =
+        path
+        |> Sys_unix.ls_dir
+        |> List.map ~f:absolute_path
+        |> List.filter ~f:is_vm_file
+        |> List.concat_map ~f:generate_hack
+        |> List.append Translate.bootstrap
+      in
+      write_hack output_file hack
+    else if Sys_unix.is_file_exn path && is_vm_file path then
+      let output_file = chop_extension path ^ ext in
+      let hack = generate_hack path in
+      write_hack output_file hack
+    else
+      failwith "Incompatible!"
+
+
+let command =
+  let summary = "Translate Jack byte code to Hack assembly" in
+  let readme () = "Compiler (backend) for project 7/8 of Nand2Tetris" in
+  let param_spec = Command.Param.(anon ("path" %: string)) in
+  let param_handler path () = compile path in
+  Command.basic
+    ~summary:summary ~readme:readme
+    (Command.Param.map param_spec ~f:param_handler)
+
+
+let () = Command_unix.run command

compiler/backend/bin/compiler.mli

@@ -0,0 +1 @@
+val command : Command.t

compiler/backend/bin/dune

@@ -1,3 +1,5 @@
 (executable
+ (modes byte exe)
  (name compiler)
+ (public_name compiler)
  (libraries backend core core_unix.command_unix))

compiler/backend/dune-project

@@ -0,0 +1,2 @@
+(lang dune 3.13)
+(using menhir 3.0)

compiler/backend/lib/arithmetic.ml

@@ -0,0 +1,78 @@
+open! Ast
+open! Base
+
+let counter = ref 0
+
+let count =
+  fun () ->
+    counter := (!counter) + 1;
+    !counter
+
+
+let arithmetic =
+  Map.of_alist_exn (module String)
+    [ "add", [ "@SP"; "AM=M-1"; "D=M"; "A=A-1"; "M=D+M" ]
+    ; "sub", [ "@SP"; "AM=M-1"; "D=M"; "A=A-1"; "M=M-D" ]
+    ; "and", [ "@SP"; "AM=M-1"; "D=M"; "A=A-1"; "M=D&M" ]
+    ; "or" , [ "@SP"; "AM=M-1"; "D=M"; "A=A-1"; "M=D|M" ]
+    ; "neg", [ "@SP"; "A=M-1"; "M=-M" ]
+    ; "not", [ "@SP"; "A=M-1"; "M=!M" ]
+    ]
+
+let eq count =
+  [ "@SP"
+    ; "AM=M-1"
+    ; "D=M"
+    ; "A=A-1"
+    ; "D=M-D"
+    ; "M=-1"
+    ; "@END_EQ_" ^ count
+    ; "D;JEQ"
+    ; "@SP"
+    ; "A=M-1"
+    ; "M=0"
+    ; "(END_EQ_" ^ count ^ ")"
+  ]
+
+let gt count =
+  [ "@SP"
+    ; "AM=M-1"
+    ; "D=M"
+    ; "A=A-1"
+    ; "D=M-D"
+    ; "M=-1"
+    ; "@END_GT_" ^ count
+    ; "D;JGT"
+    ; "@SP"
+    ; "A=M-1"
+    ; "M=0"
+    ; "(END_GT_" ^ count ^ ")"
+  ]
+
+let lt count =
+  [ "@SP"
+    ; "AM=M-1"
+    ; "D=M"
+    ; "A=A-1"
+    ; "D=M-D"
+    ; "M=-1"
+    ; "@END_LT_" ^ count
+    ; "D;JLT"
+    ; "@SP"
+    ; "A=M-1"
+    ; "M=0"
+    ; "(END_LT_" ^ count ^ ")"
+  ]
+
+let translate command =
+  let i = Int.to_string (count ()) in
+  match command with
+  | Add -> Map.find_exn arithmetic "add"
+  | Sub -> Map.find_exn arithmetic "sub"
+  | Neg -> Map.find_exn arithmetic "neg"
+  | And -> Map.find_exn arithmetic "and"
+  | Not -> Map.find_exn arithmetic "not"
+  | Or  -> Map.find_exn arithmetic "or"
+  | Eq  -> eq i
+  | Gt  -> gt i
+  | Lt  -> lt i

compiler/backend/lib/arithmetic.mli

@@ -0,0 +1 @@
+val translate : Ast.arithmetic_command -> string list

compiler/backend/lib/ast.ml

@@ -0,0 +1,41 @@
+type arithmetic_command =
+  | Add
+  | Sub
+  | Neg
+  | Eq
+  | Gt
+  | Lt
+  | And
+  | Or
+  | Not
+
+type memory_segment =
+  | Argument
+  | Local
+  | Static
+  | Constant
+  | This
+  | That
+  | Pointer
+  | Temp
+
+type memory_command =
+  | Push
+  | Pop
+
+type branching_command =
+  | Label
+  | Goto
+  | Ifgoto
+
+type function_command =
+  | Function
+  | Call
+
+type expr =
+  | Comment of string
+  | ArithmeticCommand of arithmetic_command
+  | MemoryAccessCommand of memory_command * memory_segment * int
+  | ProgramFlowCommand of branching_command * string
+  | FunctionCallCommand of function_command * string * int
+  | Return

compiler/backend/lib/dune

@@ -0,0 +1,8 @@
+(ocamllex lexer)
+
+(menhir
+ (modules parser))
+
+(library
+ (name backend)
+ (libraries core))

compiler/backend/lib/functioncall.ml

@@ -0,0 +1,95 @@
+open! Ast
+open! Base
+
+let counter = ref 0
+
+let count =
+  fun () ->
+    counter := (!counter) + 1;
+    !counter
+
+let addr a = "@" ^ a
+
+let label name = "(" ^ name ^ ")"      
+
+let function_definition name arg =
+  let push_inner n = [
+    addr n
+    ; "D=A"
+    ; "@LCL"
+    ; "A=D+M"
+    ; "M=0"
+    ; "@SP"
+    ; "M=M+1"
+    ] in
+  let locals = arg
+    |> List.init ~f:Int.to_string
+    |> List.concat_map ~f:push_inner in
+  List.append [ label name ] locals
+
+let function_call name arg =
+  let i = Int.to_string (count ()) in
+  let arg = Int.to_string arg in
+  let ret = name ^ "_RETURN_" ^ i in
+  [ addr ret
+  ; "D=A"
+  ; "@SP"
+  ; "A=M"
+  ; "M=D"
+  ; "@SP"
+  ; "M=M+1"
+  ; "// push LCL "
+  ; "@LCL"
+  ; "D=M"
+  ; "@SP"
+  ; "A=M"
+  ; "M=D"
+  ; "@SP"
+  ; "M=M+1"
+  ; "// push ARG "
+  ; "@ARG"
+  ; "D=M"
+  ; "@SP"
+  ; "A=M"
+  ; "M=D"
+  ; "@SP"
+  ; "M=M+1"
+  ; "// push THIS "
+  ; "@THIS"
+  ; "D=M"
+  ; "@SP"
+  ; "A=M"
+  ; "M=D"
+  ; "@SP"
+  ; "M=M+1"
+  ; "// push THAT "
+  ; "@THAT"
+  ; "D=M"
+  ; "@SP"
+  ; "A=M"
+  ; "M=D"
+  ; "@SP"
+  ; "M=M+1"
+  ; "// reposition ARG"
+  ; "D=M"
+  ; addr arg
+  ; "D=D-A"
+  ; "@5"
+  ; "D=D-A"
+  ; "@ARG"
+  ; "M=D"
+  ; "// reposition LCL"
+  ; "@SP"
+  ; "D=M"
+  ; "@LCL"
+  ; "M=D"
+  ; "// goto function"
+  ; addr name
+  ; "0;JMP"
+  ; label ret ]
+
+let translate command name arg =
+  match command with
+  | Function -> function_definition name arg
+  | Call -> function_call name arg
+  

compiler/backend/lib/functioncall.mli

@@ -0,0 +1 @@
+val translate : Ast.function_command -> string -> int -> string list

compiler/backend/lib/lexer.mll

@@ -0,0 +1,49 @@
+{
+open Parser
+}
+
+let period     = '.'
+let colon      = ':'
+let underscore = '_'
+let numbers    = ['0'-'9']+
+let alphabets  = ['a'-'z' 'A'-'Z']+
+let white      = [' ' '\t']+
+let comment    = "//" _*
+
+
+let address    = (numbers)+
+let id         = (alphabets | numbers | colon | period | underscore)+
+
+rule read =
+  parse
+  | white          { read lexbuf }
+  | comment as c   { COMMENT (c) }
+  | "add"          { ADD } 
+  | "sub"          { SUB }
+  | "neg"          { NEG }
+  | "eq"           { EQ }
+  | "gt"           { GT }
+  | "lt"           { LT }
+  | "and"          { AND }
+  | "or"           { OR }
+  | "not"          { NOT }
+  | "pop"          { POP }
+  | "push"         { PUSH }  
+  | "argument"     { ARGUMENT }  
+  | "local"        { LOCAL }  
+  | "static"       { STATIC }  
+  | "this"         { THIS }  
+  | "that"         { THAT }  
+  | "pointer"      { POINTER }  
+  | "temp"         { TEMP }  
+  | "constant"     { CONSTANT }  
+  | "label"        { LABEL }
+  | "goto"         { GOTO }
+  | "if-goto"      { IFGOTO }
+  | "function"     { FUNCTION }
+  | "call"         { CALL }
+  | "return"       { RETURN }
+  | address as a   { ADDRESS (int_of_string a) }
+  | id as i        { ID (i) }
+  | eof            { EOF }
+  | _ as c         { failwith (Printf.sprintf "unexpected character: %C" c) }

compiler/backend/lib/memoryaccess.ml

@@ -0,0 +1,68 @@
+open! Ast
+open! Base
+
+let addr a = "@" ^ a
+
+let push = [ "@SP"; "A=M"; "M=D"; "@SP"; "M=M+1" ]
+let pop = [ "@R13"; "M=D"; "@SP"; "AM=M-1"; "D=M"; "@R13"; "A=M"; "M=D" ]
+
+let common = function
+  | Local -> "@LCL"
+  | This -> "@THIS"
+  | That -> "@THAT"
+  | Argument -> "@ARG"
+  | _ -> failwith "Invalid Segment"
+
+let pointer = function
+  | "0" -> "@THIS"
+  | "1" -> "@THAT"
+  | _ -> failwith "Invalid Pointer"
+
+let push_constant a = [ addr a; "D=A" ] @ push
+
+let push_pointer a = [ pointer a; "D=M" ] @ push
+
+let push_static offset class_name=
+  [ addr (class_name ^ ":" ^ offset); "D=M" ] @ push
+
+let push_temp a = [ addr a; "D=A"; "@5"; "A=D+A"; "D=M" ] @ push
+
+let pop_pointer a =
+  [ "@SP"; "AM=M-1"; "D=M"; pointer a; "M=D" ]
+
+let pop_static offset class_name =
+  [ "@SP"; "AM=M-1"; "D=M"; addr (class_name ^ ":" ^ offset); "M=D" ]
+
+let push_common segment offset =
+  [ addr offset ; "D=A" ; common segment ; "A=D+M" ; "D=M" ] @ push
+
+let pop_temp a =
+[ addr a; "D=A"; "@5" ; "D=D+A" ] @ pop
+
+let pop_common segment offset = [
+  addr offset
+  ; "D=A"
+  ; common segment
+  ; "D=D+M" ] @ pop
+
+let process_push segment offset class_name =
+  match segment with
+  | Local | Argument | This | That -> push_common segment offset
+  | Constant -> push_constant offset
+  | Temp -> push_temp offset
+  | Static -> push_static class_name offset
+  | Pointer -> push_pointer offset
+
+let process_pop segment offset class_name =
+  match segment with
+  | Local | Argument | This | That -> pop_common segment offset
+  | Temp -> pop_temp offset
+  | Static -> pop_static class_name offset
+  | Pointer -> pop_pointer offset
+  | Constant -> failwith "Invalid Segment"
+
+let translate command segment offset class_name =
+  let offset = Int.to_string offset in
+    match command with
+    | Pop -> process_pop segment offset class_name
+    | Push -> process_push segment offset class_name

compiler/backend/lib/memoryaccess.mli

@@ -0,0 +1,3 @@
+val translate :
+    Ast.memory_command ->
+    Ast.memory_segment -> int -> string -> string list

compiler/backend/lib/parser.mly

@@ -0,0 +1,93 @@
+%{
+open Ast
+%}
+
+
+(* arithmetic and logical commands *)
+%token ADD SUB EQ GT LT AND OR NEG NOT
+
+(* memory commands *)
+%token POP PUSH
+
+(* memory segments *)
+%token CONSTANT STATIC POINTER TEMP
+       ARGUMENT LOCAL THIS THAT
+
+(* branching commands *)
+%token LABEL GOTO IFGOTO
+
+(* function commands*)
+%token FUNCTION CALL RETURN
+
+%token <int> ADDRESS
+%token <string> ID
+%token <string> COMMENT
+%token EOF
+
+%start <Ast.expr> prog
+
+%%
+
+
+prog:
+  | e = expr; EOF                            { e }
+  ;
+
+expr:
+  | c = COMMENT                              { Comment c }
+  | e = arithmetic                           { e }
+  | POP; p = pop                             { p }
+  | PUSH; p = push                           { p }
+  | b = branching                            { b }
+  | FUNCTION; f = function_definition        { f }
+  | CALL; c = function_call                  { c }
+  | RETURN                                   { Return }
+  | e = expr; COMMENT                        { e }
+;
+
+arithmetic:
+  | ADD                             { ArithmeticCommand Add }
+  | SUB                             { ArithmeticCommand Sub }
+  | EQ                              { ArithmeticCommand Eq }
+  | GT                              { ArithmeticCommand Gt }
+  | LT                              { ArithmeticCommand Lt }
+  | AND                             { ArithmeticCommand And }
+  | OR                              { ArithmeticCommand Or }
+  | NEG                             { ArithmeticCommand Neg }
+  | NOT                             { ArithmeticCommand Not }
+;
+
+pop:
+  | ARGUMENT; a = ADDRESS           { MemoryAccessCommand (Pop, Argument, a) }
+  | LOCAL; a = ADDRESS              { MemoryAccessCommand (Pop, Local, a) }
+  | STATIC; a = ADDRESS             { MemoryAccessCommand (Pop, Static, a) }
+  | THIS; a = ADDRESS               { MemoryAccessCommand (Pop, This, a) }
+  | THAT; a = ADDRESS               { MemoryAccessCommand (Pop, That, a) }
+  | POINTER; a = ADDRESS            { MemoryAccessCommand (Pop, Pointer, a) }
+  | TEMP; a = ADDRESS               { MemoryAccessCommand (Pop, Temp, a) }
+;
+
+push:
+  | ARGUMENT; a = ADDRESS           { MemoryAccessCommand (Push, Argument, a) }
+  | LOCAL; a = ADDRESS              { MemoryAccessCommand (Push, Local, a) }
+  | STATIC; a = ADDRESS             { MemoryAccessCommand (Push, Static, a) }
+  | THIS; a = ADDRESS               { MemoryAccessCommand (Push, This, a) }
+  | THAT; a = ADDRESS               { MemoryAccessCommand (Push, That, a) }
+  | POINTER; a = ADDRESS            { MemoryAccessCommand (Push, Pointer, a) }
+  | TEMP; a = ADDRESS               { MemoryAccessCommand (Push, Temp, a) }
+  | CONSTANT; a = ADDRESS           { MemoryAccessCommand (Push, Constant, a) }
+;
+
+branching:
+  | LABEL; i = ID                   { ProgramFlowCommand (Label, i) }
+  | GOTO; i = ID                    { ProgramFlowCommand (Goto, i) }
+  | IFGOTO; i = ID                  { ProgramFlowCommand (Ifgoto, i) }
+;
+
+function_definition:
+  | i = ID; a = ADDRESS             { FunctionCallCommand (Function, i, a) }
+;
+
+function_call:
+  | i = ID; a = ADDRESS             { FunctionCallCommand (Call, i, a) }
+;

compiler/backend/lib/programflow.ml

@@ -0,0 +1,12 @@
+open! Ast
+open! Base
+
+let addr a = "@" ^ a
+
+let label name = "(" ^ name ^ ")"
+
+let translate command name =
+  match command with
+  | Label -> [ label name ]
+  | Goto -> [ addr name; "0;JMP" ]
+  | Ifgoto -> [ "@SP"; "AM=M-1"; "D=M"; addr name; "D;JNE" ]

compiler/backend/lib/programflow.mli

@@ -0,0 +1 @@
+val translate : Ast.branching_command -> string -> string list

compiler/backend/lib/return.ml

@@ -0,0 +1,47 @@
+let translate =
+  [ "// Save LCL to R14, Return Address to R15 "
+  ; "@LCL"
+  ; "D=M"
+  ; "@R14"
+  ; "M=D"
+  ; "@R5"
+  ; "A=D-A"
+  ; "D=M"
+  ; "@R15"
+  ; "M=D"
+  ; "// POP return value to ARG0, SP=ARG+1 "
+  ; "@SP"
+  ; "AM=M-1"
+  ; "D=M"
+  ; "@ARG"
+  ; "A=M"
+  ; "M=D"
+  ; "D=A"
+  ; "@SP"
+  ; "M=D+1"
+  ; "// reposition THAT, THIS, ARG, LCL "
+  ; "@R14"
+  ; "AM=M-1"
+  ; "D=M"
+  ; "@THAT"
+  ; "M=D"
+  ; "@R14"
+  ; "AM=M-1"
+  ; "D=M"
+  ; "@THIS"
+  ; "M=D"
+  ; "@R14"
+  ; "AM=M-1"
+  ; "D=M"
+  ; "@ARG"
+  ; "M=D"
+  ; "@R14"
+  ; "AM=M-1"
+  ; "D=M"
+  ; "@LCL"
+  ; "M=D"
+  ; "// Jump to Return Address "
+  ; "@R15"
+  ; "A=M"
+  ; "0;JMP"
+  ]

compiler/backend/lib/return.mli

@@ -0,0 +1 @@
+val translate : string list

compiler/backend/lib/translate.ml

@@ -0,0 +1,27 @@
+open! Ast
+open! Base
+
+let parse str =
+  let lexbuf = Lexing.from_string str in
+  Parser.prog Lexer.read lexbuf
+
+let bootstrap =
+  [ "@256"; "D=A"; "@SP"; "M=D" ]
+  @ Functioncall.translate Call "Sys.init" 0
+
+let translate class_name lines : string list =
+  lines
+  |> List.map ~f:parse
+  |> List.bind ~f:(function
+      | ArithmeticCommand a
+        -> Arithmetic.translate a
+      | MemoryAccessCommand (command, segment, offset)
+        -> Memoryaccess.translate command segment offset class_name
+      | ProgramFlowCommand (command, name)
+        -> Programflow.translate command name
+      | FunctionCallCommand (command, name, arg)
+        -> Functioncall.translate command name arg
+      | Return
+        -> Return.translate
+      | Comment _ -> []
+    )

compiler/backend/lib/translate.mli

@@ -0,0 +1,10 @@
+open Ast
+
+(* Parse a string to the Ast.expr type. *)
+val parse : string -> expr
+
+(* Set the Stack Pointer to 256 and call Sys.init function. *)
+val bootstrap : string list
+
+(* Translate from parsed byte code [Ast.expr] to assembly *)
+val translate : string -> string list -> string list

compiler/backend/test/test_backend.ml

@@ -0,0 +1,31 @@
+open OUnit2
+open Backend.Ast
+open Backend.Translate
+
+let peq case value = assert_equal value (parse case)
+
+let test_parse_a_command _ =
+  peq "add" (ArithmeticCommand Add);
+  peq "sub" (ArithmeticCommand Sub);
+  peq "neg" (ArithmeticCommand Neg);
+  peq "eq" (ArithmeticCommand Eq);
+  peq "gt" (ArithmeticCommand Gt);
+  peq "lt" (ArithmeticCommand Lt);
+  peq "and" (ArithmeticCommand And);
+  peq "or" (ArithmeticCommand Or);
+  peq "not" (ArithmeticCommand Not)
+;;
+
+let test_parse_m_command _ =
+  peq "pop local 12" (MemoryAccessCommand (Pop, Local, 12));
+  peq "push argument 4" (MemoryAccessCommand (Push, Argument, 4))
+;;
+
+let suite =
+  "suite"
+  >::: [ "A Instruction" >:: test_parse_a_command
+       ; "M Instruction" >:: test_parse_m_command
+       ]
+;;
+
+let () = run_test_tt_main suite

compiler/bin/compiler.ml

@@ -1,32 +0,0 @@
-open Core
-open Backend
-
-let read_file file =
-  let not_empty str = not (String.is_empty str) in
-  List.filter (In_channel.read_lines file) ~f:not_empty
-;;
-
-let classname file = Filename.chop_extension (Filename.basename file)
-let outfile file = String.concat [ Filename.chop_extension file; ".asm" ]
-
-let gen_hack file =
-  let ircode = read_file file in
-  let assembly = Be_translate.translate (classname file) ircode in
-  let outchan = Out_channel.create (outfile file) in
-  Out_channel.output_lines outchan assembly;
-  Out_channel.close outchan
-;;
-
-let param =
-  let open Command.Param in
-  anon ("filename" %: string)
-;;
-
-let command =
-  Command.basic
-    ~summary:"Translate <filename>.vm to <filename>.asm"
-    ~readme:(fun () -> "Compiler (backend) for project 7 of Nand2Tetris")
-    (Command.Param.map param ~f:(fun filename () -> gen_hack filename))
-;;
-
-let () = Command_unix.run command

compiler/dune-project

@@ -1,2 +0,0 @@
-(lang dune 3.3)
-(using menhir 2.0)

compiler/lib/be_ast.ml

@@ -1,4 +0,0 @@
-type expr =
-  | Comment of string
-  | Acommand of string
-  | Mcommand of string * string * string

compiler/lib/be_lexer.mll

@@ -1,57 +0,0 @@
-{
-open Be_parser
-}
-
-let address   = ['0'-'9']+
-
-(* let ADD       = "add"
-let SUB       = "sub"
-let NEG       = "neg"
-let EQ        = "eq"
-let GT        = "gt"
-let LT        = "lt"
-let AND       = "and"
-let OR        = "or"
-let NOT       = "not"
-let POP       = "pop"
-let PUSH      = "push" *)
-
-let command   = "add"
-              | "sub"
-              | "neg"
-              | "eq"
-              | "gt"
-              | "lt"
-              | "and"
-              | "or"
-              | "not"
-              | "pop"
-              | "push"
-
-let segment   = "argument"
-              | "local"
-              | "static"
-              | "this"
-              | "that"
-              | "pointer"
-              | "temp"
-              | "constant"
-
-let white     = [' ' '\t']+
-let comment   = "//" _*
-
-(* 
-let digit      = ['0'-'9']
-let letter     = ['a'-'z' 'A'-'Z']
-let special    = ['.' '$' '_' '-' '+' '&' '!' '|']
-let id         = (digit | letter | special)+ 
-*)
-
-rule read =
-  parse
-  | white          { read lexbuf }
-  | address as a   { ADDRESS (a) }
-  | command as c   { COMMAND (c) }
-  | segment as s   { SEGMENT (s) }
-  | comment as c   { COMMENT (c) }
-  | eof            { EOF }

compiler/lib/be_parser.mly

@@ -1,24 +0,0 @@
-%{
-open Be_ast
-%}
-
-%token <string> ADDRESS
-%token <string> COMMAND
-%token <string> SEGMENT 
-%token <string> COMMENT
-%token EOF
-
-%start <Be_ast.expr> prog
-
-%%
-
-prog:
-  | e = expr; EOF { e }
-  ;
-
-expr:
-  | c = COMMENT                              { Comment c }
-  | c = COMMAND;                             { Acommand c }
-  | c = COMMAND; s = SEGMENT; a = ADDRESS    { Mcommand (c, s, a) }
-  | e = expr; COMMENT                        { e }
-  ;

compiler/lib/be_predef.ml

@@ -1,77 +0,0 @@
-open Base
-
-let _unary = [ "@SP"; "A=M-1" ]
-let _binary = [ "@SP"; "AM=M-1"; "D=M"; "A=A-1" ]
-let _add = _binary @ [ "M=M+D" ]
-let _sub = _binary @ [ "M=M-D" ]
-let _neg = _unary @ [ "M=-M" ]
-let _and = _binary @ [ "M=D&M" ]
-let _or = _binary @ [ "M=D|M" ]
-let _not = _unary @ [ "M=!M" ]
-
-let _eq loc =
-  _binary
-  @ [ "D=M-D"
-    ; "M=-1"
-    ; "@END_EQ_" ^ loc
-    ; "D;JEQ"
-    ; "@SP"
-    ; "A=M-1"
-    ; "M=0"
-    ; "(END_EQ_" ^ loc ^ ")"
-    ]
-;;
-
-let _gt loc =
-  _binary
-  @ [ "D=M-D"
-    ; "M=-1"
-    ; "@END_GT_" ^ loc
-    ; "D;JGT"
-    ; "@SP"
-    ; "A=M-1"
-    ; "M=0"
-    ; "(END_GT_" ^ loc ^ ")"
-    ]
-;;
-
-let _lt loc =
-  _binary
-  @ [ "D=M-D"
-    ; "M=-1"
-    ; "@END_LT_" ^ loc
-    ; "D;JLT"
-    ; "@SP"
-    ; "A=M-1"
-    ; "M=0"
-    ; "(END_LT_" ^ loc ^ ")"
-    ]
-;;
-
-let push = [ "@SP"; "A=M"; "M=D"; "@SP"; "M=M+1" ]
-let pop = [ "@R13"; "M=D"; "@SP"; "AM=M-1"; "D=M"; "@R13"; "A=M"; "M=D" ]
-
-let s_pointer = function
-  | "0" -> "@THIS"
-  | "1" -> "@THAT"
-  | _ -> failwith "Invalid Pointer"
-;;
-
-let s_common = function
-  | "local" -> "@LCL"
-  | "this" -> "@THIS"
-  | "that" -> "@THAT"
-  | "argument" -> "@ARG"
-  | _ -> failwith "Invalid Segment"
-;;
-
-let push_constant a = [ "@" ^ a; "D=A" ] @ push
-let push_common a sp = [ "@" ^ a; "D=A"; s_common sp; "A=D+M"; "D=M" ] @ push
-let push_temp a = [ "@" ^ a; "D=A"; "@R5"; "A=D+A"; "D=M" ] @ push
-let push_pointer a = [ s_pointer a; "D=M" ] @ push
-let push_static a cn = [ "@" ^ cn ^ "." ^ a; "D=M" ] @ push
-let pop_common a sp = [ "@" ^ a; "D=A"; s_common sp; "D=D+M" ] @ pop
-let pop_temp a = [ "@" ^ a; "D=A"; "@R5"; "D=D+A" ] @ pop
-let pop_pointer a = [ "@SP"; "AM=M-1"; "D=M"; s_pointer a; "M=D" ]
-let pop_static a cn = [ "@SP"; "AM=M-1"; "D=M"; "@" ^ cn ^ "." ^ a; "M=D" ]
-let _end = [ "(TERMINATE)"; "@TERMINATE"; "0;JMP" ]

compiler/lib/be_translate.ml

@@ -1,65 +0,0 @@
-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
-;;

compiler/lib/dune

@@ -1,9 +0,0 @@
-(ocamllex be_lexer)
-
-(menhir
- (modules be_parser))
-
-(library
- (name backend)
- (modules be_ast be_predef be_translate be_lexer be_parser)
- (libraries base))

compiler/test/test_backend.ml

@@ -1,31 +0,0 @@
-open OUnit2
-open Backend.Be_ast
-open Backend.Be_translate
-
-let peq case value = assert_equal value (parse case)
-
-let test_parse_a_command _ =
-  peq "add" (Acommand "add");
-  peq "sub" (Acommand "sub");
-  peq "neg" (Acommand "neg");
-  peq "eq" (Acommand "eq");
-  peq "gt" (Acommand "gt");
-  peq "lt" (Acommand "lt");
-  peq "and" (Acommand "and");
-  peq "or" (Acommand "or");
-  peq "not" (Acommand "not")
-;;
-
-let test_parse_m_command _ =
-  peq "pop local 12" (Mcommand ("pop", "local", "12"));
-  peq "push argument 4" (Mcommand ("push", "argument", "4"))
-;;
-
-let suite =
-  "suite"
-  >::: [ "A Instruction" >:: test_parse_a_command
-       ; "M Instruction" >:: test_parse_m_command
-       ]
-;;
-
-let () = run_test_tt_main suite