MODULE trans8to64 ;

(* trans8to64 : translate a classic 16-bit Turbo Modula-2 .MCD binary
   into a 64-bit MC64 .MC4 image that mcint can boot.

   16-bit file layout (little-endian) ::
      header   : 16 bytes
         fileSize       u16  (byte count not counting header)
         moduleStart    u16  (blob offset of the module descriptor)
         codeSize       u16  (size of the blob that follows the header)
         nbDependencies u16
         reserved       [8] bytes
      blob     : codeSize bytes
         + moduleStart       descriptor:
            +66..73  name[8]        +74,75 loadAddr
            +76,77   checksum       +78,79 procsAddr
            +80      flags (bit2=TOINIT)
            +81      varCount       +82 proc count k0   +83 depCount
            +84      var sizes : varCount*u16 BYTES
         proc table : cell i (i16) at procsAddr-2*i, descending;
            proc_i = (procsAddr-2*i) + 1 + cell
            scan i while cell<0 ; codeEnd = procsAddr-2*k0
      dependencies : nbDeps * 12 bytes (dropped by mc64)

   16-bit dependencies : nbDependencies u16 (header +6) ; records of 12 bytes
   (name[8], version u16, location u16) sit at blob offset +4 (header +4),
   at the tail of the blob.  The 64-bit image carries dcnt (DescDepCount)
   and an 8-byte name per dependency, appended at the image tail.

   64-bit output : 64-byte "MC64" header + descriptor + translated code +
   rebuilt proc table (cells relative to cell start) + dcnt*8 dep-name table.

   Operand translation (locked against mc64/Interpreter.mod) ::
      8E word imm  2B -> 8B  zero-extended (CARDINAL/word semantics)
      8F dword imm 4B -> 8B  via 8E, sign-extended (LONGINT constant)
      CD switch    u16 low/high(range size)/ret ; cells = high+1
                   64-bit: low u64, highw=low+high u64, t u64, cells i64
                   cells relative to cell-start+8 ; call-switch return
                   pushed as eot+t (mc64 CD honours t)
      CF push_code 2B -> 8B, target preserved
      E0/E1 jp     2B -> 8B, target preserved
      DC limit_check : 16-bit pops its limit (no operand) ; the 64-bit form
      reads a u8 immediate.  Reference modules only contain DC in dead code
      (right after a leave), so we emit `DC 00` (never executed).
   All other opcodes have identical operand widths and pass through.

   Limitations :
      - global slots / module-table address tricks (e.g. 0xFFF7/0xFFFF) do
        not map onto the mc64 data window => globals misbehave at run time.
      - extern references 0xEF/0xF0 point at dependencies; mc64 sets dcnt=0,
        so such calls crash if executed.
      - 8F used for REAL constants decodes as a LONGINT.
      - runnable only for dependency-free modules; TOINIT (flags bit2) is
        preserved, so a module with a real proc0 init runs under mcint.
*)

FROM FileIO IMPORT ReadFile, WriteFile ;
FROM Console IMPORT WriteString, WriteLn, WriteLongCard, Fatal ;
FROM ProgramArgs IMPORT ArgChan, NextArg ;
FROM TextIO IMPORT ReadString ;

CONST
  MaxBuf = 65535 ;
  HeaderSize = 64 ;
  DescName = 264 ;
  DescLoadAddr = 280 ;
  DescChecksum = 288 ;
  DescFlags = 292 ;
  DescVarCount = 293 ;
  DescDepCount = 294 ;
  DescPad = 295 ;
  DescProcs = 296 ;
  DescVarSizes = 304 ;

VAR
  inName, outName : ARRAY [0 .. 200] OF CHAR ;
  src : ARRAY [0 .. MaxBuf] OF CHAR ;
  dst : ARRAY [0 .. MaxBuf] OF CHAR ;
  map : ARRAY [0 .. MaxBuf] OF LONGCARD ;
  got : CARDINAL ;
  ms, cs : CARDINAL ;
  ndeps, deps16 : CARDINAL ;
  k2 : CARDINAL ;
  desc, procs16 : CARDINAL ;
  k0 : CARDINAL ;
  codeEnd : CARDINAL ;
  flags8, vcnt : CARDINAL ;
  varSizes : ARRAY [0 .. 31] OF CARDINAL ;
  procAddrs : ARRAY [0 .. 255] OF CARDINAL ;
  ents : ARRAY [0 .. 256] OF CARDINAL ;
  nEnt : CARDINAL ;
  codeOff, procTabImg, imgLen : CARDINAL ;
  i, j, sum : CARDINAL ;

PROCEDURE H16 (off : CARDINAL) : CARDINAL ;
BEGIN
  RETURN ORD (src [off]) + 256 * ORD (src [off + 1]) ;
END H16 ;

PROCEDURE B (p : CARDINAL) : CARDINAL ;
BEGIN
  RETURN ORD (src [16 + p]) ;
END B ;

PROCEDURE Get16 (p : CARDINAL) : CARDINAL ;
BEGIN
  IF (p > MaxBuf) OR (p + 1 > MaxBuf) THEN
    Fatal ("trans8to64: Get16 out of range") ;
  END ;
  RETURN ORD (src [16 + p]) + 256 * ORD (src [16 + p + 1]) ;
END Get16 ;

PROCEDURE Sig16 (p : CARDINAL) : LONGINT ;
VAR v : CARDINAL ;
BEGIN
  v := Get16 (p) ;
  IF v >= 32768 THEN
    RETURN VAL (LONGINT, v) - 65536 ;
  ELSE
    RETURN VAL (LONGINT, v) ;
  END ;
END Sig16 ;

PROCEDURE Align8 (c : CARDINAL) : CARDINAL ;
BEGIN
  IF (c MOD 8) # 0 THEN
    RETURN c + 8 - (c MOD 8) ;
  ELSE
    RETURN c ;
  END ;
END Align8 ;

PROCEDURE WB (off : CARDINAL; v : CARDINAL) ;
BEGIN
  dst [HeaderSize + off] := CHR (v MOD 256) ;
END WB ;

PROCEDURE Put64 (off : CARDINAL; v : LONGCARD) ;
VAR j : CARDINAL ;
BEGIN
  FOR j := 0 TO 7 DO
    dst [HeaderSize + off + j] := CHR (VAL (CARDINAL, v MOD 256)) ;
    v := v DIV 256 ;
  END ;
END Put64 ;

PROCEDURE Put32 (off, v : CARDINAL) ;
BEGIN
  dst [HeaderSize + off] := CHR (v MOD 256) ;
  dst [HeaderSize + off + 1] := CHR ((v DIV 256) MOD 256) ;
  dst [HeaderSize + off + 2] := CHR ((v DIV 65536) MOD 256) ;
  dst [HeaderSize + off + 3] := CHR (v DIV 16777216) ;
END Put32 ;

(* number of sub-opcode operand bytes consumed by 0x12 quad ops *)
PROCEDURE QuadLen (sub : CARDINAL) : CARDINAL ;
BEGIN
  CASE sub OF
  | 0H, 1H, 2H, 4H, 5H, 6H : RETURN 1 ;
  | 3H, 7H : RETURN 2 ;
  | 0AH : RETURN 1 ;
  ELSE RETURN 0 ;
  END ;
END QuadLen ;

PROCEDURE InstrLen16 (p : CARDINAL) : CARDINAL ;
VAR op, sub, v : CARDINAL ;
BEGIN
  op := B (p) ;
  CASE op OF
  | 02H : RETURN 2 ;
  | 08H, 09H, 0AH, 0CH,
    11H, 18H, 19H, 1AH, 1CH,
    2CH, 2DH, 2EH,
    3CH, 3DH, 3EH,
    40H,
    80H, 81H, 82H, 84H, 85H, 86H, 87H, 8DH,
    0AEH, 0AFH, 0B0H, 0B1H,
    0D4H, 0DEH, 0DFH,
    0ECH, 0EDH, 0EEH, 0F0H : RETURN 2 ;
  | 0BH, 1BH, 2FH, 3FH, 83H, 0EFH : RETURN 3 ;
  | 12H : sub := B (p + 1) ; RETURN 2 + QuadLen (sub) ;
  | 8CH : RETURN 2 + B (p + 1) ;
  | 8EH, 0CFH, 0E0H, 0E1H : RETURN 3 ;
  | 8FH : RETURN 5 ;
  | 0CDH : v := Get16 (p + 3) ;
           IF v >= 30000 THEN
             v := 30000 ;
           END ;
           RETURN 7 + 2 * (v + 1) ;  ELSE RETURN 1 ;
  END ;
END InstrLen16 ;

PROCEDURE InstrInfo (p : CARDINAL; VAR sz16, out, op : CARDINAL) ;
BEGIN
  op := B (p) ;
  sz16 := InstrLen16 (p) ;
  out := sz16 ;
  CASE op OF
  | 8EH, 8FH, 0CFH, 0E0H, 0E1H : out := 9 ;
  | 0CDH : out := 25 + 8 * (Get16 (p + 3) + 1) ;
  | 0DCH : out := 2 ;
  ELSE out := sz16 ;
  END ;
END InstrInfo ;

(* pass 1 : assign image offsets to every instruction in [start, stop) *)
PROCEDURE Laying (start, stop : CARDINAL; VAR startImg : CARDINAL) ;
VAR p, op, sz16, out, cur : CARDINAL ;
BEGIN
  p := start ;
  cur := startImg ;
  WHILE p < stop DO
    InstrInfo (p, sz16, out, op) ;
    IF p + sz16 > stop THEN
      sz16 := stop - p ;
      out := sz16 ;
    END ;
    map [p] := VAL (LONGCARD, cur) ;
    IF cur + out > MaxBuf THEN
      Fatal ("trans8to64: output too large") ;
    END ;
    cur := cur + out ;
    p := p + sz16 ;
  END ;
  map [stop] := VAL (LONGCARD, cur) ;
  startImg := cur ;
END Laying ;

(* pass 2 : emit [start, stop) at curImg (must follow pass 1 exactly) *)
PROCEDURE Emitting (start, stop : CARDINAL; VAR curImg : CARDINAL) ;
VAR p, op, sz16, out, cur, j, N, low, high, ret, tgt16, lsw, msw : CARDINAL ;
    first, eot, t, off64, rel64, cellImg, idx : LONGCARD ;
BEGIN
  p := start ;
  cur := curImg ;
  WHILE p < stop DO
    InstrInfo (p, sz16, out, op) ;
    IF p + sz16 > stop THEN
      sz16 := stop - p ;
      out := sz16 ;
      op := 0H ;
    END ;
    IF op = 8EH THEN
      WB (cur, 8EH) ;
      Put64 (cur + 1, VAL (LONGCARD, Get16 (p + 1))) ;
    ELSIF op = 8FH THEN
      lsw := Get16 (p + 1) ;
      msw := Get16 (p + 3) ;
      IF B (p + 4) >= 128 THEN
        off64 := VAL (LONGCARD,
                 (VAL (LONGINT, msw) - 65536) * 65536 +
                  VAL (LONGINT, lsw)) ;
      ELSE
        off64 := VAL (LONGCARD,
                 VAL (LONGINT, msw) * 65536 + VAL (LONGINT, lsw)) ;
      END ;
      WB (cur, 8EH) ;
      Put64 (cur + 1, off64) ;
    ELSIF op = 0CFH THEN
      tgt16 := VAL (CARDINAL,
               VAL (LONGINT, p) + 2 + Sig16 (p + 1)) ;
      off64 := map [tgt16] - (VAL (LONGCARD, cur) + 8) ;
      WB (cur, 0CFH) ;
      Put64 (cur + 1, off64) ;
    ELSIF (op = 0E0H) OR (op = 0E1H) THEN
      tgt16 := VAL (CARDINAL,
               VAL (LONGINT, p) + 2 + Sig16 (p + 1)) ;
      off64 := map [tgt16] - (VAL (LONGCARD, cur) + 9) ;
      WB (cur, op) ;
      Put64 (cur + 1, off64) ;
    ELSIF op = 0DCH THEN
      WB (cur, 0DCH) ;
      WB (cur + 1, 0) ;
    ELSIF op = 0CDH THEN
      low := Get16 (p + 1) ;
      high := Get16 (p + 3) ;
      ret := Get16 (p + 5) ;
      N := high + 1 ;
      WB (cur, 0CDH) ;
      Put64 (cur + 1, VAL (LONGCARD, low)) ;
      Put64 (cur + 9, VAL (LONGCARD, low + high)) ;
      first := VAL (LONGCARD, cur) + 25 ;
      eot := first + VAL (LONGCARD, N) * 8 ;
      idx := VAL (LONGCARD, p) + 6 + VAL (LONGCARD, ret) ;
      IF idx > VAL (LONGCARD, MaxBuf) THEN
        idx := VAL (LONGCARD, codeEnd) ;
      END ;
      t := map [VAL (CARDINAL, idx)] - eot ;
      Put64 (cur + 17, t) ;
      FOR j := 0 TO N - 1 DO
        cellImg := VAL (LONGCARD, cur) + 25 + VAL (LONGCARD, j) * 8 ;
        tgt16 := VAL (CARDINAL,
                 VAL (LONGINT, p) + 7 + VAL (LONGINT, j) * 2 +
                 1 + Sig16 (p + 7 + 2 * j)) ;
        rel64 := map [tgt16] - (cellImg + 8) ;
        Put64 (VAL (CARDINAL, cellImg), rel64) ;
      END ;
    ELSE
      FOR j := 0 TO sz16 - 1 DO
        WB (cur + j, B (p + j)) ;
      END ;
    END ;
    cur := cur + out ;
    p := p + sz16 ;
  END ;
  curImg := cur ;
END Emitting ;

(* insert an entry, keeping ents[] sorted and unique *)
PROCEDURE AddEnt (e : CARDINAL) ;
VAR i, j : CARDINAL ;
BEGIN
  i := 0 ;
  WHILE (i < nEnt) AND (ents [i] < e) DO
    INC (i) ;
  END ;
  IF (i < nEnt) AND (ents [i] = e) THEN
    RETURN ;
  END ;
  j := nEnt ;
  WHILE j > i DO
    ents [j] := ents [j - 1] ;
    DEC (j) ;
  END ;
  ents [i] := e ;
  INC (nEnt) ;
END AddEnt ;

PROCEDURE Usage ;
BEGIN
  WriteString ("usage: trans8to64 in.MCD out.MC4") ;
  WriteLn ;
END Usage ;

BEGIN
  NextArg ;
  ReadString (ArgChan (), inName) ;
  NextArg ;
  ReadString (ArgChan (), outName) ;
  IF (inName [0] = 0C) OR (outName [0] = 0C) THEN
    Usage ;
    HALT (1) ;
  END ;

  IF NOT ReadFile (inName, src, got) THEN
    Fatal ("trans8to64: cannot read input") ;
  END ;
  IF got <= 16 THEN
    Fatal ("trans8to64: input too short") ;
  END ;

  FOR i := 0 TO MaxBuf DO
    dst [i] := 0C ;
  END ;

  ms := H16 (2) ;
  cs := H16 (4) ;
  IF 16 + cs > got THEN
    Fatal ("trans8to64: header/blob size mismatch") ;
  END ;
  ndeps := H16 (6) ;
  deps16 := cs ;
  IF ndeps > 32 THEN
    Fatal ("trans8to64: too many dependencies") ;
  END ;
  IF 16 + deps16 + ndeps * 12 > got THEN
    Fatal ("trans8to64: dependency table out of range") ;
  END ;
  IF ms + 84 > cs THEN
    Fatal ("trans8to64: descriptor out of range") ;
  END ;

  desc := ms ;
  procs16 := Get16 (desc + 78) ;
  flags8 := B (desc + 80) ;
  vcnt := B (desc + 81) ;
  IF vcnt > 32 THEN
    Fatal ("trans8to64: too many var sizes") ;
  END ;
  IF desc + 84 + 2 * vcnt > cs THEN
    Fatal ("trans8to64: var sizes out of range") ;
  END ;
  IF procs16 + 2 > cs THEN
    Fatal ("trans8to64: procs table out of range") ;
  END ;

  (* count proc-table cells (negative, descending) *)
  k0 := 0 ;
  WHILE (procs16 >= 2 * k0) AND (Sig16 (procs16 - 2 * k0) < 0) DO
    INC (k0) ;
  END ;
  IF k0 > 255 THEN
    Fatal ("trans8to64: too many procedures") ;
  END ;
  codeEnd := procs16 - 2 * k0 ;

  IF k0 > 0 THEN
    FOR j := 0 TO k0 - 1 DO
      procAddrs [j] := VAL (CARDINAL,
                       VAL (LONGINT, procs16 - 2 * j) + 1 +
                       Sig16 (procs16 - 2 * j)) ;
    END ;
  END ;

  (* sorted unique proc entries + final code end *)
  nEnt := 0 ;
  IF k0 > 0 THEN
    FOR j := 0 TO k0 - 1 DO
      IF procAddrs [j] <= codeEnd THEN
        AddEnt (procAddrs [j]) ;
      END ;
    END ;
  END ;
  AddEnt (codeEnd) ;

  (* 16-bit var sizes *)
  IF vcnt > 0 THEN
    FOR j := 0 TO vcnt - 1 DO
      varSizes [j] := Get16 (desc + 84 + 2 * j) ;
    END ;
  END ;

  codeOff := Align8 (304 + vcnt * 8) ;
  IF codeOff < 312 THEN
    codeOff := 312 ;
  END ;

  (* pass 1 : assign positions ; intervals start at each proc entry *)
  procTabImg := codeOff ;
  IF nEnt >= 2 THEN
    FOR j := 0 TO nEnt - 2 DO
      Laying (ents [j], ents [j + 1], procTabImg) ;
    END ;
  END ;

  (* descriptor *)
  FOR j := 0 TO 7 DO
    WB (DescName + j, B (desc + 66 + j)) ;
  END ;
  Put64 (DescLoadAddr, VAL (LONGCARD, Get16 (desc + 74))) ;
  WB (DescFlags, flags8) ;
  WB (DescVarCount, vcnt) ;
  WB (DescDepCount, ndeps) ;
  WB (DescPad, 0) ;
  IF vcnt > 0 THEN
    FOR j := 0 TO vcnt - 1 DO
      Put64 (DescVarSizes + j * 8, VAL (LONGCARD, Align8 (varSizes [j]))) ;
    END ;
  END ;

  (* pad the code region to 8 before the proc table *)
  procTabImg := Align8 (procTabImg) ;

  (* pass 2 : emit *)
  imgLen := codeOff ;
  FOR j := 0 TO nEnt - 2 DO
    Emitting (ents [j], ents [j + 1], imgLen) ;
  END ;
  imgLen := Align8 (imgLen) ;
  IF imgLen > procTabImg THEN
    procTabImg := imgLen ;
  END ;
  Put64 (DescProcs, VAL (LONGCARD, procTabImg)) ;

  (* rebuild the proc table : cell = target - cellAddr *)
  FOR j := 0 TO k0 - 1 DO
    Put64 (procTabImg + j * 8,
           map [procAddrs [j]] - VAL (LONGCARD, procTabImg + j * 8)) ;
  END ;
  imgLen := procTabImg + k0 * 8 ;

  (* append the dependency name table at the image tail : 8 bytes each *)
  IF ndeps > 0 THEN
    IF imgLen + ndeps * 8 > MaxBuf THEN
      Fatal ("trans8to64: output too large") ;
    END ;
    FOR j := 0 TO ndeps - 1 DO
      FOR k2 := 0 TO 7 DO
        WB (imgLen + k2, B (deps16 + j * 12 + k2)) ;
      END ;
      INC (imgLen, 8) ;
    END ;
  END ;

  (* file header : magic *)
  dst [0] := 'M' ;
  dst [1] := 'C' ;
  dst [2] := '6' ;
  dst [3] := '4' ;

  (* checksum over the image bytes, excluding the checksum field itself *)
  sum := 0 ;
  FOR i := HeaderSize TO HeaderSize + imgLen - 1 DO
    IF NOT ((i >= 352) AND (i <= 355)) THEN
      sum := sum + ORD (dst [i]) ;
    END ;
  END ;
  Put32 (DescChecksum, sum) ;

  IF HeaderSize + imgLen > MaxBuf + 1 THEN
    Fatal ("trans8to64: output too large") ;
  END ;
  IF NOT WriteFile (outName, dst, HeaderSize + imgLen) THEN
    Fatal ("trans8to64: cannot write output") ;
  END ;
  WriteString ("trans8to64: ") ;
  WriteString (inName) ;
  WriteString (" -> ") ;
  WriteString (outName) ;
  WriteString (" : ok (") ;
  WriteLongCard (VAL (LONGCARD, HeaderSize + imgLen)) ;
  WriteString (" bytes)") ;
  WriteLn ;
END trans8to64.