A virtual machine implements a computer in software.

Task[edit]
Write a virtual machine interpreter. This interpreter should be able to run virtual
assembly language programs created via the task. This is a
byte-coded, 32-bit word stack based virtual machine.

The program should read input from a file and/or stdin, and write output to a file and/or
stdout.

Input format:

Given the following program:

count = 1;
while (count < 10) {
    print("count is: ", count, "\n");
    count = count + 1;
}

The output from the Code generator is a virtual assembly code program:



 Output from gen, input to VM



Datasize: 1 Strings: 2
"count is: "
"\n"
    0 push  1
    5 store [0]
   10 fetch [0]
   15 push  10
   20 lt
   21 jz     (43) 65
   26 push  0
   31 prts
   32 fetch [0]
   37 prti
   38 push  1
   43 prts
   44 fetch [0]
   49 push  1
   54 add
   55 store [0]
   60 jmp    (-51) 10
   65 halt

The first line of the input specifies the datasize required and the number of constant
strings, in the order that they are reference via the code.

The data can be stored in a separate array, or the data can be stored at the beginning of
the stack. Data is addressed starting at 0. If there are 3 variables, the 3rd one if
referenced at address 2.

If there are one or more constant strings, they come next. The code refers to these
strings by their index. The index starts at 0. So if there are 3 strings, and the code
wants to reference the 3rd string, 2 will be used.

Next comes the actual virtual assembly code. The first number is the code address of that
instruction. After that is the instruction mnemonic, followed by optional operands,
depending on the instruction.

Registers:

sp:

   the stack pointer - points to the next top of stack.  The stack is a 32-bit integer
   array.

pc:

   the program counter - points to the current instruction to be performed.  The code is an
   array of bytes.

Data:

   data
   string pool

Instructions:

Each instruction is one byte. The following instructions also have a 32-bit integer
operand:

fetch [index]

where index is an index into the data array.

store [index]

where index is an index into the data array.

push n

where value is a 32-bit integer that will be pushed onto the stack.

jmp (n) addr

where (n) is a 32-bit integer specifying the distance between the current location and the
desired location. addr is an unsigned value of the actual code address.

jz (n) addr

where (n) is a 32-bit integer specifying the distance between the current location and the
desired location. addr is an unsigned value of the actual code address.

The following instructions do not have an operand. They perform their operation directly
against the stack:

For the following instructions, the operation is performed against the top two entries in
the stack:

add
sub
mul
div
mod
lt
gt
le
ge
eq
ne
and
or

For the following instructions, the operation is performed against the top entry in the
stack:

neg
not

Print the word at stack top as a character.

prtc

Print the word at stack top as an integer.

prti

Stack top points to an index into the string pool. Print that entry.

prts

Unconditional stop.

halt

 A simple example virtual machine

def run_vm(data_size)
    int stack[data_size + 1000]
    set stack[0..data_size - 1] to 0
    int pc = 0
    while True:
        op = code[pc]
        pc += 1
 
        if op == FETCH:
            stack.append(stack[bytes_to_int(code[pc:pc+word_size])[0]]);
            pc += word_size
        elif op == STORE:
            stack[bytes_to_int(code[pc:pc+word_size])[0]] = stack.pop();
            pc += word_size
        elif op == PUSH:
            stack.append(bytes_to_int(code[pc:pc+word_size])[0]);
            pc += word_size
        elif op == ADD:   stack[-2] += stack[-1]; stack.pop()
        elif op == SUB:   stack[-2] -= stack[-1]; stack.pop()
        elif op == MUL:   stack[-2] *= stack[-1]; stack.pop()
        elif op == DIV:   stack[-2] /= stack[-1]; stack.pop()
        elif op == MOD:   stack[-2] %= stack[-1]; stack.pop()
        elif op == LT:    stack[-2] = stack[-2] <  stack[-1]; stack.pop()
        elif op == GT:    stack[-2] = stack[-2] >  stack[-1]; stack.pop()
        elif op == LE:    stack[-2] = stack[-2] <= stack[-1]; stack.pop()
        elif op == GE:    stack[-2] = stack[-2] >= stack[-1]; stack.pop()
        elif op == EQ:    stack[-2] = stack[-2] == stack[-1]; stack.pop()
        elif op == NE:    stack[-2] = stack[-2] != stack[-1]; stack.pop()
        elif op == AND:   stack[-2] = stack[-2] and stack[-1]; stack.pop()
        elif op == OR:    stack[-2] = stack[-2] or  stack[-1]; stack.pop()
        elif op == NEG:   stack[-1] = -stack[-1]
        elif op == NOT:   stack[-1] = not stack[-1]
        elif op == JMP:   pc += bytes_to_int(code[pc:pc+word_size])[0]
        elif op == JZ:    if stack.pop() then pc += word_size else pc += bytes_to_int(code[pc:pc+word_size])[0]
        elif op == PRTC:  print stack[-1] as a character; stack.pop()
        elif op == PRTS:  print the constant string referred to by stack[-1]; stack.pop()
        elif op == PRTI:  print stack[-1] as an integer; stack.pop()
        elif op == HALT:  break
 Additional examples
Your solution should pass all the test cases above and the additional tests found Here.

Reference
The C and Python versions can be considered reference implementations.

Related Tasks
 Lexical Analyzer task
 Syntax Analyzer task
 Code Generator task
 AST Interpreter task

--
-- 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;