// > TransInit - initialisation for the ARM Pascal translator

SECTION "Setup"

GET "MyHdr"

STATIC $( old.wrch = ? ; vir.wrch.ptr = ? $)

LET start () BE
$(
  init ()
  pass.1 ()
  pass.2 ()
$)


AND init () BE /************* General dogsbody initialisation ****************/
$(
  LET MyAbort (arg) BE // Re-Voctored Hard Bread ?
  $(
    wrch := old.wrch
    selectoutput (console)
    SysAbort (arg)
  $)

  SysAbort := Abort    // We need to take this over to reset the output
  Abort    := MyAbort

  new.wrch.init ()     // Re-voctored hard tabs for pretty output

  console := output () // Must be before anything that could cause an error

  get.args ()

  selectinput (infile)

  lab          := mygetvec (max.label) // Vector of BL addresses referenced
  arm.label.cp := mygetvec (max.label) // And their corresponding ARM addresses

  for i = 0 to max.label do
  $(
    lab!i          := 0
    arm.label.cp!i := 0
  $)

  ser.proc.numv := mygetvec (max.proc)  // serial proc nos == BL proc numbers
  arm.proc.cp   := mygetvec (max.proc)  // ARM addresses of serial procedures
  bl.proc.cp    := mygetvec (max.proc)  // BL addresses of serial procedures

  for i = 0 to max.proc do // Need to initialise for FORWARD proc references
  $(
    ser.proc.numv!i := 0
    arm.proc.cp!i   := 0
    bl.proc.cp!i    := 0
  $)

  cc := mygetvec (off.int+max.cc) // ARM condition codes corresponding to BL

  cc!off.eq := c.eq ;  cc!off.ne := c.ne ;  cc!off.le := c.le
  cc!off.ge := c.ge ;  cc!off.lt := c.lt ;  cc!off.gt := c.gt

  cc!(off.ptr+off.eq) := c.eq
  cc!(off.ptr+off.ne) := c.ne

  cc!(off.int+off.eq) := c.eq
  cc!(off.int+off.ne) := c.ne
  cc!(off.int+off.le) := c.le
  cc!(off.int+off.ge) := c.ge
  cc!(off.int+off.lt) := c.lt
  cc!(off.int+off.gt) := c.gt

  regs := mygetvec (15+1) // Strings for ARM registers

  regs!r0 := "r0"
  regs!r1 := "r1"
  regs!temp := "temp"
  regs!t0 := "t0"
  regs!t1 := "t1"
  regs!t2 := "t2"
  regs!t3 := "t3"
  regs!arga  := "arga"
  regs!count := "count"
  regs!currbase := "currbase"
  regs!globalbase := "globalbase"
  regs!frame := "frame"
  regs!sp   := "sp"
  regs!hasp := "hasp"
  regs!link := "link"
  regs!pc   := "pc"
  regs!null.reg := "" // For those ops that don't have one of the fields there

  if debugflag then for i = 0 to 15 do writef ("%I2 = %S*N", i, regs!i)

  armop := mygetvec (31) // Set up arithmetic opcode strings

  armop!d.adc := "ADC";  armop!d.adcs := "ADCS"
  armop!d.add := "ADD";  armop!d.adds := "ADDS"
  armop!d.and := "AND";  armop!d.ands := "ANDS"
  armop!d.bic := "BIC";  armop!d.bics := "BICS"
  armop!d.cmn := "CMN"
  armop!d.cmp := "CMP"
  armop!d.eor := "EOR";  armop!d.eors := "EORS"
  armop!d.mov := "MOV";  armop!d.movs := "MOVS"
  armop!d.mvn := "MVN";  armop!d.mvns := "MVNS"
  armop!d.orr := "ORR";  armop!d.orrs := "ORRS"
  armop!d.rsb := "RSB";  armop!d.rsbs := "RSBS"
  armop!d.rsc := "RSC";  armop!d.rscs := "RSCS"
  armop!d.sbc := "SBC";  armop!d.sbcs := "SBCS"
  armop!d.sub := "SUB";  armop!d.subs := "SUBS"
  armop!d.teq := "TEQ"
  armop!d.tst := "TST"

  armcc := mygetvec (15) // Set up ARM condition code strings

  armcc!c.eq := "EQ";  armcc!c.ne := "NE"
  armcc!c.cs := "CS";  armcc!c.cc := "CC"
  armcc!c.mi := "MI";  armcc!c.pl := "PL"
  armcc!c.vs := "VS";  armcc!c.vc := "VC"
  armcc!c.hi := "HI";  armcc!c.ls := "LS"
  armcc!c.ge := "GE";  armcc!c.lt := "LT"
  armcc!c.gt := "GT";  armcc!c.le := "LE"
  armcc!c.al := "";    armcc!c.nv := "NV"

  shift.names := mygetvec (8) // Set up ARM shift type strings

  shift.names!s.lsl := "LSL #";  shift.names!s.lsl.r := "LSL "
  shift.names!s.lsr := "LSR #";  shift.names!s.lsr.r := "LSR "
  shift.names!s.asr := "ASR #";  shift.names!s.asr.r := "ASR "
  shift.names!s.ror := "ROR #";  shift.names!s.ror.r := "ROR "


// Set up routines that simply call others rather than having a call overhead

  locateK.ild.S := locateK.ild.L

  pshI.blk.S := pshI.blk.L;  popI.blk.S := popI.blk.L

  pshI.ptr := pshI.int;  pshL.ptr := pshL.int
  popI.ptr := popI.int;  popL.ptr := popL.int

  pshK.uby := pshK.bce
  pshI.uby := pshI.bce;  pshL.uby := pshL.bce
  popI.uby := popI.bce;  popL.uby := popL.bce

  set.elem.bce := set.elem.int;  set.subr.bce := set.subr.int

  op.ne.bce := op.eq.bce;  op.le.bce := op.eq.bce;  op.ge.bce := op.eq.bce
  op.lt.bce := op.eq.bce;  op.gt.bce := op.eq.bce

  op.eq.ptr := op.eq.bce;  op.ne.ptr := op.eq.bce

  op.eq.int := op.eq.bce;  op.ne.int := op.eq.bce;  op.le.int := op.eq.bce
  op.ge.int := op.eq.bce;  op.lt.int := op.eq.bce;  op.gt.int := op.eq.bce

  op.eq.rea := op.ne.rea

  op.le.rea := op.gt.rea;  op.ge.rea := op.gt.rea;  op.lt.rea := op.gt.rea

  op.in.bce := op.in.int

  op.xsub.int := op.add.int

  op.union.set      := op.intersect.set
  op.difference.set := op.intersect.set

  case.jump.bce := case.jump.int

  check.int.S := check.bce;  check.int.L := check.bce

  for.to.bce := for.to.int;  for.ot.bce := for.ot.int
  for.dt.bce := for.dt.int
  for.td.bce := for.td.int

  pr.new.S := pr.new.L
  pr.dispose.S := pr.dispose.L
$)


AND get.args () BE
$(
  argv := mygetvec (255)

  unless rdargs ("FILE/A,TO/K,LIST/K,DEBUG/S,NOCHECK/S,IDENTITY/S", argv, 255)
    then naffup ("Bad arguments")

  infilename   := argv!0
  outfilename  := argv!1
  listfilename := argv!2
  debugflag    := argv!3
  checking     := ~(argv!4)

  writes ("Tutu's ARM Pascal translator")

  if argv!5 then writes (" Version 0.31 (24-Sep-87)")   // -identity ?

  wrch('*N')

  unless infilename then
  $(
    writes("+++ Error: Nothing to translate*N")
    stop (42)
  $)

  unless outfilename then // If dest not supplied, assume we know what he wants
  $(
    if listfilename then listfilename := concat ("Asm.", listfilename)
//    listfilename :=  concat ("Asm.", infilename)
    outfilename := concat ("Bin.", infilename)
    infilename  := concat ("a4.", infilename)
  $)

  infile   := openin  (infilename)
  outfile  := openout (outfilename)
  listfile := listfilename -> openout (listfilename), false // Open if wanted
$)


AND mygetvec (n) = VALOF
$(
  LET ptr = getvec (n)
  unless ptr then naffup ("Getvec (%N) failed", n)
  resultis ptr
$)


AND openin (str) = VALOF
$(
  LET infile = findinput (str)
  unless infile then naffup ("Can't open %S for input", str)
  resultis infile
$)


AND openout (str) = VALOF
$(
  LET outfile = findoutput (str)
  unless outfile then naffup ("Can't open %S for output", str)
  resultis outfile
$)


AND concat (str1, str2) = VALOF
$(
  LET len1 = str1%0
  LET len2 = str2%0
  LET newstr = mygetvec ((len1+len2+1)/bytesperword)
  newstr%0 := len1 + len2
  for i = 1 to len1 do newstr%i := str1%i
  for i = 1 to len2 do newstr%(i+len1) := str2%i
  resultis newstr
$)


AND naffup (str, a1, a2, a3) BE // General error reporting utility
$(
  endwrite (outfile)
  selectoutput (console)
  writes ("+++ Error: ")
  writef (str, a1, a2, a3)
  wrch ('*N')
  stop (42)
$)


/********* First pass - generate all necessary labels for second pass ********/

AND pass.1 () BE
$(
  LET lust, putty, paddy, bl.proc.no = list.this, put.word, ?, ?
  LET my.increment () BE arm.cp +:= 4

  writef ("Pass 1*N")
  lab.i  := 0
  num.procs  := 0
  codelength := 0

  list.this := sweet.f.all
  put.word := my.increment

  process.code ()

  list.this := lust
  put.word := putty

  if debugflag then
    writef ("%N label%S created*N", lab.i, (lab.i = 1) -> "", "s")

// Read the PAT at the end to find the BL procedure numbers corresponding
// to our serial procedure numbers that we've just found
                 
  num.procs := ser.proc.no-1
  bl.proc.no := 0
  $(
    paddy := getword ()
    if paddy = #XFFFF then break // repeat loop
    for spn = 0 to num.procs do
    $(
      if paddy = bl.proc.cp!spn
      then
      $(
        ser.proc.numv!bl.proc.no := spn
        if debugflag then
          writef ("NewProc BP%N AP%N @ BL %X5*N", bl.proc.no, spn, paddy)
        break // for loop
      $)
    $)
    bl.proc.no +:= 1
  $) repeat

$) // End of first pass processing


AND pass.2 () BE
$(
  writes ("Pass 2*N")

  selectinput (openin (infilename))
  selectoutput (outfile)

  unless listfile then list.this := sweet.f.all

  process.code () // Go off and do the assembly
$)


// Create new label entry corresponding to given BL address

AND newlabel (addr) BE
$(
  for i = 1 to lab.i do if lab!i = addr then return
  if debugflag then writef ("; NewLabel &%X4*N", addr)
  if lab.i = max.label then naffup ("Too many labels")
  lab.i +:= 1
  lab!lab.i := addr
$)


// Return label number corresponding to given BL address
// Can look up ARM address in arm.label.cp!(blabel(bl.addr))

AND blabel (addr) = VALOF
$(
  for i = 1 to lab.i do if lab!i = addr then resultis i
  resultis 0 // Invalid label == FALSE
$)


/*********** Compact and prettify the output when listing to a file **********/

AND new.wrch.init () BE
$(
  old.wrch := wrch
  wrch := new.wrch
  vir.wrch.ptr := 0
$)


AND new.wrch (ch) BE
switchon ch into
$(
  case '*N' :
  $(
    old.wrch ('*N')
    vir.wrch.ptr := 0
    ENDCASE
  $)

  default : old.wrch (ch) ; vir.wrch.ptr +:= 1 ; ENDCASE

  case '*T' :
  $(
    test vir.wrch.ptr >= 255 then $( old.wrch (ch) ; vir.wrch.ptr +:= 1 $)
    else
    $(
      LET thing = (vir.wrch.ptr / 8) * 8
      LET tab.i, tab.pos = 0, ?
      $(
        tab.pos := (TABLE 1, 9, 56, 60, 70, 132, 255)!tab.i
        tab.i +:= 1
      $) repeatuntil vir.wrch.ptr < tab.pos
      for i = 1 to ((tab.pos - thing) / 8) do old.wrch ('*T')
      for i = 1 to ((tab.pos - thing) REM 8) do old.wrch ('*S')
      vir.wrch.ptr := tab.pos
    $)
    ENDCASE
  $)
$)
.