nand2tetris/compiler/lib/be_predef.ml

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" ]