MODULE ilo;
IMPORT Files, In, Out, SYSTEM, extArgs;

CONST
  MemSize = 65536;
  DSSize = 33;
  RSSize = 257;
  DSMax = DSSize - 1;
  RSMax = RSSize - 1;
  BlockBytes = 4096;
  BlockCells = BlockBytes DIV 4;
  MaxBit = 31;

VAR
  ip, sp, rp: INTEGER;
  ds: ARRAY DSSize OF INTEGER;
  rs: ARRAY RSSize OF INTEGER;
  m: ARRAY MemSize OF INTEGER;
  blocksName, romName: ARRAY 64 OF CHAR;
  a, b, s, d, l: INTEGER;
  ch: CHAR;

PROCEDURE CopyString(src: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
VAR i, max: INTEGER;
BEGIN
  i := 0; max := LEN(dest) - 1;
  WHILE (i < max) & (src[i] # 0X) DO
    dest[i] := src[i]; INC(i)
  END;
  dest[i] := 0X
END CopyString;

PROCEDURE Fail(msg: ARRAY OF CHAR);
BEGIN
  Out.String(msg); Out.Ln;
  ASSERT(FALSE)
END Fail;

PROCEDURE Push(v: INTEGER);
BEGIN
  INC(sp);
  IF sp > DSMax THEN
    Fail("Error: data stack overflow")
  END;
  ds[sp] := v
END Push;

PROCEDURE Pop(): INTEGER;
VAR v: INTEGER;
BEGIN
  IF sp < 0 THEN
    Fail("Error: data stack underflow")
  END;
  v := ds[sp];
  ds[sp] := 0;
  DEC(sp);
  RETURN v
END Pop;

PROCEDURE SaveIP;
BEGIN
  INC(rp);
  IF rp > RSMax THEN
    Fail("Error: return stack overflow")
  END;
  rs[rp] := ip
END SaveIP;

PROCEDURE BitAnd(x, y: INTEGER): INTEGER;
VAR sx, sy, res: SET; v: INTEGER;
BEGIN
  sx := SYSTEM.VAL(SET, x);
  sy := SYSTEM.VAL(SET, y);
  res := sx * sy;
  v := SYSTEM.VAL(INTEGER, res);
  RETURN v
END BitAnd;

PROCEDURE BitOr(x, y: INTEGER): INTEGER;
VAR sx, sy, res: SET; v: INTEGER;
BEGIN
  sx := SYSTEM.VAL(SET, x);
  sy := SYSTEM.VAL(SET, y);
  res := sx + sy;
  v := SYSTEM.VAL(INTEGER, res);
  RETURN v
END BitOr;

PROCEDURE BitXor(x, y: INTEGER): INTEGER;
VAR sx, sy, res: SET; v: INTEGER;
BEGIN
  sx := SYSTEM.VAL(SET, x);
  sy := SYSTEM.VAL(SET, y);
  res := sx / sy;
  v := SYSTEM.VAL(INTEGER, res);
  RETURN v
END BitXor;

PROCEDURE LogicalShift(val, amount: INTEGER): INTEGER;
VAR src, dst: SET; bit, shift, v: INTEGER;
BEGIN
  src := SYSTEM.VAL(SET, val);
  dst := {};
  shift := amount;
  IF shift >= 0 THEN
    IF shift <= MaxBit THEN
      bit := 0;
      WHILE bit <= MaxBit - shift DO
        IF bit IN src THEN INCL(dst, bit + shift) END;
        INC(bit)
      END
    END
  ELSE
    shift := -shift;
    IF shift <= MaxBit THEN
      bit := shift;
      WHILE bit <= MaxBit DO
        IF bit IN src THEN INCL(dst, bit - shift) END;
        INC(bit)
      END
    END
  END;
  v := SYSTEM.VAL(INTEGER, dst);
  RETURN v
END LogicalShift;

PROCEDURE Symmetric;
BEGIN
  IF (b >= 0) & (ds[sp - 1] < 0) THEN
    ds[sp] := ds[sp] + 1;
    ds[sp - 1] := ds[sp - 1] - b
  END
END Symmetric;

PROCEDURE LoadImage;
VAR f: Files.File; r: Files.Rider; idx: INTEGER;
BEGIN
  f := Files.Old(romName);
  IF f # NIL THEN
    Files.Set(r, f, 0);
    idx := 0;
    WHILE (idx < MemSize) & ~r.eof DO
      Files.ReadInt(r, m[idx]);
      INC(idx)
    END;
    ip := 0; sp := 0; rp := 0;
    Files.Close(f)
  END
END LoadImage;

PROCEDURE SaveImage;
VAR f: Files.File; r: Files.Rider; idx: INTEGER;
BEGIN
  f := Files.New(romName);
  Files.Set(r, f, 0);
  idx := 0;
  WHILE idx < MemSize DO
    Files.WriteInt(r, m[idx]);
    INC(idx)
  END;
  Files.Register(f)
END SaveImage;

PROCEDURE BlockCommon(VAR f: Files.File; VAR r: Files.Rider; VAR pos: INTEGER);
BEGIN
  b := Pop(); a := Pop();
  pos := a * BlockBytes;
  Files.Set(r, f, pos)
END BlockCommon;

PROCEDURE ReadBlock;
VAR f: Files.File; r: Files.Rider; pos, idx: INTEGER;
BEGIN
  f := Files.Old(blocksName);
  IF f # NIL THEN
    BlockCommon(f, r, pos);
    idx := 0;
    WHILE idx < BlockCells DO
      Files.ReadInt(r, m[b + idx]);
      INC(idx)
    END;
    Files.Close(f)
  END
END ReadBlock;

PROCEDURE WriteBlock;
VAR f: Files.File; r: Files.Rider; pos, idx: INTEGER;
BEGIN
  f := Files.Old(blocksName);
  IF f # NIL THEN
    BlockCommon(f, r, pos);
    idx := 0;
    WHILE idx < BlockCells DO
      Files.WriteInt(r, m[b + idx]);
      INC(idx)
    END;
    Files.Register(f);
    Files.Close(f)
  END
END WriteBlock;

PROCEDURE Li;
BEGIN
  INC(ip);
  Push(m[ip])
END Li;

PROCEDURE Du;
BEGIN
  Push(ds[sp])
END Du;

PROCEDURE Dr;
BEGIN
  ds[sp] := 0;
  DEC(sp)
END Dr;

PROCEDURE Sw;
VAR tmp: INTEGER;
BEGIN
  tmp := ds[sp];
  ds[sp] := ds[sp - 1];
  ds[sp - 1] := tmp
END Sw;

PROCEDURE Pu;
BEGIN
  INC(rp);
  IF rp > RSMax THEN
    Fail("Error: return stack overflow")
  END;
  rs[rp] := Pop()
END Pu;

PROCEDURE Po;
BEGIN
  IF rp < 0 THEN
    Fail("Error: return stack underflow")
  END;
  Push(rs[rp]);
  DEC(rp)
END Po;

PROCEDURE Ju;
BEGIN
  ip := Pop() - 1
END Ju;

PROCEDURE Ca;
BEGIN
  SaveIP;
  ip := Pop() - 1
END Ca;

PROCEDURE Cc;
BEGIN
  a := Pop();
  IF Pop() # 0 THEN
    SaveIP;
    ip := a - 1
  END
END Cc;

PROCEDURE Cj;
BEGIN
  a := Pop();
  IF Pop() # 0 THEN
    ip := a - 1
  END
END Cj;

PROCEDURE Re;
BEGIN
  IF rp < 0 THEN
    Fail("Error: return stack underflow")
  END;
  ip := rs[rp];
  DEC(rp)
END Re;

PROCEDURE Eq;
BEGIN
  IF ds[sp - 1] = ds[sp] THEN ds[sp - 1] := -1 ELSE ds[sp - 1] := 0 END;
  DEC(sp)
END Eq;

PROCEDURE Ne;
BEGIN
  IF ds[sp - 1] # ds[sp] THEN ds[sp - 1] := -1 ELSE ds[sp - 1] := 0 END;
  DEC(sp)
END Ne;

PROCEDURE Lt;
BEGIN
  IF ds[sp - 1] < ds[sp] THEN ds[sp - 1] := -1 ELSE ds[sp - 1] := 0 END;
  DEC(sp)
END Lt;

PROCEDURE Gt;
BEGIN
  IF ds[sp - 1] > ds[sp] THEN ds[sp - 1] := -1 ELSE ds[sp - 1] := 0 END;
  DEC(sp)
END Gt;

PROCEDURE Fe;
BEGIN
  ds[sp] := m[ds[sp]]
END Fe;

PROCEDURE St;
BEGIN
  m[ds[sp]] := ds[sp - 1];
  DEC(sp, 2)
END St;

PROCEDURE Ad;
BEGIN
  ds[sp - 1] := ds[sp - 1] + ds[sp];
  DEC(sp)
END Ad;

PROCEDURE Su;
BEGIN
  ds[sp - 1] := ds[sp - 1] - ds[sp];
  DEC(sp)
END Su;

PROCEDURE Mu;
BEGIN
  ds[sp - 1] := ds[sp - 1] * ds[sp];
  DEC(sp)
END Mu;

PROCEDURE Di;
BEGIN
  a := ds[sp];
  b := ds[sp - 1];
  ds[sp] := b DIV a;
  ds[sp - 1] := b MOD a;
  Symmetric
END Di;

PROCEDURE An;
BEGIN
  ds[sp - 1] := BitAnd(ds[sp], ds[sp - 1]);
  DEC(sp)
END An;

PROCEDURE Oo;
BEGIN
  ds[sp - 1] := BitOr(ds[sp], ds[sp - 1]);
  DEC(sp)
END Oo;

PROCEDURE Xo;
BEGIN
  ds[sp - 1] := BitXor(ds[sp], ds[sp - 1]);
  DEC(sp)
END Xo;

PROCEDURE Sl;
BEGIN
  ds[sp - 1] := LogicalShift(ds[sp - 1], ds[sp]);
  DEC(sp)
END Sl;

PROCEDURE Sr;
BEGIN
  ds[sp - 1] := LogicalShift(ds[sp - 1], -ds[sp]);
  DEC(sp)
END Sr;

PROCEDURE Cp;
BEGIN
  l := Pop();
  d := Pop();
  s := ds[sp];
  ds[sp] := -1;
  WHILE l # 0 DO
    IF m[d] # m[s] THEN ds[sp] := 0 END;
    DEC(l); INC(s); INC(d)
  END
END Cp;

PROCEDURE Cy;
BEGIN
  l := Pop();
  d := Pop();
  s := Pop();
  WHILE l # 0 DO
    m[d] := m[s];
    DEC(l); INC(s); INC(d)
  END
END Cy;

PROCEDURE Ioa;
BEGIN
  b := Pop();
  Out.Char(CHR(b MOD 256))
END Ioa;

PROCEDURE Iob;
BEGIN
  In.Char(ch);
  IF In.Done THEN
    Push(ORD(ch))
  ELSE
    Push(0)
  END
END Iob;

PROCEDURE Io;
BEGIN
  CASE Pop() OF
    0: Ioa
  | 1: Iob
  | 2: ReadBlock
  | 3: WriteBlock
  | 4: SaveImage
  | 5: LoadImage; ip := -1
  | 6: ip := MemSize
  | 7: Push(sp); Push(rp)
  END
END Io;

PROCEDURE Process(op: INTEGER);
BEGIN
  CASE op OF
     0: (* nop *)
  |  1: Li
  |  2: Du
  |  3: Dr
  |  4: Sw
  |  5: Pu
  |  6: Po
  |  7: Ju
  |  8: Ca
  |  9: Cc
  | 10: Cj
  | 11: Re
  | 12: Eq
  | 13: Ne
  | 14: Lt
  | 15: Gt
  | 16: Fe
  | 17: St
  | 18: Ad
  | 19: Su
  | 20: Mu
  | 21: Di
  | 22: An
  | 23: Oo
  | 24: Xo
  | 25: Sl
  | 26: Sr
  | 27: Cp
  | 28: Cy
  | 29: Io
  END
END Process;

PROCEDURE ProcessBundle(opcode: INTEGER);
VAR op: INTEGER;
BEGIN
  op := opcode;
  Process(op MOD 256);
  op := op DIV 256;
  Process(op MOD 256);
  op := op DIV 256;
  Process(op MOD 256);
  op := op DIV 256;
  Process(op MOD 256)
END ProcessBundle;

PROCEDURE Execute;
BEGIN
  WHILE ip < MemSize DO
    ProcessBundle(m[ip]);
    INC(ip)
  END
END Execute;

PROCEDURE DumpStack;
BEGIN
  WHILE sp > 0 DO
    Out.Char(CHR(32));
    Out.Int(ds[sp], 0);
    DEC(sp)
  END;
  Out.Ln
END DumpStack;

PROCEDURE InitNames;
VAR res: INTEGER;
BEGIN
  CopyString("ilo.blocks", blocksName);
  CopyString("ilo.rom", romName);
  IF extArgs.count >= 1 THEN
    extArgs.Get(0, blocksName, res)
  END;
  IF extArgs.count >= 2 THEN
    extArgs.Get(1, romName, res)
  END
END InitNames;

BEGIN
  InitNames;
  In.Open;
  LoadImage;
  Execute;
  DumpStack
END ilo.