--
-- The Rosetta Code Virtual Machine, in Ada.
--
-- It is assumed the platform on which this program is run
-- has two's-complement integers. (Otherwise one could modify
-- the vmint_to_vmsigned and vmsigned_to_vmint functions. But
-- the chances your binary integers are not two's-complement
-- seem pretty low.)
--

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line;        use Ada.Command_Line;

with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;

with Ada.Text_IO;              use Ada.Text_IO;
with Ada.Text_IO.Text_Streams; use Ada.Text_IO.Text_Streams;

with Ada.Unchecked_Conversion;

procedure VM
is
  bad_vm            : exception;
  vm_limit_exceeded : exception;
  vm_runtime_error  : exception;

  status           : Exit_Status;
  input_file_name  : Unbounded_String;
  output_file_name : Unbounded_String;
  input_file       : File_Type;
  output_file      : File_Type;

-- Some limits of this implementation. You can adjust these to taste.
  strings_size : constant := 2_048;
  stack_size   : constant := 2_048;
  data_size    : constant := 2_048;
  code_size    : constant := 32_768;

  type byte is mod 16#100#;
  type vmint is mod 16#1_0000_0000#;
  subtype vmsigned is Integer range -2_147_483_648 .. 2_147_483_647;

  op_halt  : constant byte := 0;
  op_add   : constant byte := 1;
  op_sub   : constant byte := 2;
  op_mul   : constant byte := 3;
  op_div   : constant byte := 4;
  op_mod   : constant byte := 5;
  op_lt    : constant byte := 6;
  op_gt    : constant byte := 7;
  op_le    : constant byte := 8;
  op_ge    : constant byte := 9;
  op_eq    : constant byte := 10;
  op_ne    : constant byte := 11;
  op_and   : constant byte := 12;
  op_or    : constant byte := 13;
  op_neg   : constant byte := 14;
  op_not   : constant byte := 15;
  op_prtc  : constant byte := 16;
  op_prti  : constant byte := 17;
  op_prts  : constant byte := 18;
  op_fetch : constant byte := 19;
  op_store : constant byte := 20;
  op_push  : constant byte := 21;
  op_jmp   : constant byte := 22;
  op_jz    : constant byte := 23;

  strings : array (0 .. strings_size - 1) of Unbounded_String;
  stack   : array (0 .. stack_size - 1) of vmint;
  data    : array (0 .. data_size - 1) of vmint;
  code    : array (0 .. code_size) of byte;
  sp      : vmint;
  pc      : vmint;

  output_stream : Stream_Access;

  function vmsigned_to_vmint is new Ada.Unchecked_Conversion
   (Source => vmsigned, Target => vmint);

  function vmint_to_vmsigned is new Ada.Unchecked_Conversion
   (Source => vmint, Target => vmsigned);

  function twos_complement
   (x : in vmint)
    return vmint
  is
  begin
    return (not x) + 1;
  end twos_complement;

  function vmint_to_digits
   (x : in vmint)
    return Unbounded_String
  is
    s : Unbounded_String;
    z : vmint;
  begin
    if x = 0 then
      s := To_Unbounded_String ("0");
    else
      s := To_Unbounded_String ("");
      z := x;
      while z /= 0 loop
        s := Character'Val ((z rem 10) + Character'Pos ('0')) & s;
        z := z / 10;
      end loop;
    end if;
    return s;
  end vmint_to_digits;

  function digits_to_vmint
   (s : in String)
    return vmint
  is
    zero     : constant Character := '0';
    zero_pos : constant Integer   := Character'Pos (zero);
    retval   : vmint;
  begin
    if s'Length < 1 then
      raise bad_vm with "expected a numeric literal";
    end if;
    retval := 0;
    for i in s'Range loop
      if Is_Decimal_Digit (s (i)) then
        retval :=
         (10 * retval) + vmint (Character'Pos (s (i)) - zero_pos);
      else
        raise bad_vm with "expected a decimal digit";
      end if;
    end loop;
    return retval;
  end digits_to_vmint;

  function string_to_vmint
   (s : in String)
    return vmint
  is
    retval : vmint;
  begin
    if s'Length < 1 then
      raise bad_vm with "expected a numeric literal";
    end if;
    if s (s'First) = '-' then
      if s'Length < 2 then
        raise bad_vm with "expected a numeric literal";
      end if;
      retval :=
       twos_complement (digits_to_vmint (s (s'First + 1 .. s'Last)));
    else
      retval := digits_to_vmint (s);
    end if;
    return retval;
  end string_to_vmint;

  procedure parse_header
   (s             : in     String;
    data_count    :    out vmint;
    strings_count :    out vmint)
  is
    i : Positive;
    j : Positive;
  begin
    i := s'First;
    while i <= s'Last and then not Is_Decimal_Digit (s (i)) loop
      i := i + 1;
    end loop;

    j := i;
    while j <= s'Last and then Is_Decimal_Digit (s (j)) loop
      j := j + 1;
    end loop;

    data_count := digits_to_vmint (s (i .. j - 1));

    i := j;
    while i <= s'Last and then not Is_Decimal_Digit (s (i)) loop
      i := i + 1;
    end loop;

    j := i;
    while j <= s'Last and then Is_Decimal_Digit (s (j)) loop
      j := j + 1;
    end loop;

    strings_count := digits_to_vmint (s (i .. j - 1));
  end parse_header;

  function parse_string_literal
   (s : in String)
    return Unbounded_String
  is
    t : Unbounded_String;
    i : Positive;

    --
    -- A little trick to get around mistaken highlighting on the
    -- Rosetta Code site.
    --
    quote_string : constant String    := """";
    quote        : constant Character := quote_string (1);

  begin
    t := To_Unbounded_String ("");

    i := s'First;
    while i <= s'Last and then s (i) /= quote loop
      i := i + 1;
    end loop;

    if s'Last < i or else s (i) /= quote then
      raise bad_vm with "expected a '""'";
    end if;

    i := i + 1;
    while i <= s'Last and then s (i) /= quote loop
      if s (i) /= '\' then
        Append (t, s (i));
        i := i + 1;
      elsif s'Last < i + 1 then
        raise bad_vm with "truncated string literal";
      elsif s (i + 1) = 'n' then
        Append (t, Character'Val (10));
        i := i + 2;
      elsif s (i + 1) = '\' then
        Append (t, '\');
        i := i + 2;
      else
        raise bad_vm with "unsupported escape sequence";
      end if;
    end loop;

    return t;
  end parse_string_literal;

  function name_to_opcode
   (s : in String)
    return byte
  is
    retval : byte;
  begin
    if s = "halt" then
      retval := op_halt;
    elsif s = "add" then
      retval := op_add;
    elsif s = "sub" then
      retval := op_sub;
    elsif s = "mul" then
      retval := op_mul;
    elsif s = "div" then
      retval := op_div;
    elsif s = "mod" then
      retval := op_mod;
    elsif s = "lt" then
      retval := op_lt;
    elsif s = "gt" then
      retval := op_gt;
    elsif s = "le" then
      retval := op_le;
    elsif s = "ge" then
      retval := op_ge;
    elsif s = "eq" then
      retval := op_eq;
    elsif s = "ne" then
      retval := op_ne;
    elsif s = "and" then
      retval := op_and;
    elsif s = "or" then
      retval := op_or;
    elsif s = "neg" then
      retval := op_neg;
    elsif s = "not" then
      retval := op_not;
    elsif s = "prtc" then
      retval := op_prtc;
    elsif s = "prti" then
      retval := op_prti;
    elsif s = "prts" then
      retval := op_prts;
    elsif s = "fetch" then
      retval := op_fetch;
    elsif s = "store" then
      retval := op_store;
    elsif s = "push" then
      retval := op_push;
    elsif s = "jmp" then
      retval := op_jmp;
    elsif s = "jz" then
      retval := op_jz;
    else
      raise bad_vm with ("unexpected opcode name");
    end if;
    return retval;
  end name_to_opcode;

  procedure parse_instruction
   (s       : in     String;
    address :    out vmint;
    opcode  :    out byte;
    arg     :    out vmint)
  is
    i : Positive;
    j : Positive;
  begin
    i := s'First;
    while i <= s'Last and then not Is_Decimal_Digit (s (i)) loop
      i := i + 1;
    end loop;

    j := i;
    while j <= s'Last and then Is_Decimal_Digit (s (j)) loop
      j := j + 1;
    end loop;

    address := digits_to_vmint (s (i .. j - 1));

    i := j;
    while i <= s'Last and then not Is_Letter (s (i)) loop
      i := i + 1;
    end loop;

    j := i;
    while j <= s'Last and then Is_Letter (s (j)) loop
      j := j + 1;
    end loop;

    opcode := name_to_opcode (s (i .. j - 1));

    i := j;
    while i <= s'Last and then Is_Space (s (i)) loop
      i := i + 1;
    end loop;

    if s'Last < i then
      arg := 0;
    else
      if not Is_Decimal_Digit (s (i)) and then s (i) /= '-' then
        i := i + 1;
      end if;
      j := i;
      while j <= s'Last
       and then (Is_Decimal_Digit (s (j)) or else s (j) = '-')
      loop
        j := j + 1;
      end loop;
      arg := string_to_vmint (s (i .. j - 1));
    end if;
  end parse_instruction;

  procedure read_and_parse_header
   (data_count    : out vmint;
    strings_count : out vmint)
  is
    line : Unbounded_String;
  begin
    Get_Line (Current_Input, line);
    parse_header (To_String (line), data_count, strings_count);
  end read_and_parse_header;

  procedure read_parse_and_store_strings
   (strings_count : in vmint)
  is
    line : Unbounded_String;
  begin
    if strings_count /= 0 then
      if strings_size < strings_count then
        raise vm_limit_exceeded with "strings limit exceeded";
      end if;
      for i in 0 .. strings_count - 1 loop
        Get_Line (Current_Input, line);
        strings (Integer (i)) :=
         parse_string_literal (To_String (line));
      end loop;
    end if;
  end read_parse_and_store_strings;

  function opcode_takes_arg
   (opcode : in byte)
    return Boolean
  is
    retval : Boolean;
  begin
    if opcode = op_fetch then
      retval := True;
    elsif opcode = op_store then
      retval := True;
    elsif opcode = op_push then
      retval := True;
    elsif opcode = op_jmp then
      retval := True;
    elsif opcode = op_jz then
      retval := True;
    else
      retval := False;
    end if;
    return retval;
  end opcode_takes_arg;

  procedure read_parse_and_store_instructions
  is
    line    : Unbounded_String;
    address : vmint;
    opcode  : byte;
    arg     : vmint;
    j       : Positive;
  begin
    while not End_Of_File (Current_Input) loop
      Get_Line (Current_Input, line);

      j := 1;
      while j <= Length (line) and then Is_Space (Element (line, j))
      loop
        j := j + 1;
      end loop;

      if j <= Length (line) then
        parse_instruction (To_String (line), address, opcode, arg);
        if opcode_takes_arg (opcode) then
          if code_size - 4 <= address then
            raise vm_limit_exceeded with "code space limit exceeded";
          end if;
          code (Integer (address)) := opcode;
          --
          -- Little-endian storage.
          --
          code (Integer (address) + 1) := byte (arg and 16#FF#);
          code (Integer (address) + 2) :=
           byte ((arg / 16#100#) and 16#FF#);
          code (Integer (address) + 3) :=
           byte ((arg / 16#1_0000#) and 16#FF#);
          code (Integer (address) + 4) :=
           byte ((arg / 16#100_0000#) and 16#FF#);
        else
          if code_size <= address then
            raise vm_limit_exceeded with "code space limit exceeded";
          end if;
          code (Integer (address)) := opcode;
        end if;
      end if;
    end loop;
  end read_parse_and_store_instructions;

  procedure read_parse_and_store_program
  is
    data_count    : vmint;
    strings_count : vmint;
  begin
    read_and_parse_header (data_count, strings_count);
    read_parse_and_store_strings (strings_count);
    read_parse_and_store_instructions;
  end read_parse_and_store_program;

  procedure pop_value
   (x : out vmint)
  is
  begin
    if sp = 0 then
      raise vm_runtime_error with "stack underflow";
    end if;
    sp := sp - 1;
    x  := stack (Integer (sp));
  end pop_value;

  procedure push_value
   (x : in vmint)
  is
  begin
    if stack_size <= sp then
      raise vm_runtime_error with "stack overflow";
    end if;
    stack (Integer (sp)) := x;
    sp                   := sp + 1;
  end push_value;

  procedure get_value
   (x : out vmint)
  is
  begin
    if sp = 0 then
      raise vm_runtime_error with "stack underflow";
    end if;
    x := stack (Integer (sp) - 1);
  end get_value;

  procedure put_value
   (x : in vmint)
  is
  begin
    if sp = 0 then
      raise vm_runtime_error with "stack underflow";
    end if;
    stack (Integer (sp) - 1) := x;
  end put_value;

  procedure fetch_value
   (i : in     vmint;
    x :    out vmint)
  is
  begin
    if data_size <= i then
      raise vm_runtime_error with "data boundary exceeded";
    end if;
    x := data (Integer (i));
  end fetch_value;

  procedure store_value
   (i : in vmint;
    x : in vmint)
  is
  begin
    if data_size <= i then
      raise vm_runtime_error with "data boundary exceeded";
    end if;
    data (Integer (i)) := x;
  end store_value;

  procedure immediate_value
   (x : out vmint)
  is
    b0, b1, b2, b3 : vmint;
  begin
    if code_size - 4 <= pc then
      raise vm_runtime_error with "code boundary exceeded";
    end if;
    --
    -- Little-endian order.
    --
    b0 := vmint (code (Integer (pc)));
    b1 := vmint (code (Integer (pc) + 1));
    b2 := vmint (code (Integer (pc) + 2));
    b3 := vmint (code (Integer (pc) + 3));
    x  :=
     b0 + (16#100# * b1) + (16#1_0000# * b2) + (16#100_0000# * b3);
  end immediate_value;

  procedure machine_add
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    put_value (x + y);
  end machine_add;

  procedure machine_sub
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    put_value (x - y);
  end machine_sub;

  procedure machine_mul
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    put_value
     (vmsigned_to_vmint
       (vmint_to_vmsigned (x) * vmint_to_vmsigned (y)));
  end machine_mul;

  procedure machine_div
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    put_value
     (vmsigned_to_vmint
       (vmint_to_vmsigned (x) / vmint_to_vmsigned (y)));
  end machine_div;

  procedure machine_mod
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    put_value
     (vmsigned_to_vmint
       (vmint_to_vmsigned (x) rem vmint_to_vmsigned (y)));
  end machine_mod;

  procedure machine_lt
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if vmint_to_vmsigned (x) < vmint_to_vmsigned (y) then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_lt;

  procedure machine_gt
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if vmint_to_vmsigned (x) > vmint_to_vmsigned (y) then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_gt;

  procedure machine_le
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if vmint_to_vmsigned (x) <= vmint_to_vmsigned (y) then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_le;

  procedure machine_ge
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if vmint_to_vmsigned (x) >= vmint_to_vmsigned (y) then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_ge;

  procedure machine_eq
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if x = y then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_eq;

  procedure machine_ne
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if x /= y then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_ne;

  procedure machine_and
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if x /= 0 and y /= 0 then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_and;

  procedure machine_or
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if x /= 0 or y /= 0 then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_or;

  procedure machine_neg
  is
    x : vmint;
  begin
    get_value (x);
    put_value (twos_complement (x));
  end machine_neg;

  procedure machine_not
  is
    x : vmint;
  begin
    get_value (x);
    if x = 0 then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_not;

  procedure machine_prtc
  is
    x : vmint;
  begin
    pop_value (x);
    Character'Write (output_stream, Character'Val (x));
  end machine_prtc;

  procedure machine_prti
  is
    x : vmint;
  begin
    pop_value (x);
    if 16#7FFF_FFFF# < x then
      Character'Write (output_stream, '-');
      String'Write
       (output_stream,
        To_String (vmint_to_digits (twos_complement (x))));
    else
      String'Write (output_stream, To_String (vmint_to_digits (x)));
    end if;
  end machine_prti;

  procedure machine_prts
  is
    k : vmint;
  begin
    pop_value (k);
    if strings_size <= k then
      raise vm_runtime_error with "strings boundary exceeded";
    end if;
    String'Write (output_stream, To_String (strings (Integer (k))));
  end machine_prts;

  procedure machine_fetch
  is
    k : vmint;
    x : vmint;
  begin
    immediate_value (k);
    fetch_value (k, x);
    push_value (x);
    pc := pc + 4;
  end machine_fetch;

  procedure machine_store
  is
    k : vmint;
    x : vmint;
  begin
    immediate_value (k);
    pop_value (x);
    store_value (k, x);
    pc := pc + 4;
  end machine_store;

  procedure machine_push
  is
    x : vmint;
  begin
    immediate_value (x);
    push_value (x);
    pc := pc + 4;
  end machine_push;

  procedure machine_jmp
  is
    offset : vmint;
  begin
    immediate_value (offset);
    pc := pc + offset;
  end machine_jmp;

  procedure machine_jz
  is
    x      : vmint;
    offset : vmint;
  begin
    pop_value (x);
    if x = 0 then
      immediate_value (offset);
      pc := pc + offset;
    else
      pc := pc + 4;
    end if;
  end machine_jz;

  procedure machine_step
   (halt : out Boolean)
  is
    opcode             : byte;
    op_div_4, op_rem_4 : byte;
  begin
    if code_size <= pc then
      raise vm_runtime_error with "code boundary exceeded";
    end if;
    opcode   := code (Integer (pc));
    pc       := pc + 1;
    halt     := False;
    op_div_4 := opcode / 4;
    op_rem_4 := opcode rem 4;
    if op_div_4 = 0 then
      if op_rem_4 = 0 then
        halt := True;
      elsif op_rem_4 = 1 then
        machine_add;
      elsif op_rem_4 = 2 then
        machine_sub;
      else
        machine_mul;
      end if;
    elsif op_div_4 = 1 then
      if op_rem_4 = 0 then
        machine_div;
      elsif op_rem_4 = 1 then
        machine_mod;
      elsif op_rem_4 = 2 then
        machine_lt;
      else
        machine_gt;
      end if;
    elsif op_div_4 = 2 then
      if op_rem_4 = 0 then
        machine_le;
      elsif op_rem_4 = 1 then
        machine_ge;
      elsif op_rem_4 = 2 then
        machine_eq;
      else
        machine_ne;
      end if;
    elsif op_div_4 = 3 then
      if op_rem_4 = 0 then
        machine_and;
      elsif op_rem_4 = 1 then
        machine_or;
      elsif op_rem_4 = 2 then
        machine_neg;
      else
        machine_not;
      end if;
    elsif op_div_4 = 4 then
      if op_rem_4 = 0 then
        machine_prtc;
      elsif op_rem_4 = 1 then
        machine_prti;
      elsif op_rem_4 = 2 then
        machine_prts;
      else
        machine_fetch;
      end if;
    elsif op_div_4 = 5 then
      if op_rem_4 = 0 then
        machine_store;
      elsif op_rem_4 = 1 then
        machine_push;
      elsif op_rem_4 = 2 then
        machine_jmp;
      else
        machine_jz;
      end if;
    else
      -- Treat anything unrecognized as equivalent to a halt.
      halt := True;
    end if;
  end machine_step;

  procedure machine_continue
  is
    halt : Boolean;
  begin
    halt := False;
    while not halt loop
      machine_step (halt);
    end loop;
  end machine_continue;

  procedure machine_run
  is
  begin
    sp := 0;
    pc := 0;
    for i in data'Range loop
      data (i) := 0;
    end loop;
    machine_continue;
  end machine_run;

begin
  status := 0;

  input_file_name := To_Unbounded_String ("-");

  if Argument_Count = 0 then
    null;
  elsif Argument_Count = 1 then
    input_file_name := To_Unbounded_String (Argument (1));
  else
    Put ("Usage: ");
    Put (Command_Name);
    Put_Line (" [INPUTFILE]");
    Put ("If either INPUTFILE is missing or ""-"",");
    Put_Line (" standard input is used.");
    Put_Line ("Output is always to standard output.");
    status := 1;
  end if;

  if status = 0 then
    if input_file_name /= "-" then
      Open (input_file, In_File, To_String (input_file_name));
      Set_Input (input_file);
    end if;

    output_stream := Stream (Current_Output);
    read_parse_and_store_program;
    machine_run;

    if input_file_name /= "-" then
      Set_Input (Standard_Input);
      Close (input_file);
    end if;
  end if;

  Set_Exit_Status (status);
end VM;