# --------------------------------------------------------------------------- #

# assembler.icn

# a collection of procedures to aid in generating kcode assembly language

# --------------------------------------------------------------------------- #

global  IA,IB,IC,ID,FA,FB,FC,FD,SAR,DAR,OR,IR,ZR,FP,SP,RP,HP
global  name_generator

# --------------------------------------------------------------------------- #

procedure initialize_assembler ()
  # procedure to initialize register sets
  # and to create the name generator

  IA      := "I0"       # integer calculation registers
  IB      := "I1"
  IC      := "I2"
  ID      := "I3"

  SAR     := "I4"       # source      address register
  DAR     := "I5"       # destination address register
  OR      := "I6"       # offset register
  IR      := "I7"       # index  register

  ZR      := "I11"      # zero   register
  SP      := "I12"      # frame  pointer
  FP      := "I13"      # stack  pointer
  RP      := "I14"      # return pointer
  HP      := "I15"      # heap   pointer

  FA      := "F0"       # floating point calculation registers
  FB      := "F1"
  FC      := "F2"
  FD      := "F3"

  name_generator         := create ("K"||seq())
end

# --------------------------------------------------------------------------- #

procedure emit_blank_line ()
  # generate a blank line within the kbox assembly code

  write ()
end

procedure emit_comment (message)
  # insert a single comment line in the kbox assembly code

  write ("# ",message)
end

procedure emit_label (label)
  # insert an internal label name into the kbox assembly code

  emit_line ("_LABEL",label)
end

procedure emit_line (opcode,oper1,oper2,oper3,comment)
  # generate a single line of code in the kbox assembly code

  writes (left ("",10))
  writes (left (opcode,15))
  if (\oper1) then
  {
    ops := oper1
    if (\oper2) then
    {
      ops := ops||" "||oper2
      if (\oper3) then
        ops := ops||" "||oper3
    }
  }
  else
    ops := ""
  if ((opcode == "_DEFINE") | (opcode == "_RESERVE") | (*ops > 25)) then
  {
    write (ops)
    return
  }
  writes (left (ops,25))
  if (/comment) then
    write ()
  else
    write ("# "||comment)
end

# --------------------------------------------------------------------------- #

procedure emit_program_prologue (prog_name)
  # emit kbox assembly code to:
  #   - define the text section
  #   - identify the entry point "main" for the kbox assembly code

  emit_comment ("BEGIN PROGRAM: "||prog_name)
  emit_blank_line ()
  display_global_symbol_table ()
  emit_blank_line ()
  emit_line ("_CODE_SEGMENT")
  emit_blank_line ()
  emit_line ("_GLOBAL","MAIN")
  emit_blank_line ()
end

procedure emit_program_epilogue (prog_name)
  # emit kbox assembly code to:
  #   - define the data section
  #   - display
  #     . symbol table
  #     . static memory

  emit_blank_line ()
  emit_line ("_DATA_SEGMENT")
  emit_blank_line ()
  setup_static_memory ()
  emit_blank_line ()
  emit_comment ("END PROGRAM: "||prog_name)
  emit_blank_line ()
end

# --------------------------------------------------------------------------- #

procedure emit_procedure_prologue (proc_name,local_vars)
  # emit kbox assembly code to:
  #   - display the new procedure name as a comment
  #   - set up a new activation stack item
  #     - save the return address
  #     - save the old frame pointer
  #     - move the current stack pointer to the new frame pointer

  # remember that the "caller" has the responsibility
  #   - evaluate the actual arguments
  #   - and push the appropriate information onto the activation stack
  #   - prior to the transfer of control

  emit_blank_line ()
  emit_comment ("BEGIN PROCEDURE: "||proc_name)
  emit_blank_line ()
  display_local_symbol_table ()
  emit_blank_line ()
  emit_label (proc_name)
  emit_line ("push",RP,,,"save the RP to stack")
  emit_line ("push",FP,,,"save the FP to stack")
  emit_line ("mov",FP,SP,,"current SP become the new FP")
  if (\local_vars) then
  {
    emit_line ("movi",OR,local_vars,,"space for local variables")
    emit_line ("add",SP,SP,OR)
  }
  emit_blank_line ()
end

procedure emit_procedure_epilogue (proc_name)
  # emit kbox assembly code to:
  #   - display the procedure name as a comment
  #   - clean up the obsolete activation stack item
  #     - retrieve the previous stack pointer from the current frame pointer
  #     - retrieve the old frame pointer
  #     - retrieve the return address

  emit_blank_line ()
  emit_label ("EXIT"||proc_name)
  # the following line automatically cleans up local variables!
  emit_line ("mov",SP,FP,,"retrieve old SP from current FP")
  emit_line ("pop",FP,,,"retrieve FP from stack")
  emit_line ("pop",RP,,,"retrieve RP from stack")
  emit_line ("ret",,,,"return to calling procedure")
  emit_blank_line ()
  emit_comment ("END PROCEDURE: "||proc_name)
  emit_blank_line ()
end

# --------------------------------------------------------------------------- #

procedure save_register (reg)
  # emit kbox assembly code to:
  # save the value found in the specified reg
  # to the top of the stack

  emit_line ("push",reg,,,reg||" --> stack")
end

procedure retrieve_register (reg)
  # emit kbox assembly code to:
  # save the value found on the top of the stack
  # to the specified reg

  emit_line ("pop",reg,,,"stack --> "||reg)
end

# --------------------------------------------------------------------------- #

procedure emit_Lvalue (addr,scope)
  # emit kbox assembly code to:
  # move the address of the identifier
  # into SAR

  if (scope == "global") then
    emit_line ("lda",SAR,"="||addr,,"Lvalue --> SAR")
  else # (scope == "local")
  {
    emit_line ("movi",OR,addr,,"Lvalue --> SAR")
    emit_line ("add",SAR,FP,OR)
  }
end

procedure emit_Indirect ()
  # emit kbox assembly code to:
  # replace the address in the SAR register
  # with the actual address for the data

  emit_line ("ldr",SAR,SAR,,"indirect / call by var")
end

procedure emit_Rvalue (data_type)
  # emit kbox assembly code to:
  # retrieve the data value found at the memory address
  # currently found in SAR
  # and push the data value onto the top of the stack

  if ((data_type == "INT") |
      (data_type == "STRING") |
      (isPointer(data_type))) then
  {
    emit_line ("ldr",IA,SAR,,"Rvalue --> stack")
    emit_line ("push",IA)
  }
  else if (data_type == "REAL") then
  {
    emit_line ("ldr",FA,SAR,,"Rvalue --> stack")
    emit_line ("push",FA)
  }
  else
  {
    emit_comment ("note: for structured data types, Rvalue = Lvalue!")
    emit_line ("push",SAR)
  }
end

procedure emit_literal (literal_type,literal_value)
  # emit kbox assembly code to:
  # move a constant value to the top of the stack

  if (literal_type == "INT") then
  {
    emit_line ("movi",IA,literal_value,,"int literal constant")
    emit_line ("push",IA)
  }
  else if (literal_type == "REAL") then
  {
    emit_line ("movi",FA,literal_value,,"real literal constant")
    emit_line ("push",FA)
  }
  else if (literal_type == "STRING") then
  {
    emit_line ("movi",SAR,literal_value)
    emit_line ("push",SAR)
  }
  else # (literal_type == "POINTER")
  {
    emit_line ("ldr",IA,ZR,,"NULL pointer")
    emit_line ("push",IA)
  }
end

# --------------------------------------------------------------------------- #

procedure emit_promote (reg)
  if (reg[1] == "I") then
  {
    dest := "F" || reg[2:0]
    emit_line ("i2f",dest,reg,,"promote")
  }
  else
    stop ("invalid int register ("||reg||")")
end

procedure emit_demote (reg)
  if (reg[1] == "F") then
  {
    dest := "I" || reg[2:0]
    emit_line ("f2i",dest,reg,,"demote")
  }
  else
    stop ("invalid real register ("||reg||")")
end

# --------------------------------------------------------------------------- #

procedure emit_read (data_type)
  # emit kbox assembly code to:
  #   - read value from the keyboard
  #   - store value on the top of the stack
  #   - data type determines fmt

  if (\data_type) then
  {
    if (data_type == "INT") then
    {
      fmt := "INT"
      reg := IA
    }
    else
    {
      fmt := "FLT"
      reg := FA
    }
    emit_line ("get",fmt,,,"read")
    emit_line ("pop",reg,,,"store input value")
    emit_line ("pop",DAR)
    emit_line ("str",reg,DAR)
  }
  else
    emit_line ("getln",,,,"eol")
end

# --------------------------------------------------------------------------- #

procedure emit_write (data_type)
  # emit kbox assembly code to:
  #   - write value to the monitor
  #   - value is found on the top of the stack
  #   - data type determines fmt

  if (\data_type) then
  {
    if (data_type == "INT") then
      fmt := "INT"
    else if (data_type == "REAL") then
      fmt := "FLT"
    else if (data_type == "STRING") then
      fmt := "STR"
    else if (isPointer(data_type)) then
      fmt := "PTR"
    else
    {
      stop ("invalid write data type ("||data_type||")")
    }
    emit_line ("put",fmt,,,"write")
  }
  else
    emit_line ("putln",,,,"eol")
end

# --------------------------------------------------------------------------- #

procedure emit_assign (target_type,expr_type,data_size)
  # emit kbox code to assign the data value found at the top of the stack
  #   to the target location also found at the top of the stack
  # target_type specifies the data type for the transfer

  emit_line ("nop",,,,"assignment")
  if (isAtomic(global_symbol_table[target_type])) then
    if (target_type == "INT") then
    {
      if (expr_type == "REAL") then
      {
        emit_line ("pop",FA)
        emit_demote (FA)
      }
      else if (expr_type == "INT") then
        emit_line ("pop",IA)
      else
        stop ("invalid assignment: "||target_type||" <-> "||expr_type)
      emit_line ("pop",DAR)
      emit_line ("str",IA,DAR)
    }
    else if (target_type == "REAL") then
    {
      if (expr_type == "INT") then
      {
        emit_line ("pop",IA)
        emit_promote (IA)
      }
      else if (expr_type == "REAL") then
        emit_line ("pop",FA)
      else
        stop ("invalid assignment: "||target_type||" <-> "||expr_type)
      emit_line ("pop",DAR)
      emit_line ("str",FA,DAR)
    }
    else
      stop ("invalid assignment: "||target_type||" <-> "||expr_type)
  else if (isArray(global_symbol_table[target_type]) |
           isRecord(global_symbol_table[target_type])) then
    if (target_type == expr_type) then
    {
      label_loop := @name_generator
      emit_line ("pop",SAR)
      emit_line ("pop",DAR)
      emit_line ("movi",IR,data_size)
      emit_label (label_loop)
      emit_line ("ldr",IA,SAR)
      emit_line ("str",IA,DAR)
      emit_line ("inc",SAR)
      emit_line ("inc",DAR)
      emit_line ("dec",IR)
      emit_line ("cmp",IR,ZR)
      emit_line ("jgt",label_loop)
    }
    else
      stop ("invalid assignment: "||target_type||" <-> "||expr_type)
  else if (isPointer(target_type)) then
    if ((target_type == expr_type) | (expr_type == "POINTER")) then
    {
      emit_line ("pop",IA)
      emit_line ("pop",DAR)
      emit_line ("str",IA,DAR)
    }
    else
      stop ("invalid assignment: "||target_type||" <-> "||expr_type)
  else
    stop ("how on earth did you get here!")
end

# --------------------------------------------------------------------------- #

procedure emit_get_operands (a_type,b_type,c_type)
  # emit kbox code to retrieve a two operands
  #   from the top of the stack
  # b_type and c_type determine the destination registers for the data
  #   and a_type determines any promotion

  if ((c_type == "INT") | isPointer(c_type)) then
    emit_line ("pop",IC,,,"get operands")
  else if (c_type == "REAL") then
    emit_line ("pop",FC,,,"get operands")
  else
    stop ("unrecognized data type ("||c_type||")")
  if ((b_type == "INT") | isPointer(b_type)) then
    emit_line ("pop",IB)
  else if (b_type == "REAL") then
    emit_line ("pop",FB)
  else
    stop ("unrecognized data type ("||b_type||")")
  if ((b_type == "INT") & (a_type == "REAL")) then
    emit_promote (IB)
  if ((c_type == "INT") & (a_type == "REAL")) then
    emit_promote (IC)
end

# --------------------------------------------------------------------------- #

procedure emit_compop (op,a_type,b_type,c_type)
  # emit kbox code to compare two data values
  # a_type, b_type, and c_type determine the registers to use

  emit_get_operands (a_type,b_type,c_type)
  if ((a_type == "INT") | isPointer(a_type)) then
  {
    inst := "cmp"
    emit_line (inst,IB,IC,,"perform comparison "||op)
  }
  else if (a_type == "REAL") then
  {
    inst := "fcmp"
    emit_line (inst,FB,FC,,"perform comparison "||op)
  }
  else
    stop ("invalid arithmetic data type ("||a_type||")")
  label_true :=  @name_generator
  label_false := @name_generator
  label_done :=  @name_generator
  if (op == "=") then
    emit_line ("jeq",label_true)
  else if (op == "<>") then
    emit_line ("jne",label_true)
  else if (op == ">") then
    emit_line ("jgt",label_true)
  else if (op == "<") then
    emit_line ("jlt",label_true)
  else if (op == ">=") then
    emit_line ("jge",label_true)
  else # (op == "<=")
    emit_line ("jle",label_true)
  emit_label (label_false)
  emit_line ("movi",IA,"0")
  emit_line ("jmp",label_done)
  emit_label (label_true)
  emit_line ("movi",IA,"1")
  emit_label (label_done)
  emit_line ("push",IA)
end

procedure emit_addop (op,a_type,b_type,c_type)
  # emit kbox code to add/subtract two data values
  # a_type, b_type, and c_type determine the registers to use

  emit_get_operands (a_type,b_type,c_type)
  if (a_type == "INT") then
  {
    if (op == "+") then
      inst := "add"
    else if (op == "-") then
      inst := "sub"
    else
      stop ("invalid INT addop ("||op||")")
    emit_line (inst,IA,IB,IC,"perform addop "||op)
    emit_line ("push",IA)
  }
  else if (a_type == "REAL") then
  {
    if (op == "+") then
      inst := "fadd"
    else if (op == "-") then
      inst := "fsub"
    else
      stop ("invalid REAL addop ("||op||")")
    emit_line (inst,FA,FB,FC,"perform addop "||op)
    emit_line ("push",FA)
  }
  else
    stop ("invalid arithmetic data type ("||a_type||")")
end

procedure emit_mulop (op,a_type,b_type,c_type)
  # emit kbox code to multiply/divide two data values
  # a_type, b_type, and c_type determine the registers to use

  emit_get_operands (a_type,b_type,c_type)
  if (a_type == "INT") then
  {
    if (op == "*") then
      inst := "mul"
    else if (op == "/") then
      inst := "div"
    else if (op == "%") then
      inst := "mod"
    else
      stop ("invalid INT mulop ("||op||")")
    emit_line (inst,IA,IB,IC,"perform mulop "||op)
    emit_line ("push",IA)
  }
  else if (a_type == "REAL") then
  {
    if (op == "*") then
      inst := "fmul"
    else if (op == "/") then
      inst := "fdiv"
    else
      stop ("invalid REAL mulop ("||op||")")
    emit_line (inst,FA,FB,FC,"perform mulop "||op)
    emit_line ("push",FA)
  }
  else
    stop ("invalid arithmetic data type ("||a_type||")")
end

procedure emit_neg (data_type)
  # emit kbox code to negate a single data value

  if (data_type == "INT") then
  {
    emit_line ("pop",IA)
    emit_line ("neg",IA)
    emit_line ("push",IA)
  }
  else if (data_type == "REAL") then
  {
    emit_line ("pop",FA)
    emit_line ("fneg",FA)
    emit_line ("push",FA)
  }
  else
    stop ("invalid arithmetic data type ("||data_type||")")
end

# --------------------------------------------------------------------------- #

procedure emit_and_a (label_false)
  # emit kbox code to perform logical AND on INT data values
  # note: but implements short-circuit logic, not simple LAND instruction

  emit_line ("pop",IA,,,"short-circuit and")
  emit_line ("cmp",IA,ZR)
  emit_line ("jeq",label_false)
end

procedure emit_and_b (label_false,label_done)

  emit_line ("pop",IA)
  emit_line ("cmp",IA,ZR)
  emit_line ("jeq",label_false)
  emit_line ("movi",IA,1)
  emit_line ("push",IA)
  emit_line ("jmp",label_done)
  emit_label (label_false)
  emit_line ("mov",IA,ZR)
  emit_line ("push",IA)
  emit_label (label_done)
  emit_line ("nop")
end

procedure emit_or_a (label_true)
  # emit kbox code to perform logical OR on INT data values
  # note: but implements short-circuit logic, not simple LOR instruction

  emit_line ("pop",IA,,,"short-circuit or")
  emit_line ("cmp",IA,ZR)
  emit_line ("jne",label_true)
end

procedure emit_or_b (label_true,label_done)

  emit_line ("pop",IA)
  emit_line ("cmp",IA,ZR)
  emit_line ("jne",label_true)
  emit_line ("mov",IA,ZR)
  emit_line ("push",IA)
  emit_line ("jmp",label_done)
  emit_label (label_true)
  emit_line ("movi",IA,1)
  emit_line ("push",IA)
  emit_label (label_done)
  emit_line ("nop")
end

procedure emit_not (data_type)
  # emit kbox code to perform logical NOT on a INT data value

  if (data_type == "INT") then
  {
    emit_line ("pop",IA,,"logical not")
    emit_line ("lnot",IA)
    emit_line ("push",IA)
  }
  else
    stop ("invalid logical NOT data type ("||data_type||")")
end

# --------------------------------------------------------------------------- #

procedure calc_array_offset (element_size)
  emit_line ("nop",,,,"array offset")
  retrieve_register (IR)
  emit_line ("movi",OR,element_size)
  emit_line ("mul",OR,IR,OR)
  retrieve_register (SAR)
  emit_line ("add",SAR,SAR,OR)
end

procedure calc_record_offset (offset)
  emit_line ("nop",,,,"record offset")
  emit_line ("movi",OR,offset)
  retrieve_register (SAR)
  emit_line ("add",SAR,SAR,OR)  
end

# --------------------------------------------------------------------------- #

procedure emit_empty ()
  emit_line ("nop",,,,"empty statement")
end

procedure emit_goto (lvalue)
  emit_line ("jmp",lvalue,,,"goto statement")
end

procedure emit_do_a ()
  emit_line ("nop",,,,"do statement")
end

procedure emit_do_b ()
  emit_line ("nop",,,,"end do")
end

procedure emit_if_a ()
  emit_line ("nop",,,,"if statement")
end

procedure emit_if_b ()
  emit_line ("nop",,,,"end if")
end

procedure emit_test_a (label_false,label_done)
  emit_line ("pop",IA,,,"test result")
  emit_line ("cmp",IA,ZR)
  emit_line ("jeq",label_false)
  emit_line ("nop",,,,"then clause")
end

procedure emit_test_b (label_false,label_done)
  emit_line ("jmp",label_done)
  emit_label (label_false)
  emit_line ("nop",,,,"else clause")
end

procedure emit_test_c (label_false,label_done)
  emit_label (label_done)
  emit_line ("nop",,,,"end test")
end

procedure emit_case_a ()
  emit_line ("nop",,,,"case statement")
end

procedure emit_case_b ()
  emit_line ("nop",,,,"end case")
end

procedure emit_case_compare (case_value,label_next)
  emit_line ("movi",IB,case_value,,"case value");
  emit_line ("pop",IA,,,"target value")
  emit_line ("push",IA,,"resave target value")
  emit_line ("cmp",IA,IB)
  emit_line ("jne",label_next)
end

procedure emit_next_case (label_exit,label_next)
  if (\label_next) then
  {
    emit_line ("jmp",label_exit)
    emit_label (label_next)
  }
  else
    emit_label (label_exit)
end

procedure emit_while_a (label_top)
  emit_label (label_top)
  emit_line ("nop",,,,"while statement")
end

procedure emit_while_b (label_bottom)
  emit_label (label_bottom)
  emit_line ("nop",,,,"end while")
end

procedure emit_repeat_a (label_top)
  emit_label (label_top)
  emit_line ("nop",,,,"repeat statement")
end

procedure emit_repeat_b (label_bottom)
  emit_label (label_bottom)
  emit_line ("nop",,,,"end repeat")
end

procedure emit_for_a ()
  emit_line ("nop",,,,"for statement")
end

procedure emit_for_b ()
  emit_line ("nop",,,,"end for")
end

procedure emit_for_setup ()
  emit_line ("pop",IB,,,"set up for loop")
  emit_line ("pop",IA)
  emit_line ("pop",DAR)
  emit_line ("str",IA,DAR)
  emit_line ("push",DAR)
  emit_line ("push",IB)
end

procedure emit_for_test (flag,label_top,label_break)
  emit_label (label_top)
  emit_line ("pop",IB,,,"top test for loop")
  emit_line ("pop",SAR)
  emit_line ("ldr",IA,SAR)
  emit_line ("cmp",IA,IB)
  if (flag == "up") then
    emit_line ("jgt",label_break)
  else
    emit_line ("jlt",label_break)
  emit_line ("push",SAR)
  emit_line ("push",IB)
end

procedure emit_for_increment (flag,label_top,label_next,label_break)
  emit_label (label_next)
  emit_line ("pop",IB,,,"increment for loop")
  emit_line ("pop",DAR)
  emit_line ("ldr",IA,DAR)
  if (flag == "up") then
    emit_line ("inc",IA)
  else
    emit_line ("dec",IA)
  emit_line ("str",IA,DAR)
  emit_line ("push",DAR)
  emit_line ("push",IB)
  emit_line ("jmp",label_top)
  emit_label (label_break)
end

procedure emit_call (procedure_name,return_type)
  emit_line ("call",procedure_name);
  no_actual_args := *global_symbol_table[procedure_name].formal_arguments
  emit_line ("movi",OR,no_actual_args)
  emit_line ("add",SP,SP,OR)
  if (\return_type) then
    if (return_type == "REAL") then
      emit_line ("push",FA)
    else # ((return_type == "INT") | (return_type == "STRING")) then
      emit_line ("push",IA)
end