Compiler/virtual machine interpreter

From Rosetta Code
Task
Compiler/virtual machine interpreter
You are encouraged to solve this task according to the task description, using any language you may know.
Virtual Machine Interpreter

A virtual machine implements a computer in software.

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

Ada

Works with: GNAT version Community 2021


This program outputs only the standard output, because I did not feel like implementing stream output to a named file. (Text I/O would have appended a newline or some such page-ender to the output.) One does not really need more than standard output for this task.

This Ada program is one of the faster implementations I have written, but you have to turn off runtime checks to get that speed.


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


Output:
$ gnatmake -q -gnatp -O3 -march=native vm.adb && ./vm compiler-tests/count.vm
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

Aime

integer n, pc, sp;
file f;
text s;
index code, Data;
list l, stack, strings;

f.affix(argv(1));

f.list(l, 0);

n = atoi(l[-1]);
while (n) {
    f.lead(s);
    strings.append(erase(s, -1, 0));
    n -= 1;
}

while (f.list(l, 0) ^ -1) {
    code.put(atoi(lf_x_text(l)), l);
}

pc = sp = 0;
while (1) {
    l = code[pc];
    s = l[0];
    if (s == "jz") {
        if (lb_pick(stack)) {
            isk_greater(code, pc, pc);
        } else {
            pc = atoi(l[-1]);
        }
    } elif (s == "jmp") {
        pc = atoi(l[-1]);
    } else {
        if (s == "push") {
            lb_push(stack, atoi(l[1]));
        } elif (s == "fetch") {
            lb_push(stack, Data[atoi(erase(l[1], -1, 0))]);
        } elif (s == "neg") {
            stack[-1] = -stack[-1];
        } elif (s == "not") {
            stack[-1] = !stack[-1];
        } elif (s == "halt") {
            break;
        } else {
            n = lb_pick(stack);
            if (s == "store") {
                Data[atoi(erase(l[1], -1, 0))] = n;
            } elif (s == "add") {
                stack[-1] = stack[-1] + n;
            } elif (s == "sub") {
                stack[-1] = stack[-1] - n;
            } elif (s == "mul") {
                stack[-1] = stack[-1] * n;
            } elif (s == "div") {
                stack[-1] = stack[-1] / n;
            } elif (s == "mod") {
                stack[-1] = stack[-1] % n;
            } elif (s == "lt") {
                stack[-1] = stack[-1] < n;
            } elif (s == "gt") {
                stack[-1] = stack[-1] > n;
            } elif (s == "le") {
                stack[-1] = stack[-1] <= n;
            } elif (s == "ge") {
                stack[-1] = stack[-1] >= n;
            } elif (s == "eq") {
                stack[-1] = stack[-1] == n;
            } elif (s == "ne") {
                stack[-1] = stack[-1] != n;
            } elif (s == "and") {
                stack[-1] = stack[-1] && n;
            } elif (s == "or") {
                stack[-1] = stack[-1] || n;
            } elif (s == "prtc") {
                o_byte(n);
            } elif (s == "prti") {
                o_(n);
            } elif (s == "prts") {
                o_(strings[n]);
            } else {
            }
        }

        isk_greater(code, pc, pc);
    }
}

ALGOL W

begin % virtual machine interpreter %
    % string literals %
    string(256) array stringValue  ( 0 :: 256 );
    integer     array stringLength ( 0 :: 256 );
    integer     MAX_STRINGS;
    % op codes %
    integer     oFetch, oStore, oPush
          ,     oAdd,   oSub,   oMul, oDiv, oMod, oLt, oGt,   oLe,   oGe,   oEq,   oNe
          ,     oAnd,   oOr,    oNeg, oNot, oJmp, oJz, oPrtc, oPrts, oPrti, oHalt
          ;
    string(6)   array opName       ( 1 :: 24 );
    integer     OP_MAX;
    % code %
    string(1)   array byteCode     ( 0 :: 4096 );
    integer     nextLocation, MAX_LOCATION;
    % data %
    integer     array data         ( 0 :: 4096 );
    integer     dataSize, MAX_DATA, MAX_STACK;
    % tracing %
    logical     trace;

    % reports an error and stops %
    procedure rtError( string(80) value message ); begin
        integer errorPos;
        write( s_w := 0, "**** Runtime error: " );
        errorPos := 0;
        while errorPos < 80 and message( errorPos // 1 ) not = "." do begin
            writeon( s_w := 0, message( errorPos // 1 ) );
            errorPos := errorPos + 1
        end while_not_at_end_of_message ;
        writeon( s_w := 0, "." );
        assert( false )
    end genError ;

    oFetch :=  1; opName( oFetch ) := "fetch"; oStore :=  2; opName( oStore ) := "store"; oPush :=  3; opName( oPush ) := "push";
    oAdd   :=  4; opName( oAdd   ) := "add";   oSub   :=  5; opName( oSub   ) := "sub";   oMul  :=  6; opName( oMul  ) := "mul";
    oDiv   :=  7; opName( oDiv   ) := "div";   oMod   :=  8; opName( oMod   ) := "mod";   oLt   :=  9; opName( oLt   ) := "lt";
    oGt    := 10; opName( oGt    ) := "gt";    oLe    := 11; opName( oLe    ) := "le";    oGe   := 12; opName( oGe   ) := "ge";
    oEq    := 13; opName( oEq    ) := "eq";    oNe    := 14; opName( oNe    ) := "ne";    oAnd  := 15; opName( oAnd  ) := "and";
    oOr    := 16; opName( oOr    ) := "or";    oNeg   := 17; opName( oNeg   ) := "neg";   oNot  := 18; opName( oNot  ) := "not";
    oJmp   := 19; opName( oJmp   ) := "jmp";   oJz    := 20; opName( oJz    ) := "jz";    oPrtc := 21; opName( oPrtc ) := "prtc";
    oPrts  := 22; opName( oPrts  ) := "prts";  oPrti  := 23; opName( oPrti  ) := "prti";  oHalt := 24; opName( oHalt ) := "halt";
    OP_MAX := oHalt;

    trace        := false;
    MAX_STACK    := 256;
    MAX_LOCATION := 4096;
    for pc := 0 until MAX_LOCATION do byteCode( pc ) := code( 0 );
    MAX_DATA := 4096;
    for dPos := 0 until MAX_DATA do data( dPos ) := 0;
    MAX_STRINGS := 256;
    for sPos := 0 until MAX_STRINGS do begin
        stringValue(  sPos ) := " ";
        stringLength( sPos ) := 0
    end for_sPos ;

    % load thge output from syntaxc analyser %
    begin % readCode %

        % skips spaces on the source line %
        procedure skipSpaces ; begin
            while line( lPos // 1 ) = " " do lPos := lPos + 1
        end skipSpaces ;

        % parses a string from line and stores it in the string literals table %
        procedure readString ( integer value stringNumber ) ; begin
            string(256) str;
            integer     sLen;
            str  := " ";
            sLen := 0;
            lPos := lPos + 1; % skip the opening double-quote %
            while lPos <= 255 and line( lPos // 1 ) not = """" do begin
                str( sLen // 1 ) := line( lPos // 1 );
                sLen := sLen + 1;
                lPos := lPos + 1
            end while_more_string ;
            if lPos > 255 then rtError( "Unterminated String." );
            % store the string %
            stringValue(  stringNumber ) := str;
            stringLength( stringNumber ) := sLen
        end readString ;

        % gets an integer from the line - checks for valid digits %
        integer procedure readInteger ; begin
            integer n;
            skipSpaces;
            n := 0;
            while line( lPos // 1 ) >= "0" and line( lPos // 1 ) <= "9" do begin
                n    := ( n * 10 ) + ( decode( line( lPos // 1 ) ) - decode( "0" ) );
                lPos := lPos + 1
            end while_not_end_of_integer ;
            n
        end readInteger ;

        % reads the next line from standard input %
        procedure readALine ; begin
            lPos := 0;
            readcard( line );
            if trace then write( s_w := 0, ">> ", line( 0 // 32 ) )
        end readALine ;

        % loads an instruction from the current source line %
        procedure loadCodeFromLine ; begin
            integer pc, opCode, operand, oPos;
            string(256) op;
            logical haveOperand;
            % get the code location %
            pc := readInteger;
            if pc > MAX_LOCATION then rtError( "Code too large." );
            % get the opCode %
            skipSpaces;
            oPos := 0;
            op := " ";
            while lPos <= 255 and line( lPos // 1 ) not = " " do begin
                op( oPos // 1 ) := line( lPos // 1 );
                oPos := oPos + 1;
                lPos := lPos + 1
            end while_more_opName ;
            % lookup the op code %
            opCode := 0;
            oPos   := 1;
            while oPos <= OP_MAX and opCode = 0 do begin
                if opName( oPos ) = op then opCode := oPos
                                       else oPos   := oPos + 1
            end while_op_not_found ;
            if opCode = 0 then rtError( "Unknown op code." );
            % get the operand if there is one %
            operand     := 0;
            haveOperand := false;
            if      opCode = oFetch or opCode = oStore then begin
                % fetch or store - operand is enclosed in square brackets %
                skipSpaces;
                if line( lPos // 1 ) not = "[" then rtError( """["" expected after fetch/store." );
                lPos        := lPos + 1;
                operand     := readInteger;
                if operand > dataSize then rtError( "fetch/store address out of range." );
                haveOperand := true
                end
            else if opCode = oPush then begin
                % push integer literal instruction %
                operand     := readInteger;
                haveOperand := true
                end
            else if opCode = oJmp or opCode = oJz then begin
                % jump - the operand is the relative address enclosed in parenthesis %
                % followed by the absolute address - we use the absolute address so  %
                % the opewrand will be >= 0 %
                skipSpaces;
                if line( lPos // 1 ) not = "(" then rtError( """("" expected after jmp/jz." );
                lPos        := lPos + 1;
                if line( lPos // 1 ) = "-" then % negative relative address % lPos := lPos + 1;
                operand     := readInteger;
                if line( lPos // 1 ) not = ")" then rtError( """)"" expected after jmp/jz." );
                lPos        := lPos + 1;
                operand     := readInteger;
                haveOperand := true
            end if_various_opcodes ;
            % store the code %
            byteCode( pc ) := code( opCode );
            if haveOperand then begin
                % have an operand for the op code %
                if ( pc + 4 ) > MAX_LOCATION then rtError( "Code too large." );
                for oPos := 1 until 4 do begin
                    pc := pc + 1;
                    byteCode( pc ) := code( operand rem 256 );
                    operand := operand div 256;
                end for_oPos
            end if_have_operand ;
        end loadCodeFromLine ;

        string(256) line;
        string(16)  name;
        integer     lPos, tPos, stringCount;

        % allow us to detect EOF %
        ENDFILE := EXCEPTION( false, 1, 0, false, "EOF" );

        % first line should be "Datasize: d Strings: s" where d = number variables %
        % and s = number of strings                                                %
        readALine;
        if line = "trace" then begin
            % extension - run in trace mode %
            trace := true;
            readALine
        end if_line_eq_trace ;
        if XCPNOTED(ENDFILE) then rtError( "Empty program file." );
        if line( 0 // 10 ) not = "Datasize: " then rtError( "Header line missing." );
        lPos := 10;
        dataSize := readInteger;
        if dataSize > MAX_DATA then rtError( "Datasize too large." );
        skipSpaces;
        if line( lPos // 9 ) not = "Strings: " then rtError( """Strings: "" missing on header line." );
        lPos := lPos + 9;
        stringCount := readInteger;
        if stringCount > MAX_STRINGS then rtError( "Too many strings." );
        % read the string table %
        for stringNumber := 0 until stringCount - 1 do begin
            string(256) str;
            integer     sLen, sPos;
            readALine;
            if XCPNOTED(ENDFILE) then rtError( "End-of-file in string table." );
            if line( lPos // 1 ) not = """" then rtError( "String literal expected." );
            str  := " ";
            sLen := 0;
            lPos := lPos + 1; % skip the opening double-quote %
            while lPos <= 255 and line( lPos // 1 ) not = """" do begin
                str( sLen // 1 ) := line( lPos // 1 );
                sLen := sLen + 1;
                lPos := lPos + 1
            end while_more_string ;
            if lPos > 255 then rtError( "Unterminated String." );
            % store the string %
            stringValue(  stringNumber ) := str;
            stringLength( stringNumber ) := sLen
        end for_sPos ;
        % read the code %
        readALine;
        while not XCPNOTED(ENDFILE) do begin
            if line not = " " then loadCodeFromLine;
            readALine
        end while_not_eof
    end;
    % run the program %
    begin
        integer pc, opCode, operand, sp;
        integer array st ( 0 :: MAX_STACK );
        logical halted;
        % prints a string from the string pool, escape sequences are interpreted %
        procedure writeOnString( integer value stringNumber ) ;
        begin
            integer     cPos, sLen;
            string(256) text;
            if stringNumber < 0 or stringNumber > MAX_STRINGS then rtError( "Invalid string number." );
            cPos := 0;
            sLen := stringLength( stringNumber );
            text := stringValue(  stringNumber );
            while cPos < stringLength( stringNumber ) do begin
                string(1) ch;
                ch := text( cPos // 1 );
                if ch not = "\" then writeon( s_w := 0, ch )
                else begin
                    % escaped character %
                    cPos := cPos + 1;
                    if cPos > sLen then rtError( "String terminates with ""\""." );
                    ch := text( cPos // 1 );
                    if ch = "n" then % newline % write()
                                else writeon( s_w := 0, ch )
                end;
                cPos := cPos + 1
            end while_not_end_of_string
        end writeOnString ;

        pc     := 0;
        sp     := -1;
        halted := false;
        while not halted do begin;
            % get the next op code and operand %
            opCode  := decode( byteCode( pc ) );
            pc      := pc + 1;
            operand := 0;
            if opCode = oFetch or opCode = oStore or opCode = oPush or opCode = oJmp or opCode = oJz then begin
                % this opCode has an operand %
                pc := pc + 4;
                for bPos := 1 until 4 do begin
                    operand := ( operand * 256 ) + decode( byteCode( pc - bPos ) );
                end for_bPos
            end if_opCode_with_an_operand ;
            if trace then begin
                write( i_w:= 1, s_w := 0, pc, " op(", opCode, "): ", opName( opCode ), " ", operand );
                write()
            end if_trace ;
            % interpret the instruction %
            if      opCode = oFetch then begin sp := sp + 1; st( sp ) := data( operand ) end
            else if opCode = oStore then begin data( operand ) := st( sp ); sp := sp - 1 end
            else if opCode = oPush  then begin sp := sp + 1; st( sp ) := operand         end
            else if opCode = oHalt  then halted := true
            else if opCode = oJmp   then pc     := operand
            else if oPCode = oJz    then begin
                if st( sp ) = 0 then pc := operand;
                sp := sp - 1
                end
            else if opCode = oPrtc  then begin writeon( i_w := 1, s_w := 0, code( st( sp ) ) ); sp := sp - 1 end
            else if opCode = oPrti  then begin writeon( i_w := 1, s_w := 0,       st( sp )   ); sp := sp - 1 end
            else if opCode = oPrts  then begin writeonString(                     st( sp )   ); sp := sp - 1 end
            else if opCode = oNeg   then st( sp ) := - st( sp )
            else if opCode = oNot   then st( sp ) := ( if st( sp ) = 0 then 1 else 0 )
            else begin
                operand := st( sp );
                sp      := sp - 1;
                if      opCode = oAdd   then st( sp ) :=    st( sp )    +  operand
                else if opCode = oSub   then st( sp ) :=    st( sp )    -  operand
                else if opCode = oMul   then st( sp ) :=    st( sp )    *  operand
                else if opCode = oDiv   then st( sp ) :=    st( sp )  div  operand
                else if opCode = oMod   then st( sp ) :=    st( sp )  rem  operand
                else if opCode = oLt    then st( sp ) := if st( sp )    <  operand then 1 else 0
                else if opCode = oGt    then st( sp ) := if st( sp )    >  operand then 1 else 0
                else if opCode = oLe    then st( sp ) := if st( sp )    <= operand then 1 else 0
                else if opCode = oGe    then st( sp ) := if st( sp )    >= operand then 1 else 0
                else if opCode = oEq    then st( sp ) := if st( sp )     = operand then 1 else 0
                else if opCode = oNe    then st( sp ) := if st( sp ) not = operand then 1 else 0
                else if opCode = oAnd   then st( sp ) := if st( sp ) not = 0 and operand not = 0 then 1 else 0
                else if opCode = oOr    then st( sp ) := if st( sp ) not = 0 or  operand not = 0 then 1 else 0
                else                         rtError( "Unknown opCode." )
            end if_various_opCodes
        end while_not_halted
    end
end.

ATS

Interpreter

Works with: ATS version Postiats 0.4.1

Compile with ‘patscc -O3 -DATS_MEMALLOC_LIBC -o vm vm-postiats.dats -latslib’

With the C optimizer turned on, like this, the program should run pretty fast, despite being relatively safe against going out of bounds, etc. Try it on the ASCII Mandelbrot example.

(Without the C optimizer, ATS code can run much, much more slowly. It is worth comparing the Mandelbrot example with and without the optimizer.)

(*
  Usage: vm [INPUTFILE [OUTPUTFILE]]
     If INPUTFILE or OUTPUTFILE is "-" or missing, then standard input
     or standard output is used, respectively.

  The Rosetta Code virtual machine task in ATS2 (also known as
  Postiats).
  
  Some implementation notes:

    * Values are stored as uint32, and it is checked that uint32
      really is 32 bits, two’s-complement. Addition and subtraction
      are allowed to roll around, and so can be done without casting
      to int32. (The C standard specifies that unsigned integer values
      will roll around, rather than signal an overflow.)

    * Where it matters, the uint32 are stored in little-endian
      order. I have *not* optimized the code for x86/AMD64 (which are
      little-endian and also can address unaligned data).

    * Here I am often writing out code instead of using some library
      function. Partly this is to improve code safety (proof at
      compile-time that buffers are not overrun, proof of loop
      termination, etc.). Partly this is because I do not feel like
      using the C library (or ATS interfaces to it) all that much.

    * I am using linear types and so forth, because I think it
      interesting to do so. It is unnecessary to use a garbage
      collector, because there (hopefully) are no memory leaks. (Not
      that we couldn’t simply let memory leak, for this little program
      with no REPL.)

*)

#define ATS_EXTERN_PREFIX "rosettacode_vm_"
#define ATS_DYNLOADFLAG 0       (* No initialization is needed. *)

#include "share/atspre_define.hats"
#include "share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"

#define NIL list_vt_nil ()
#define :: list_vt_cons

(* The stack has a fixed size but is very large. (Alternatively, one
could make the stack double in size whenever it overflows. Design
options such as using a linked list for the stack come with a
performance penalty.) *)
#define VMSTACK_SIZE 65536
macdef vmstack_size = (i2sz VMSTACK_SIZE)

(* In this program, exceptions are not meant to be caught, unless
   the catcher terminates the program. Linear types and
   general exception-catching do not go together well. *)
exception bad_vm of string
exception vm_runtime_error of string

(********************************************************************)
(*                                                                  *)
(* Some string functions that are safe against buffer overruns.     *)
(*                                                                  *)

fn
skip_whitespace {n, i : int | 0 <= i; i <= n}
                (s    : string n,
                 n    : size_t n,
                 i    : size_t i) :
    [j : int | i <= j; j <= n]
    size_t j =
  let
    fun
    loop {k : int | i <= k; k <= n} .<n - k>.
         (k : size_t k) :
        [j : int | i <= j; j <= n]
        size_t j =
      if k = n then
        k
      else if isspace (s[k]) then
        loop (succ k)
      else
        k
  in
    loop (i)
  end

fn
skip_non_whitespace {n, i : int | 0 <= i; i <= n}
                    (s    : string n,
                     n    : size_t n,
                     i    : size_t i) :
    [j : int | i <= j; j <= n]
    size_t j =
  let
    fun
    loop {k : int | i <= k; k <= n} .<n - k>.
         (k : size_t k) :
        [j : int | i <= j; j <= n]
        size_t j =
      if k = n then
        k
      else if isspace (s[k]) then
        k
      else
        loop (succ k)
  in
    loop (i)
  end

fn
substr_equal {n, i, j : int | 0 <= i; i <= j; j <= n}
             {m       : int | 0 <= m}
             (s       : string n,
              i       : size_t i,
              j       : size_t j,
              t       : string m) : bool =
  (* Is s[i .. j-1] equal to t? *)
  let
    val m = string_length t
  in
    if m <> j - i then
      false
    else
      let
        fun
        loop {k : int | 0 <= k; k <= m} .<m - k>.
             (k : size_t k) : bool =
          if k = m then
            true
          else if s[i + k] <> t[k] then
            false
          else
            loop (succ k)
      in
        loop (i2sz 0)
      end
  end

(********************************************************************)
(*                                                                  *)
(* vmint = 32-bit two’s-complement numbers.                         *)
(*                                                                  *)

stadef vmint_kind = uint32_kind
typedef vmint = uint32

extern castfn i2vm    : int -<> vmint
extern castfn u2vm    : uint -<> vmint
extern castfn byte2vm : byte -<> vmint

extern castfn vm2i    : vmint -<> int
extern castfn vm2sz   : vmint -<> size_t
extern castfn vm2byte : vmint -<> byte

%{^

/*
 * The ATS prelude might not have C implementations of all the
 * operations we would like to have, so here are some.
 */

typedef uint32_t vmint_t;

ATSinline() vmint_t
rosettacode_vm_g0uint_add_vmint (vmint_t x, vmint_t y)
{
  return (x + y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_sub_vmint (vmint_t x, vmint_t y)
{
  return (x - y);
}

ATSinline() int
rosettacode_vm_g0uint_eq_vmint (vmint_t x, vmint_t y)
{
  return (x == y);
}

ATSinline() int
rosettacode_vm_g0uint_neq_vmint (vmint_t x, vmint_t y)
{
  return (x != y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_equality_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) (x == y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_inequality_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) (x != y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_lt_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x < (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_gt_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x > (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_lte_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x <= (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_gte_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x >= (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_mul_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x * (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_div_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x / (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_mod_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x % (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_logical_not_vmint (vmint_t x)
{
  return (vmint_t) (!x);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_logical_and_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((!!x) * (!!y));
}

ATSinline() vmint_t
rosettacode_vm_g0uint_logical_or_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) (1 - ((!x) * (!y)));
}

%}

extern fn g0uint_add_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn g0uint_sub_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn g0uint_eq_vmint (x : vmint, y : vmint) :<> bool = "mac#%"
extern fn g0uint_neq_vmint (x : vmint, y : vmint) :<> bool = "mac#%"

implement g0uint_add<vmint_kind> (x, y) = g0uint_add_vmint (x, y)
implement g0uint_sub<vmint_kind> (x, y) = g0uint_sub_vmint (x, y)
implement g0uint_eq<vmint_kind> (x, y) = g0uint_eq_vmint (x, y)
implement g0uint_neq<vmint_kind> (x, y) = g0uint_neq_vmint (x, y)

extern fn
g0uint_signed_mul_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_div_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_mod_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_equality_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_inequality_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_lt_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_gt_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_lte_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_gte_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_logical_not_vmint (x : vmint) :<> vmint = "mac#%"
extern fn
g0uint_logical_and_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_logical_or_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"

overload signed_mul with g0uint_signed_mul_vmint
overload signed_div with g0uint_signed_div_vmint
overload signed_mod with g0uint_signed_mod_vmint
overload equality with g0uint_equality_vmint
overload inequality with g0uint_inequality_vmint
overload signed_lt with g0uint_signed_lt_vmint
overload signed_gt with g0uint_signed_gt_vmint
overload signed_lte with g0uint_signed_lte_vmint
overload signed_gte with g0uint_signed_gte_vmint
overload logical_not with g0uint_logical_not_vmint
overload logical_and with g0uint_logical_and_vmint
overload logical_or with g0uint_logical_or_vmint

fn {}
twos_complement (x : vmint) :<>
    vmint =
  (~x) + i2vm 1

fn
ensure_that_vmint_is_suitable () : void =
  {
    val _ = assertloc (u2vm (0xFFFFFFFFU) + u2vm 1U = u2vm 0U)
    val _ = assertloc (u2vm 0U - u2vm 1U = u2vm (0xFFFFFFFFU))
    val _ = assertloc (i2vm (~1234) = twos_complement (i2vm 1234))
  }

fn
parse_digits {n, i, j : int | 0 <= i; i <= j; j <= n}
             (s       : string n,
              i       : size_t i,
              j       : size_t j) :
    vmint =
  let
    val bad_integer = "Bad integer."
    fun
    loop {k : int | i <= k; k <= j} .<j - k>.
         (k : size_t k,
          x : vmint) : vmint =
      if k = j then
        x
      else if ~isdigit (s[k]) then
        $raise bad_vm (bad_integer)
      else
        (* The result is allowed to overflow freely. *)
        loop (succ k, (i2vm 10 * x) + i2vm (char2i s[k] - char2i '0'))
  in
    if j = i then
      $raise bad_vm (bad_integer)
    else
      loop (i, i2vm 0)
  end

fn
parse_integer {n, i, j : int | 0 <= i; i <= j; j <= n}
              (s       : string n,
               i       : size_t i,
               j       : size_t j) :
    vmint =
  let
    val bad_integer = "Bad integer."
  in
    if j = i then
      $raise bad_vm (bad_integer)
    else if j = succ i && ~isdigit (s[i]) then
      $raise bad_vm (bad_integer)
    else if s[i] <> '-' then
      parse_digits (s, i, j)
    else if succ i = j then
      $raise bad_vm (bad_integer)
    else
      twos_complement (parse_digits (s, succ i, j))
  end

(********************************************************************)
(*                                                                  *)
(* A linear array type for elements of vmint, byte, etc.            *)
(*                                                                  *)

vtypedef vmarray_vt (t : t@ype+, n : int, p : addr) =
  @{
    pf = @[t][n] @ p,
    pfgc = mfree_gc_v p |
    n = size_t n,
    p = ptr p
  }
vtypedef vmarray_vt (t : t@ype+, n : int) =
  [p : addr] vmarray_vt (t, n, p)

fn {t : t@ype}
vmarray_vt_alloc {n    : int}
                 (n    : size_t n,
                  fill : t) :
    [p : addr | null < p]
    vmarray_vt (t, n, p) =
  let
    val @(pf, pfgc | p) = array_ptr_alloc<t> (n)
    val _ = array_initize_elt (!p, n, fill)
  in
    @{
      pf = pf,
      pfgc = pfgc |
      n = n,
      p = p
    }
  end

fn {t : t@ype}
vmarray_vt_free {n   : int}
                {p   : addr}
                (arr : vmarray_vt (t, n, p)) :
    void =
  let
    val @{
          pf = pf,
          pfgc = pfgc |
          n = n,
          p = p
        } = arr
  in
    array_ptr_free (pf, pfgc | p)
  end

fn {t : t@ype}
vmarray_vt_fill {n    : int}
                {p    : addr}
                (arr  : !vmarray_vt (t, n, p),
                 fill : t) :
    void =
  array_initize_elt (!(arr.p), (arr.n), fill)

fn {t  : t@ype}
   {tk : tkind}
vmarray_vt_get_at_g1int {n, i : int | 0 <= i; i < n}
                        (arr  : !vmarray_vt (t, n),
                         i    : g1int (tk, i)) :
    t =
  array_get_at (!(arr.p), i)

fn {t  : t@ype}
   {tk : tkind}
vmarray_vt_get_at_g1uint {n, i : int | 0 <= i; i < n}
                         (arr  : !vmarray_vt (t, n),
                          i    : g1uint (tk, i)) :
    t =
  array_get_at (!(arr.p), i)

overload [] with vmarray_vt_get_at_g1int
overload [] with vmarray_vt_get_at_g1uint

fn {t  : t@ype}
   {tk : tkind}
vmarray_vt_set_at_g1int {n, i : int | 0 <= i; i < n}
                        (arr  : !vmarray_vt (t, n),
                         i    : g1int (tk, i),
                         x    : t) :
    void =
  array_set_at (!(arr.p), i, x)

fn {t  : t@ype}
   {tk : tkind}
vmarray_vt_set_at_g1uint {n, i : int | 0 <= i; i < n}
                         (arr  : !vmarray_vt (t, n),
                          i    : g1uint (tk, i),
                          x    : t) :
    void =
  array_set_at (!(arr.p), i, x)

overload [] with vmarray_vt_set_at_g1int
overload [] with vmarray_vt_set_at_g1uint

fn {t : t@ype}
vmarray_vt_length {n   : int}
                  (arr : !vmarray_vt (t, n)) :<>
    size_t n =
  arr.n

(********************************************************************)
(*                                                                  *)
(* Storage for the strings section.                                 *)
(*                                                                  *)

vtypedef vmstring_vt (n : int, p : addr) =
  @{
    (* A vmstring_vt is NUL-terminated, and thus there is [n + 1]
       instead of [n] in the following declaration. *)
    pf = @[char][n + 1] @ p,
    pfgc = mfree_gc_v p |
    length = size_t n,
    p = ptr p
  }
vtypedef vmstring_vt (n : int) = [p : addr] vmstring_vt (n, p)
vtypedef vmstring_vt = [n : int | 0 <= n] vmstring_vt (n)

vtypedef vmstrings_section_vt (n : int, p : addr) =
  @{
    pf = @[vmstring_vt][n] @ p,
    pfgc = mfree_gc_v p |
    n = size_t n,
    p = ptr p
  }
vtypedef vmstrings_section_vt (n : int) =
  [p : addr] vmstrings_section_vt (n, p)

fn {t : t@ype}
vmstrings_section_vt_length {n   : int}
                            (arr : !vmstrings_section_vt (n)) :<>
    size_t n =
  arr.n

fn
vmstring_vt_free {n : int}
                 {p : addr}
                 (s : vmstring_vt (n, p)) :
    void =
  array_ptr_free (s.pf, s.pfgc | s.p)

fn
vmstrings_section_vt_free {n       : int}
                          {p       : addr}
                          (strings : vmstrings_section_vt (n, p)) :
    void =
  {
    fun
    free_the_strings {n  : int | 0 <= n}
                     {p  : addr} .<n>.
                     (pf : !(@[vmstring_vt][n] @ p) >>
                              @[vmstring_vt?][n] @ p |
                      n  : size_t n,
                      p  : ptr p) : void =
      if n = 0 then
        {
          prval _ = pf :=
            array_v_unnil_nil {vmstring_vt, vmstring_vt?} pf
        }
      else
        {
          prval @(pf_element, pf_rest) = array_v_uncons pf
          val _ = vmstring_vt_free (!p)
          val p_next = ptr_succ<vmstring_vt> (p)
          val _ = free_the_strings (pf_rest | pred n, p_next)
          prval _ = pf := array_v_cons (pf_element, pf_rest)
        }

    val @{
          pf = pf,
          pfgc = pfgc |
          n = n,
          p = p
        } = strings
    prval _ = lemma_g1uint_param n
    val _ = free_the_strings (pf | n, p)
    val _ = array_ptr_free (pf, pfgc | p)
  }

fn
quoted_string_length {n : int | 0 <= n}
                     (s : string n,
                      n : size_t n) :
    [m : int | 0 <= m; m <= n - 2]
    size_t m =
  let
    val bad_quoted_string = "Bad quoted string."

    fun
    loop {i : int | 1 <= i; i <= n - 1}
         {j : int | 0 <= j; j <= i - 1} .<n - i>.
         (i : size_t i,
          j : size_t j) :
        [k : int | 0 <= k; k <= n - 2]
        size_t k =
      if i = pred n then
        j
      else if s[i] <> '\\' then
        loop (succ i, succ j)
      else if succ i = pred n then
        $raise bad_vm (bad_quoted_string)
      else if s[succ i] = 'n' || s[succ i] = '\\' then
        loop (succ (succ i), succ j)
      else
        $raise bad_vm (bad_quoted_string)
  in
    if n < i2sz 2 then
      $raise bad_vm (bad_quoted_string)
    else if s[0] <> '"' then
      $raise bad_vm (bad_quoted_string)
    else if s[pred n] <> '"' then
      $raise bad_vm (bad_quoted_string)
    else    
      loop (i2sz 1, i2sz 0)
  end

fn
dequote_string {m, n : int | 0 <= m; m <= n - 2}
               (s : string n,
                n : size_t n,
                t : !vmstring_vt m) :
    void =
  let
    fun
    loop {i : int | 1 <= i; i <= n - 1}
         {j : int | 0 <= j; j <= i - 1} .<n - i>.
         (t : !vmstring_vt m,
          i : size_t i,
          j : size_t j) : void =
      let
        macdef t_str = !(t.p)
      in
        if i = pred n then
          ()
        else if (t.length) < j then
          assertloc (false)
        else if s[i] <> '\\' then
          begin
            t_str[j] := s[i];
            loop (t, succ i, succ j)
          end
        else if succ i = pred n then
          assertloc (false)
        else if s[succ i] = 'n' then
          begin
            t_str[j] := '\n';
            loop (t, succ (succ i), succ j)
          end
        else
          begin
            t_str[j] := s[succ i];
            loop (t, succ (succ i), succ j)
          end
      end
  in
    loop (t, i2sz 1, i2sz 0)
  end        

fn
read_vmstrings {strings_size : int}
               {strings_addr : addr}
               (pf_strings   :
                    !(@[vmstring_vt?][strings_size] @ strings_addr) >>
                        @[vmstring_vt][strings_size] @ strings_addr |
                f            : FILEref,
                strings_size : size_t strings_size,
                strings      : ptr strings_addr) :
    void =
  let
    prval _ = lemma_g1uint_param strings_size

    fun
    loop {k   : int | 0 <= k; k <= strings_size} .<strings_size - k>.
         (lst : list_vt (vmstring_vt, k),
          k   : size_t k) :
        list_vt (vmstring_vt, strings_size) =
      if k = strings_size then
        list_vt_reverse (lst)
      else
        let
          val bad_quoted_string = "Bad quoted string."
          val line = fileref_get_line_string (f)
          val s = $UN.strptr2string (line)
          val n = string_length s
              val str_length = quoted_string_length (s, n)
          val (pf, pfgc | p) =
            array_ptr_alloc<char> (succ str_length)
          val _ = array_initize_elt (!p, succ str_length, '\0')
          val vmstring =
            @{
              pf = pf,
              pfgc = pfgc |
              length = str_length,
              p = p
            }
        in
          dequote_string (s, n, vmstring);
          free line;
          loop (vmstring :: lst, succ k)
        end

    val lst = loop (NIL, i2sz 0)
  in
    array_initize_list_vt<vmstring_vt>
      (!strings, sz2i strings_size, lst)
  end

fn
vmstrings_section_vt_read {strings_size : int}
                          (f            : FILEref,
                           strings_size : size_t strings_size) :
    [p : addr]
    vmstrings_section_vt (strings_size, p) =
  let
    val @(pf, pfgc | p) = array_ptr_alloc<vmstring_vt> strings_size
    val _ = read_vmstrings (pf | f, strings_size, p)
  in
    @{
      pf = pf,
      pfgc = pfgc |
      n = strings_size,
      p = p
    }
  end

fn
vmstring_fprint {n, i    : int | i < n}
                (f       : FILEref,
                 strings : !vmstrings_section_vt n,
                 i       : size_t i) :
    void =
  {

    (*
     * The following code does some ‘unsafe’ tricks. For instance, it
     * is assumed each stored string is NUL-terminated.
     *)

    fn
    print_it (str : !vmstring_vt) : void =
      fileref_puts (f, $UN.cast{string} (str.p))

    prval _ = lemma_g1uint_param i
    val p_element = array_getref_at (!(strings.p), i)
    val @(pf_element | p_element) =
      $UN.castvwtp0
        {[n : int; p : addr] @(vmstring_vt @ p | ptr p)}
        (p_element)
    val _ = print_it (!p_element)
    prval _ = $UN.castview0{void} pf_element
  }

(********************************************************************)
(*                                                                  *)
(* vm_vt: the dataviewtype for a virtual machine.                   *)
(*                                                                  *)

datavtype instruction_vt =
| instruction_vt_1 of (byte)
| instruction_vt_5 of (byte, byte, byte, byte, byte)

#define OPCODE_COUNT 24

#define OP_HALT    0x0000  // 00000
#define OP_ADD     0x0001  // 00001
#define OP_SUB     0x0002  // 00010
#define OP_MUL     0x0003  // 00011
#define OP_DIV     0x0004  // 00100
#define OP_MOD     0x0005  // 00101
#define OP_LT      0x0006  // 00110
#define OP_GT      0x0007  // 00111
#define OP_LE      0x0008  // 01000
#define OP_GE      0x0009  // 01001
#define OP_EQ      0x000A  // 01010
#define OP_NE      0x000B  // 01011
#define OP_AND     0x000C  // 01100
#define OP_OR      0x000D  // 01101
#define OP_NEG     0x000E  // 01110
#define OP_NOT     0x000F  // 01111
#define OP_PRTC    0x0010  // 10000
#define OP_PRTI    0x0011  // 10001
#define OP_PRTS    0x0012  // 10010
#define OP_FETCH   0x0013  // 10011
#define OP_STORE   0x0014  // 10100
#define OP_PUSH    0x0015  // 10101
#define OP_JMP     0x0016  // 10110
#define OP_JZ      0x0017  // 10111

#define REGISTER_PC 0
#define REGISTER_SP 1
#define MAX_REGISTER REGISTER_SP

vtypedef vm_vt (strings_size : int,
                strings_addr : addr,
                code_size    : int,
                code_addr    : addr,
                data_size    : int,
                data_addr    : addr,
                stack_size   : int,
                stack_addr   : addr) =
  @{
    strings = vmstrings_section_vt (strings_size, strings_addr),
    code = vmarray_vt (byte, code_size, code_addr),
    data = vmarray_vt (vmint, data_size, data_addr),
    stack = vmarray_vt (vmint, stack_size, stack_addr),
    registers = vmarray_vt (vmint, MAX_REGISTER + 1)
  }

vtypedef vm_vt (strings_size : int,
                code_size    : int,
                data_size    : int,
                stack_size   : int) =
  [strings_addr : addr]
  [code_addr    : addr]
  [data_addr    : addr]
  [stack_addr   : addr]
  vm_vt (strings_size, strings_addr,
         code_size, code_addr,
         data_size, data_addr,
         stack_size, stack_addr)

vtypedef vm_vt =
  [strings_size : int]
  [code_size    : int]
  [data_size    : int]
  [stack_size   : int]
  vm_vt (strings_size, code_size, data_size, stack_size)

fn
vm_vt_free (vm : vm_vt) :
    void =
  let
    val @{
          strings = strings,
          code = code,
          data = data,
          stack = stack,
          registers = registers
        } = vm
  in
    vmstrings_section_vt_free strings;
    vmarray_vt_free<byte> code;
    vmarray_vt_free<vmint> data;
    vmarray_vt_free<vmint> stack;
    vmarray_vt_free<vmint> registers
  end

fn
opcode_name_to_byte {n, i, j : int | 0 <= i; i <= j; j <= n}
                    (arr : &(@[String0][OPCODE_COUNT]),
                     str : string n,
                     i   : size_t i,
                     j   : size_t j) :
    byte =
  let
    fun
    loop {k   : int | 0 <= k; k <= OPCODE_COUNT} .<OPCODE_COUNT - k>.
         (arr : &(@[String0][OPCODE_COUNT]),
          k   : int k) : byte =
      if k = OPCODE_COUNT then
        $raise bad_vm ("Unrecognized opcode name.")
      else if substr_equal (str, i, j, arr[k]) then
        i2byte k
      else
        loop (arr, succ k)
  in
    loop (arr, 0)
  end

fn {}
vmint_byte0 (i : vmint) :<>
    byte =
  vm2byte (i land (u2vm 0xFFU))

fn {}
vmint_byte1 (i : vmint) :<>
    byte =
  vm2byte ((i >> 8) land (u2vm 0xFFU))

fn {}
vmint_byte2 (i : vmint) :<>
    byte =
  vm2byte ((i >> 16) land (u2vm 0xFFU))

fn {}
vmint_byte3 (i : vmint) :<>
    byte =
  vm2byte (i >> 24)

fn
parse_instruction {n    : int | 0 <= n}
                  (arr  : &(@[String0][OPCODE_COUNT]),
                   line : string n) :
    instruction_vt =
  let
    val bad_instruction = "Bad VM instruction."
    val n = string_length (line)
    val i = skip_whitespace (line, n, i2sz 0)

    (* Skip the address field*)
    val i = skip_non_whitespace (line, n, i)

    val i = skip_whitespace (line, n, i)
    val j = skip_non_whitespace (line, n, i)
    val opcode = opcode_name_to_byte (arr, line, i, j)

    val start_of_argument = j

    fn
    finish_push () :
        instruction_vt =
      let
        val i1 = skip_whitespace (line, n, start_of_argument)
        val j1 = skip_non_whitespace (line, n, i1)
        val arg = parse_integer (line, i1, j1)
      in
        (* Little-endian storage. *)
        instruction_vt_5 (opcode, vmint_byte0 arg, vmint_byte1 arg,
                          vmint_byte2 arg, vmint_byte3 arg)
      end

    fn
    finish_fetch_or_store () :
        instruction_vt =
      let
        val i1 = skip_whitespace (line, n, start_of_argument)
        val j1 = skip_non_whitespace (line, n, i1)
      in
        if j1 - i1 < i2sz 3 then
          $raise bad_vm (bad_instruction)
        else if line[i1] <> '\[' || line[pred j1] <> ']' then
          $raise bad_vm (bad_instruction)
        else
          let
            val arg = parse_integer (line, succ i1, pred j1)
          in
            (* Little-endian storage. *)
            instruction_vt_5 (opcode, vmint_byte0 arg, vmint_byte1 arg,
                              vmint_byte2 arg, vmint_byte3 arg)
          end
      end

    fn
    finish_jmp_or_jz () :
        instruction_vt =
      let
        val i1 = skip_whitespace (line, n, start_of_argument)
        val j1 = skip_non_whitespace (line, n, i1)
      in
        if j1 - i1 < i2sz 3 then
          $raise bad_vm (bad_instruction)
        else if line[i1] <> '\(' || line[pred j1] <> ')' then
          $raise bad_vm (bad_instruction)
        else
          let
            val arg = parse_integer (line, succ i1, pred j1)
          in
            (* Little-endian storage. *)
            instruction_vt_5 (opcode, vmint_byte0 arg, vmint_byte1 arg,
                              vmint_byte2 arg, vmint_byte3 arg)
          end
      end
  in
    case+ byte2int0 opcode of
    | OP_PUSH => finish_push ()
    | OP_FETCH => finish_fetch_or_store ()
    | OP_STORE => finish_fetch_or_store ()
    | OP_JMP => finish_jmp_or_jz ()
    | OP_JZ => finish_jmp_or_jz ()
    | _ => instruction_vt_1 (opcode)
  end

fn
read_instructions (f   : FILEref,
                   arr : &(@[String0][OPCODE_COUNT])) :
    (List_vt (instruction_vt), Size_t) =
  (* Read the instructions from the input, producing a list of
     instruction_vt objects, and also calculating the total
     number of bytes in the instructions. *)
  let
    fun
    loop (arr          : &(@[String0][OPCODE_COUNT]),
          lst          : List_vt (instruction_vt),
          bytes_needed : Size_t) :
        @(List_vt (instruction_vt), Size_t) =
      if fileref_is_eof f then
        @(list_vt_reverse lst, bytes_needed)
      else
        let
          val line = fileref_get_line_string (f)
        in
          if fileref_is_eof f then
            begin
              free line;
              @(list_vt_reverse lst, bytes_needed)
            end
          else
            let
              val instruction =
                parse_instruction (arr, $UN.strptr2string line)
              val _ = free line
              prval _ = lemma_list_vt_param lst
            in
              case+ instruction of
              | instruction_vt_1 _ =>
                loop (arr, instruction :: lst, bytes_needed + i2sz 1)
              | instruction_vt_5 _ =>
                loop (arr, instruction :: lst, bytes_needed + i2sz 5)
            end
        end
  in
    loop (arr, NIL, i2sz 0)
  end

fn
list_of_instructions_to_code {bytes_needed : int}
                             (lst          : List_vt (instruction_vt),
                              bytes_needed : size_t bytes_needed) :
    [bytes_needed : int]
    vmarray_vt (byte, bytes_needed) =
  (* This routine consumes and destroys lst. *)
  let
    fun
    loop {n    : int | 0 <= n} .<n>.
         (code : &vmarray_vt (byte, bytes_needed),
          lst  : list_vt (instruction_vt, n),
          i    : Size_t) : void =
      case+ lst of
      | ~ NIL => ()
      | ~ head :: tail =>
        begin
          case head of
          | ~ instruction_vt_1 (byte1) =>
            let
              val _ = assertloc (i < bytes_needed)
            in
              code[i] := byte1;
              loop (code, tail, i + i2sz 1)
            end
          | ~ instruction_vt_5 (byte1, byte2, byte3, byte4, byte5) =>
            let
              val _ = assertloc (i + i2sz 4 < bytes_needed)
            in
              code[i] := byte1;
              code[i + i2sz 1] := byte2;
              code[i + i2sz 2] := byte3;
              code[i + i2sz 3] := byte4;
              code[i + i2sz 4] := byte5;
              loop (code, tail, i + i2sz 5)
            end
        end

    var code = vmarray_vt_alloc<byte> (bytes_needed, i2byte OP_HALT)

    prval _ = lemma_list_vt_param lst
    prval _ = lemma_g1uint_param bytes_needed
    val _ = loop (code, lst, i2sz 0)
  in
    code
  end

fn
read_and_parse_code (f   : FILEref,
                     arr : &(@[String0][OPCODE_COUNT])) :
    [bytes_needed : int]
    vmarray_vt (byte, bytes_needed) =
  let
    val @(instructions, bytes_needed) = read_instructions (f, arr)
  in
    list_of_instructions_to_code (instructions, bytes_needed)
  end

fn
parse_header_line {n    : int | 0 <= n}
                  (line : string n) :
    @(vmint, vmint) =
  let
    val bad_vm_header_line = "Bad VM header line."
    val n = string_length (line)
    val i = skip_whitespace (line, n, i2sz 0)
    val j = skip_non_whitespace (line, n, i)
    val _ = if ~substr_equal (line, i, j, "Datasize:") then
              $raise bad_vm (bad_vm_header_line)
    val i = skip_whitespace (line, n, j)
    val j = skip_non_whitespace (line, n, i)
    val data_size = parse_integer (line, i, j)
    val i = skip_whitespace (line, n, j)
    val j = skip_non_whitespace (line, n, i)
    val _ = if ~substr_equal (line, i, j, "Strings:") then
              $raise bad_vm (bad_vm_header_line)
    val i = skip_whitespace (line, n, j)
    val j = skip_non_whitespace (line, n, i)
    val strings_size = parse_integer (line, i, j)
  in
    @(data_size, strings_size)
  end

fn
read_vm (f                : FILEref,
         opcode_names_arr : &(@[String0][OPCODE_COUNT])) :
    vm_vt =
  let
    val line = fileref_get_line_string (f)

    val @(data_size, strings_size) =
      parse_header_line ($UN.strptr2string line)

    val _ = free line

    val [data_size : int] data_size =
      g1ofg0 (vm2sz data_size)
    val [strings_size : int] strings_size =
      g1ofg0 (vm2sz strings_size)

    prval _ = lemma_g1uint_param data_size
    prval _ = lemma_g1uint_param strings_size

    prval _ = prop_verify {0 <= data_size} ()
    prval _ = prop_verify {0 <= strings_size} ()

    val strings = vmstrings_section_vt_read (f, strings_size)
    val code = read_and_parse_code (f, opcode_names_arr)
    val data = vmarray_vt_alloc<vmint> (data_size, i2vm 0)
    val stack = vmarray_vt_alloc<vmint> (vmstack_size, i2vm 0)
    val registers = vmarray_vt_alloc<vmint> (i2sz (MAX_REGISTER + 1),
                                             i2vm 0)
  in
    @{
      strings = strings,
      code = code,
      data = data,
      stack = stack,
      registers = registers
    }
  end

fn {}
pop (vm : &vm_vt) :
    vmint =
  let
    macdef registers = vm.registers
    macdef stack = vm.stack
    val sp_before = registers[REGISTER_SP]
  in
    if sp_before = i2vm 0 then
      $raise vm_runtime_error ("Stack underflow.")
    else
      let
        val sp_after = sp_before - i2vm 1
        val _ = registers[REGISTER_SP] := sp_after
        val i = g1ofg0 (vm2sz sp_after)

        (* What follows is a runtime assertion that the upper stack
           boundary is not gone past, even though it certainly will
           not. This is necessary (assuming one does not use something
           such as $UN.prop_assert) because the stack pointer is a
           vmint, whose bounds cannot be proven at compile time.

           If you comment out the assertloc, the program will not pass
           typechecking.

           Compilers for many other languages will just insert such
           checks willy-nilly, leading programmers to turn off such
           instrumentation in the very code they provide to users.

           One might be tempted to use Size_t instead for the stack
           pointer, but what if the instruction set were later
           augmented with ways to read from or write into the stack
           pointer? *)
          val _ = assertloc (i < vmarray_vt_length stack)
      in
        stack[i]
      end
  end

fn {}
push (vm : &vm_vt,
      x  : vmint) :
    void =
  let
    macdef registers = vm.registers
    macdef stack = vm.stack
    val sp_before = registers[REGISTER_SP]
    val i = g1ofg0 (vm2sz sp_before)
  in
    if vmarray_vt_length stack <= i then
      $raise vm_runtime_error ("Stack overflow.")
    else
      let
        val sp_after = sp_before + i2vm 1
      in
        registers[REGISTER_SP] := sp_after;
        stack[i] := x
      end
  end

fn {}
fetch_data (vm    : &vm_vt,
            index : vmint) :
    vmint =
  let
    macdef data = vm.data
    val i = g1ofg0 (vm2sz index)
  in
    if vmarray_vt_length data <= i then
      $raise vm_runtime_error ("Fetch from outside the data section.")
    else
      data[i]
  end

fn {}
store_data (vm    : &vm_vt,
            index : vmint,
            x     : vmint) :
    void =
  let
    macdef data = vm.data
    val i = g1ofg0 (vm2sz index)
  in
    if vmarray_vt_length data <= i then
      $raise vm_runtime_error ("Store to outside the data section.")
    else
      data[i] := x
  end

fn {}
get_argument (vm : &vm_vt) :
    vmint =
  let
    macdef code = vm.code
    macdef registers = vm.registers
    val pc = registers[REGISTER_PC]
    val i = g1ofg0 (vm2sz pc)
  in
    if vmarray_vt_length code <= i + i2sz 4 then
      $raise (vm_runtime_error
                ("The program counter is out of bounds."))
    else
      let
        (* The data is stored little-endian. *)
        val byte0 = byte2vm code[i]
        val byte1 = byte2vm code[i + i2sz 1]
        val byte2 = byte2vm code[i + i2sz 2]
        val byte3 = byte2vm code[i + i2sz 3]
      in
        (byte0) lor (byte1 << 8) lor (byte2 << 16) lor (byte3 << 24)
      end      
  end

fn {}
skip_argument (vm : &vm_vt) :
    void =
  let
    macdef registers = vm.registers
    val pc = registers[REGISTER_PC]
  in
    registers[REGISTER_PC] := pc + i2vm 4
  end

extern fun {}
unary_operation$inner : vmint -<> vmint
fn {}
unary_operation (vm : &vm_vt) :
    void =
  let
    macdef registers = vm.registers
    macdef stack = vm.stack
    val sp = registers[REGISTER_SP]
    val i = g1ofg0 (vm2sz (sp))
    prval _ = lemma_g1uint_param i
  in
    if i = i2sz 0 then
      $raise vm_runtime_error ("Stack underflow.")
    else
      let
        val _ = assertloc (i < vmarray_vt_length stack)

        (* The actual unary operation is inserted here during
           template expansion. *)
        val result = unary_operation$inner<> (stack[i - 1])
      in
        stack[i - 1] := result
      end
  end

extern fun {}
binary_operation$inner : (vmint, vmint) -<> vmint
fn {}
binary_operation (vm : &vm_vt) :
    void =
  let
    macdef registers = vm.registers
    macdef stack = vm.stack
    val sp_before = registers[REGISTER_SP]
    val i = g1ofg0 (vm2sz (sp_before))
    prval _ = lemma_g1uint_param i
  in
    if i <= i2sz 1 then
      $raise vm_runtime_error ("Stack underflow.")
    else
      let
        val _ = registers[REGISTER_SP] := sp_before - i2vm 1
        val _ = assertloc (i < vmarray_vt_length stack)

        (* The actual binary operation is inserted here during
           template expansion. *)
        val result =
          binary_operation$inner<> (stack[i - 2], stack[i - 1])
      in
        stack[i - 2] := result
      end
  end

fn {}
uop_neg (vm : &vm_vt) :
    void =
  let
    implement {}
    unary_operation$inner (x) =
      twos_complement x
  in
    unary_operation (vm)
  end

fn {}
uop_not (vm : &vm_vt) :
    void =
  let
    implement {}
    unary_operation$inner (x) =
      logical_not x
  in
    unary_operation (vm)
  end

fn {}
binop_add (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x + y
  in
    binary_operation (vm)
  end

fn {}
binop_sub (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x - y
  in
    binary_operation (vm)
  end

fn {}
binop_mul (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_mul y
  in
    binary_operation (vm)
  end

fn {}
binop_div (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_div y
  in
    binary_operation (vm)
  end

fn {}
binop_mod (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_mod y
  in
    binary_operation (vm)
  end

fn {}
binop_eq (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \equality y
  in
    binary_operation (vm)
  end

fn {}
binop_ne (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \inequality y
  in
    binary_operation (vm)
  end

fn {}
binop_lt (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_lt y
  in
    binary_operation (vm)
  end

fn {}
binop_gt (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_gt y
  in
    binary_operation (vm)
  end

fn {}
binop_le (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_lte y
  in
    binary_operation (vm)
  end

fn {}
binop_ge (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_gte y
  in
    binary_operation (vm)
  end

fn {}
binop_and (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \logical_and y
  in
    binary_operation (vm)
  end

fn {}
binop_or (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \logical_or y
  in
    binary_operation (vm)
  end

fn {}
do_push (vm : &vm_vt) :
    void =
  let
    val arg = get_argument (vm)
  in
    push (vm, arg);
    skip_argument (vm)
  end

fn {}
do_fetch (vm : &vm_vt) :
    void =
  let
    val i = get_argument (vm)
    val x = fetch_data (vm, i)
  in
    push (vm, x);
    skip_argument (vm)
  end

fn {}
do_store (vm : &vm_vt) :
    void =
  let
    val i = get_argument (vm)
    val x = pop (vm)
  in
    store_data (vm, i, x);
    skip_argument (vm)
  end

fn {}
do_jmp (vm : &vm_vt) :
    void =
  let
    macdef registers = vm.registers
    val arg = get_argument (vm)
    val pc = registers[REGISTER_PC]
  in
    registers[REGISTER_PC] := pc + arg
  end

fn {}
do_jz (vm : &vm_vt) :
    void =
  let
    val x = pop (vm)
  in
    if x = i2vm 0 then
      do_jmp (vm)
    else
      skip_argument (vm)
  end

fn {}
do_prtc (f_output : FILEref,
         vm       : &vm_vt) :
    void =
  let
    val x = pop (vm)
  in
    fileref_putc (f_output, vm2i x)
  end

fn {}
do_prti (f_output : FILEref,
         vm       : &vm_vt) :
    void =
  let
    val x = pop (vm)
  in
    fprint! (f_output, vm2i x)
  end

fn {}
do_prts (f_output : FILEref,
         vm       : &vm_vt) :
    void =
  let
    val i = g1ofg0 (vm2sz (pop (vm)))
  in
    if vmstrings_section_vt_length (vm.strings) <= i then
      $raise vm_runtime_error ("String index out of bounds.")
    else
      vmstring_fprint (f_output, vm.strings, i)
  end

fn
vm_step (f_output     : FILEref,
         vm           : &vm_vt,
         machine_halt : &bool,
         bad_opcode   : &bool) :
    void =
  let
    macdef code = vm.code
    macdef registers = vm.registers

    val pc = registers[REGISTER_PC]

    val i = g1ofg0 (vm2sz (pc))
    prval _ = lemma_g1uint_param i
  in
    if vmarray_vt_length (code) <= i then
      $raise (vm_runtime_error
                ("The program counter is out of bounds."))
    else
      let
        val _ = registers[REGISTER_PC] := pc + i2vm 1

        val opcode = code[i]
        val u_opcode = byte2uint0 opcode
      in
        (* Dispatch by bifurcation on the bit pattern of the
           opcode. This method is logarithmic in the number
           of opcode values. *)
        machine_halt := false;
        bad_opcode := false;
        if (u_opcode land (~(0x1FU))) = 0U then
          begin
            if (u_opcode land 0x10U) = 0U then
              begin
                if (u_opcode land 0x08U) = 0U then
                  begin
                    if (u_opcode land 0x04U) = 0U then
                      begin
                        if (u_opcode land 0x02U) = 0U then
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              (* OP_HALT *)
                              machine_halt := true
                            else
                              binop_add (vm)
                          end
                        else
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              binop_sub (vm)
                            else
                              binop_mul (vm)
                          end
                      end
                    else
                      begin
                        if (u_opcode land 0x02U) = 0U then
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              binop_div (vm)
                            else
                              binop_mod (vm)
                          end
                        else
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              binop_lt (vm)
                            else
                              binop_gt (vm)
                          end
                      end
                  end
                else
                  begin
                    if (u_opcode land 0x04U) = 0U then
                      begin
                        if (u_opcode land 0x02U) = 0U then
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              binop_le (vm)
                            else
                              binop_ge (vm)
                          end
                        else
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              binop_eq (vm)
                            else
                              binop_ne (vm)
                          end
                      end
                    else
                      begin
                        if (u_opcode land 0x02U) = 0U then
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              binop_and (vm)
                            else
                              binop_or (vm)
                          end
                        else
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              uop_neg (vm)
                            else
                              uop_not (vm)
                          end
                      end
                  end
              end
            else
              begin
                if (u_opcode land 0x08U) = 0U then
                  begin
                    if (u_opcode land 0x04U) = 0U then
                      begin
                        if (u_opcode land 0x02U) = 0U then
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              do_prtc (f_output, vm)
                            else
                              do_prti (f_output, vm)
                          end
                        else
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              do_prts (f_output, vm)
                            else
                              do_fetch (vm)
                          end
                      end
                    else
                      begin
                        if (u_opcode land 0x02U) = 0U then
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              do_store (vm)
                            else
                              do_push (vm)
                          end
                        else
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              do_jmp (vm)
                            else
                              do_jz (vm)
                          end
                      end
                  end
                else
                  bad_opcode := true
              end
          end
        else
          bad_opcode := true
      end
  end

fn
vm_continue (f_output : FILEref,
             vm       : &vm_vt) :
    void =
  let
    fun
    loop (vm           : &vm_vt,
          machine_halt : &bool,
          bad_opcode   : &bool) : void =
      if ~machine_halt && ~bad_opcode then
        begin
          vm_step (f_output, vm, machine_halt, bad_opcode);
          loop (vm, machine_halt, bad_opcode)
        end

    var machine_halt : bool = false
    var bad_opcode : bool = false
  in
    loop (vm, machine_halt, bad_opcode);
    if bad_opcode then
      $raise vm_runtime_error ("Unrecognized opcode at runtime.")
  end

fn
vm_initialize (vm : &vm_vt) :
    void =
  let
    macdef data = vm.data
    macdef registers = vm.registers
  in
    vmarray_vt_fill (data, i2vm 0);
    registers[REGISTER_PC] := i2vm 0;
    registers[REGISTER_SP] := i2vm 0
  end


fn
vm_run (f_output : FILEref,
        vm       : &vm_vt) :
    void =
  begin
    vm_initialize (vm);
    vm_continue (f_output, vm)
  end

(********************************************************************)

implement
main0 (argc, argv) =
  {
    val inpfname =
      if 2 <= argc then
        $UN.cast{string} argv[1]
      else
        "-"
    val outfname =
      if 3 <= argc then
        $UN.cast{string} argv[2]
      else
        "-"

    val inpf =
      if (inpfname : string) = "-" then
        stdin_ref
      else
        fileref_open_exn (inpfname, file_mode_r)

    val outf =
      if (outfname : string) = "-" then
        stdout_ref
      else
        fileref_open_exn (outfname, file_mode_w)

    (* The following order must match that established by
       OP_HALT, OP_ADD, OP_SUB, etc. *)
    var opcode_order =
      @[String0][OPCODE_COUNT] ("halt",  // 00000   bit pattern
                                "add",   // 00001
                                "sub",   // 00010
                                "mul",   // 00011
                                "div",   // 00100
                                "mod",   // 00101
                                "lt",    // 00110
                                "gt",    // 00111
                                "le",    // 01000
                                "ge",    // 01001
                                "eq",    // 01010
                                "ne",    // 01011
                                "and",   // 01100
                                "or",    // 01101
                                "neg",   // 01110
                                "not",   // 01111
                                "prtc",  // 10000
                                "prti",  // 10001
                                "prts",  // 10010
                                "fetch", // 10011
                                "store", // 10100
                                "push",  // 10101
                                "jmp",   // 10110
                                "jz")    // 10111

    val _ = ensure_that_vmint_is_suitable ()
    var vm = read_vm (inpf, opcode_order)
    val _ = vm_run (outf, vm)
    val _ = vm_vt_free vm
  }

(********************************************************************)
Output:

$ patscc -O3 -DATS_MEMALLOC_LIBC -o vm vm-postiats.dats -latslib && ./lex < compiler-tests/count.t | ./parse | ./gen | ./vm

count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

Compiler

It seemed interesting to write translators from virtual machine code to other languages. Find at https://pastebin.com/pntTVTN3 a translator from Rosetta Code VM assembly language to ATS. The ATS program can be compiled to native code, which should run pretty fast if you use the C optimizer.

An ongoing project, to extend the translator to output languages other than ATS, is at https://sourceforge.net/p/chemoelectric/rosettacode-contributions/ci/default/tree/vmc.dats

AWK

Tested with gawk 4.1.1 and mawk 1.3.4.

function error(msg) {
  printf("%s\n", msg)
  exit(1)
}

function bytes_to_int(bstr,          i, sum) {
  sum = 0
  for (i=word_size-1; i>=0; i--) {
    sum *= 256
    sum += code[bstr+i]
  }
  return sum
}

function emit_byte(x) {
  code[next_free_code_index++] = x
}

function emit_word(x,       i) {
  for (i=0; i<word_size; i++) {
    emit_byte(int(x)%256);
    x = int(x/256)
  }
}

function run_vm(data_size) {
  sp = data_size + 1
  pc = 0
  while (1) {
    op = code[pc++]
    if (op == FETCH) {
      stack[sp++] = stack[bytes_to_int(pc)]
      pc += word_size
    } else if (op == STORE) {
      stack[bytes_to_int(pc)] = stack[--sp]
      pc += word_size
    } else if (op == PUSH) {
      stack[sp++] = bytes_to_int(pc)
      pc += word_size
    } else if (op == ADD ) { stack[sp-2] += stack[sp-1]; sp--
    } else if (op == SUB ) { stack[sp-2] -= stack[sp-1]; sp--
    } else if (op == MUL ) { stack[sp-2] *= stack[sp-1]; sp--
    } else if (op == DIV ) { stack[sp-2]  = int(stack[sp-2] / stack[sp-1]); sp--
    } else if (op == MOD ) { stack[sp-2] %= stack[sp-1]; sp--
    } else if (op == LT  ) { stack[sp-2] = stack[sp-2] <  stack[sp-1]; sp--
    } else if (op == GT  ) { stack[sp-2] = stack[sp-2] >  stack[sp-1]; sp--
    } else if (op == LE  ) { stack[sp-2] = stack[sp-2] <= stack[sp-1]; sp--
    } else if (op == GE  ) { stack[sp-2] = stack[sp-2] >= stack[sp-1]; sp--
    } else if (op == EQ  ) { stack[sp-2] = stack[sp-2] == stack[sp-1]; sp--
    } else if (op == NE  ) { stack[sp-2] = stack[sp-2] != stack[sp-1]; sp--
    } else if (op == AND ) { stack[sp-2] = stack[sp-2] && stack[sp-1]; sp--
    } else if (op == OR  ) { stack[sp-2] = stack[sp-2] || stack[sp-1]; sp--
    } else if (op == NEG ) { stack[sp-1] = - stack[sp-1]
    } else if (op == NOT ) { stack[sp-1] = ! stack[sp-1]
    } else if (op == JMP ) { pc += bytes_to_int(pc)
    } else if (op == JZ  ) { if (stack[--sp]) { pc += word_size } else { pc += bytes_to_int(pc) }
    } else if (op == PRTC) { printf("%c", stack[--sp])
    } else if (op == PRTS) { printf("%s", string_pool[stack[--sp]])
    } else if (op == PRTI) { printf("%d", stack[--sp])
    } else if (op == HALT) { break
    }
  } # while
}

function str_trans(srce,           dest, i) {
  dest = ""
  for (i=1; i <= length(srce); ) {
    if (substr(srce, i, 1) == "\\" && i < length(srce)) {
      if (substr(srce, i+1, 1) == "n") {
        dest = dest "\n"
        i += 2
      } else if (substr(srce, i+1, 1) == "\\") {
        dest = dest "\\"
        i += 2
      }
    } else {
      dest = dest substr(srce, i, 1)
      i += 1
    }
  }
  return dest
}

function load_code(            n, i) {
  getline line
  if (line ==  "")
    error("empty line")
  n=split(line, line_list)
  data_size = line_list[2]
  n_strings = line_list[4]
  for (i=0; i<n_strings; i++) {
    getline line
    gsub(/\n/, "", line)
    gsub(/"/ , "", line)
    string_pool[i] = str_trans(line)
  }
  while (getline) {
    offset = int($1)
    instr  = $2
    opcode = code_map[instr]
    if (opcode == "")
      error("Unknown instruction " instr " at " offset)
    emit_byte(opcode)
    if (opcode == JMP || opcode == JZ) {
      p = int($4)
      emit_word(p - (offset + 1))
    } else if (opcode == PUSH) {
      value = int($3)
      emit_word(value)
    } else if (opcode == FETCH || opcode == STORE) {
      gsub(/\[/, "", $3)
      gsub(/\]/, "", $3)
      value = int($3)
      emit_word(value)
    }
  }
  return data_size
}

BEGIN {
  code_map["fetch"] = FETCH =  1
  code_map["store"] = STORE =  2
  code_map["push" ] = PUSH  =  3
  code_map["add"  ] = ADD   =  4
  code_map["sub"  ] = SUB   =  5
  code_map["mul"  ] = MUL   =  6
  code_map["div"  ] = DIV   =  7
  code_map["mod"  ] = MOD   =  8
  code_map["lt"   ] = LT    =  9
  code_map["gt"   ] = GT    = 10
  code_map["le"   ] = LE    = 11
  code_map["ge"   ] = GE    = 12
  code_map["eq"   ] = EQ    = 13
  code_map["ne"   ] = NE    = 14
  code_map["and"  ] = AND   = 15
  code_map["or"   ] = OR    = 16
  code_map["neg"  ] = NEG   = 17
  code_map["not"  ] = NOT   = 18
  code_map["jmp"  ] = JMP   = 19
  code_map["jz"   ] = JZ    = 20
  code_map["prtc" ] = PRTC  = 21
  code_map["prts" ] = PRTS  = 22
  code_map["prti" ] = PRTI  = 23
  code_map["halt" ] = HALT  = 24

  next_free_node_index = 1
  next_free_code_index = 0
  word_size   = 4
  input_file = "-"
  if (ARGC > 1)
    input_file = ARGV[1]
  data_size = load_code()
  run_vm(data_size)
}
Output  —  count:

count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

C

Tested with gcc 4.81 and later, compiles warning free with -Wall -Wextra

#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <stdint.h>
#include <ctype.h>

#define NELEMS(arr) (sizeof(arr) / sizeof(arr[0]))

#define da_dim(name, type)  type *name = NULL;          \
                            int _qy_ ## name ## _p = 0;  \
                            int _qy_ ## name ## _max = 0

#define da_redim(name)      do {if (_qy_ ## name ## _p >= _qy_ ## name ## _max) \
                                name = realloc(name, (_qy_ ## name ## _max += 32) * sizeof(name[0]));} while (0)

#define da_rewind(name)     _qy_ ## name ## _p = 0

#define da_append(name, x)  do {da_redim(name); name[_qy_ ## name ## _p++] = x;} while (0)

typedef unsigned char uchar;
typedef uchar code;

typedef enum { FETCH, STORE, PUSH, ADD, SUB, MUL, DIV, MOD, LT, GT, LE, GE, EQ, NE, AND,
    OR, NEG, NOT, JMP, JZ, PRTC, PRTS, PRTI, HALT
} Code_t;

typedef struct Code_map {
    char    *text;
    Code_t   op;
} Code_map;

Code_map code_map[] = {
    {"fetch",  FETCH},
    {"store",  STORE},
    {"push",   PUSH },
    {"add",    ADD  },
    {"sub",    SUB  },
    {"mul",    MUL  },
    {"div",    DIV  },
    {"mod",    MOD  },
    {"lt",     LT   },
    {"gt",     GT   },
    {"le",     LE   },
    {"ge",     GE   },
    {"eq",     EQ   },
    {"ne",     NE   },
    {"and",    AND  },
    {"or",     OR   },
    {"neg",    NEG  },
    {"not",    NOT  },
    {"jmp",    JMP  },
    {"jz",     JZ   },
    {"prtc",   PRTC },
    {"prts",   PRTS },
    {"prti",   PRTI },
    {"halt",   HALT },
};

FILE *source_fp;
da_dim(object, code);

void error(const char *fmt, ... ) {
    va_list ap;
    char buf[1000];

    va_start(ap, fmt);
    vsprintf(buf, fmt, ap);
    va_end(ap);
    printf("error: %s\n", buf);
    exit(1);
}

/*** Virtual Machine interpreter ***/
void run_vm(const code obj[], int32_t data[], int g_size, char **string_pool) {
    int32_t *sp = &data[g_size + 1];
    const code *pc = obj;

    again:
    switch (*pc++) {
        case FETCH: *sp++ = data[*(int32_t *)pc];  pc += sizeof(int32_t); goto again;
        case STORE: data[*(int32_t *)pc] = *--sp;  pc += sizeof(int32_t); goto again;
        case PUSH:  *sp++ = *(int32_t *)pc;        pc += sizeof(int32_t); goto again;
        case ADD:   sp[-2] += sp[-1]; --sp;                             goto again;
        case SUB:   sp[-2] -= sp[-1]; --sp;                             goto again;
        case MUL:   sp[-2] *= sp[-1]; --sp;                             goto again;
        case DIV:   sp[-2] /= sp[-1]; --sp;                             goto again;
        case MOD:   sp[-2] %= sp[-1]; --sp;                             goto again;
        case LT:    sp[-2] = sp[-2] <  sp[-1]; --sp;                    goto again;
        case GT:    sp[-2] = sp[-2] >  sp[-1]; --sp;                    goto again;
        case LE:    sp[-2] = sp[-2] <= sp[-1]; --sp;                    goto again;
        case GE:    sp[-2] = sp[-2] >= sp[-1]; --sp;                    goto again;
        case EQ:    sp[-2] = sp[-2] == sp[-1]; --sp;                    goto again;
        case NE:    sp[-2] = sp[-2] != sp[-1]; --sp;                    goto again;
        case AND:   sp[-2] = sp[-2] && sp[-1]; --sp;                    goto again;
        case OR:    sp[-2] = sp[-2] || sp[-1]; --sp;                    goto again;
        case NEG:   sp[-1] = -sp[-1];                                   goto again;
        case NOT:   sp[-1] = !sp[-1];                                   goto again;
        case JMP:   pc += *(int32_t *)pc;                               goto again;
        case JZ:    pc += (*--sp == 0) ? *(int32_t *)pc : (int32_t)sizeof(int32_t); goto again;
        case PRTC:  printf("%c", sp[-1]); --sp;                         goto again;
        case PRTS:  printf("%s", string_pool[sp[-1]]); --sp;            goto again;
        case PRTI:  printf("%d", sp[-1]); --sp;                         goto again;
        case HALT:                                                      break;
        default:    error("Unknown opcode %d\n", *(pc - 1));
    }
}

char *read_line(int *len) {
    static char *text = NULL;
    static int textmax = 0;

    for (*len = 0; ; (*len)++) {
        int ch = fgetc(source_fp);
        if (ch == EOF || ch == '\n') {
            if (*len == 0)
                return NULL;
            break;
        }
        if (*len + 1 >= textmax) {
            textmax = (textmax == 0 ? 128 : textmax * 2);
            text = realloc(text, textmax);
        }
        text[*len] = ch;
    }
    text[*len] = '\0';
    return text;
}

char *rtrim(char *text, int *len) {         // remove trailing spaces
    for (; *len > 0 && isspace(text[*len - 1]); --(*len))
        ;

    text[*len] = '\0';
    return text;
}

char *translate(char *st) {
    char *p, *q;
    if (st[0] == '"')                       // skip leading " if there
        ++st;
    p = q = st;

    while ((*p++ = *q++) != '\0') {
        if (q[-1] == '\\') {
            if (q[0] == 'n') {
                p[-1] = '\n';
                ++q;
            } else if (q[0] == '\\') {
                ++q;
            }
        }
        if (q[0] == '"' && q[1] == '\0')    // skip trialing " if there
            ++q;
    }

    return st;
}

/* convert an opcode string into its byte value */
int findit(const char text[], int offset) {
    for (size_t i = 0; i < sizeof(code_map) / sizeof(code_map[0]); i++) {
        if (strcmp(code_map[i].text, text) == 0)
            return code_map[i].op;
    }
    error("Unknown instruction %s at %d\n", text, offset);
    return -1;
}

void emit_byte(int c) {
    da_append(object, (uchar)c);
}

void emit_int(int32_t n) {
    union {
        int32_t n;
        unsigned char c[sizeof(int32_t)];
    } x;

    x.n = n;

    for (size_t i = 0; i < sizeof(x.n); ++i) {
        emit_byte(x.c[i]);
    }
}

/*
Datasize: 5 Strings: 3
" is prime\n"
"Total primes found: "
"\n"
 154 jmp    (-73) 82
 164 jz     (32) 197
 175 push  0
 159 fetch [4]
 149 store [3]
 */

/* Load code into global array object, return the string pool and data size */
char **load_code(int *ds) {
    int line_len, n_strings;
    char **string_pool;
    char *text = read_line(&line_len);
    text = rtrim(text, &line_len);

    strtok(text, " ");                      // skip "Datasize:"
    *ds = atoi(strtok(NULL, " "));          // get actual data_size
    strtok(NULL, " ");                      // skip "Strings:"
    n_strings = atoi(strtok(NULL, " "));    // get number of strings

    string_pool = malloc(n_strings * sizeof(char *));
    for (int i = 0; i < n_strings; ++i) {
        text = read_line(&line_len);
        text = rtrim(text, &line_len);
        text = translate(text);
        string_pool[i] = strdup(text);
    }

    for (;;) {
        int len;

        text = read_line(&line_len);
        if (text == NULL)
            break;
        text = rtrim(text, &line_len);

        int offset = atoi(strtok(text, " "));   // get the offset
        char *instr = strtok(NULL, " ");    // get the instruction
        int opcode = findit(instr, offset);
        emit_byte(opcode);
        char *operand = strtok(NULL, " ");

        switch (opcode) {
            case JMP: case JZ:
                operand++;                  // skip the '('
                len = strlen(operand);
                operand[len - 1] = '\0';    // remove the ')'
                emit_int(atoi(operand));
                break;
            case PUSH:
                emit_int(atoi(operand));
                break;
            case FETCH: case STORE:
                operand++;                  // skip the '['
                len = strlen(operand);
                operand[len - 1] = '\0';    // remove the ']'
                emit_int(atoi(operand));
                break;
        }
    }
    return string_pool;
}

void init_io(FILE **fp, FILE *std, const char mode[], const char fn[]) {
    if (fn[0] == '\0')
        *fp = std;
    else if ((*fp = fopen(fn, mode)) == NULL)
        error(0, 0, "Can't open %s\n", fn);
}

int main(int argc, char *argv[]) {
    init_io(&source_fp, stdin,  "r",  argc > 1 ? argv[1] : "");
    int data_size;
    char **string_pool = load_code(&data_size);
    int data[1000 + data_size];
    run_vm(object, data, data_size, string_pool);
}

COBOL

Code by Steve Williams (with changes to work around code highlighting issues). Tested with GnuCOBOL 2.2.

        >>SOURCE FORMAT IS FREE
identification division.
*> this code is dedicated to the public domain
*> (GnuCOBOL) 2.3-dev.0
program-id. vminterpreter.
environment division.
configuration section.
repository.  function all intrinsic.
input-output section.
file-control.
    select input-file assign using input-name
        status is input-status
        organization is line sequential.
data division.

file section.
fd  input-file.
01  input-record pic x(64).

working-storage section.
01  program-name pic x(32).
01  input-name pic x(32).
01  input-status pic xx.

01  error-record pic x(64) value spaces global.

01  v-max pic 99.
01  parameters.
    03  offset pic 999.
    03  opcode pic x(8).
    03  parm0 pic x(16).
    03  parm1 pic x(16).
    03  parm2 pic x(16).

01  opcodes.
    03  opFETCH pic x value x'00'.
    03  opSTORE pic x value x'01'.
    03  opPUSH  pic x value x'02'.
    03  opADD   pic x value x'03'.
    03  opSUB   pic x value x'04'.
    03  opMUL   pic x value x'05'.
    03  opDIV   pic x value x'06'.
    03  opMOD   pic x value x'07'.
    03  opLT    pic x value x'08'.
    03  opGT    pic x value x'09'.
    03  opLE    pic x value x'0A'.
    03  opGE    pic x value x'0B'.
    03  opEQ    pic x value x'0C'.
    03  opNE    pic x value x'0D'.
    03  opAND   pic x value x'0E'.
    03  opOR    pic x value x'0F'.
    03  opNEG   pic x value x'10'.
    03  opNOT   pic x value x'11'.
    03  opJMP   pic x value x'13'.
    03  opJZ    pic x value x'14'.
    03  opPRTC  pic x value x'15'.
    03  opPRTS  pic x value x'16'.
    03  opPRTI  pic x value x'17'.
    03  opHALT  pic x value x'18'.

01  filler.
    03  s pic 99.
    03  s-max pic 99 value 0.
    03  s-lim pic 99 value 16.
    03  filler occurs 16.
        05  string-length pic 99.
        05  string-entry pic x(48).

01  filler.
    03  v pic 99.
    03  v-lim pic 99 value 16.
    03  variables occurs 16 usage binary-int.

01  generated-code global.
    03  c  pic 999 value 1.
    03  pc pic 999.
    03  c-lim pic 999 value 512.
    03  kode pic x(512).

01  filler.
    03  stack1 pic 999 value 2.
    03  stack2 pic 999 value 1.
    03  stack-lim pic 999 value 998.
    03  stack occurs 998 usage binary-int.

01  display-definitions global.
    03  ascii-character.
        05  numeric-value usage binary-char.
    03  display-integer pic -(9)9.
    03  word-x.
        05  word usage binary-int.
    03  word-length pic 9.
    03  string1 pic 99.
    03  length1 pic 99.
    03  count1 pic 99.
    03  display-pending pic x.

procedure division.
start-vminterpreter.
    display 1 upon command-line *> get arg(1)
    accept program-name from argument-value
    move length(word) to word-length
    perform load-code
    perform run-code
    stop run
    .
run-code.
    move 1 to pc 
    perform until pc >= c
        evaluate kode(pc:1) 
        when opFETCH
            perform push-stack
            move kode(pc + 1:word-length) to word-x
            add 1 to word *> convert offset to subscript
            move variables(word) to stack(stack1)
            add word-length to pc
        when opPUSH
            perform push-stack
            move kode(pc + 1:word-length) to word-x
            move word to stack(stack1)
            add word-length to pc
        when opNEG
            compute stack(stack1) = -stack(stack1)
        when opNOT
            if stack(stack1) = 0
                move 1 to stack(stack1)
            else
                move 0 to stack(stack1)
            end-if
        when opJMP
            move kode(pc + 1:word-length) to word-x
            move word to pc
        when opHALT
            if display-pending = 'Y'
                display space
            end-if
            exit perform
        when opJZ
            if stack(stack1) = 0
                move kode(pc + 1:word-length) to word-x
                move word to pc
            else
                add word-length to pc
            end-if
            perform pop-stack
        when opSTORE
            move kode(pc + 1:word-length) to word-x
            add 1 to word *> convert offset to subscript
            move stack(stack1) to variables(word)
            add word-length to pc
            perform pop-stack
        when opADD
            add stack(stack1) to stack(stack2)
            perform pop-stack
        when opSUB
            subtract stack(stack1) from stack(stack2)
            perform pop-stack
        when opMUL
            multiply stack(stack1) by stack(stack2)
                *>rounded mode nearest-toward-zero *> doesn't match python 
            perform pop-stack
        when opDIV
            divide stack(stack1) into stack(stack2)
                *>rounded mode nearest-toward-zero *> doesn't match python 
            perform pop-stack
        when opMOD
            move mod(stack(stack2),stack(stack1)) to stack(stack2)
            perform pop-stack
        when opLT
            if stack(stack2) <  stack(stack1)
                move 1 to stack(stack2)
            else
                move 0 to stack(stack2)
            end-if
            perform pop-stack
        when opGT
            if stack(stack2) >  stack(stack1)
                move 1 to stack(stack2)
            else
                move 0 to stack(stack2)
            end-if
            perform pop-stack
        when opLE
            if stack(stack2) <= stack(stack1)
                move 1 to stack(stack2)
            else
                move 0 to stack(stack2)
            end-if
            perform pop-stack
        when opGE
            if stack(stack2) >= stack(stack1)
                move 1 to stack(stack2)
            else
                move 0 to stack(stack2)
            end-if
            perform pop-stack
        when opEQ
            if stack(stack2) = stack(stack1)
                move 1 to stack(stack2)
            else
                move 0 to stack(stack2)
            end-if
            perform pop-stack
        when opNE
            if stack(stack2) <> stack(stack1)
                move 1 to stack(stack2)
            else
                move 0 to stack(stack2)
            end-if
            perform pop-stack
        when opAND
            call "CBL_AND" using stack(stack1) stack(stack2) by value word-length
            perform pop-stack
        when opOR
            call "CBL_OR" using stack(stack1) stack(stack2) by value word-length
            perform pop-stack
        when opPRTC
            move stack(stack1) to numeric-value
            if numeric-value = 10
                display space
                move 'N' to display-pending
            else
                display ascii-character with no advancing
                move 'Y' to display-pending
            end-if
            perform pop-stack
        when opPRTS
            add 1 to word *> convert offset to subscript
            move 1 to string1
            move string-length(word) to length1
            perform until string1 > string-length(word)
                move 0 to count1
                inspect string-entry(word)(string1:length1)
                    tallying count1 for characters before initial '\'   *> ' workaround code highlighter problem
                evaluate true
                when string-entry(word)(string1 + count1 + 1:1) = 'n' *> \n
                    display string-entry(word)(string1:count1)
                    move 'N' to display-pending
                    compute string1 = string1 + 2 + count1
                    compute length1 = length1 - 2 - count1
                when string-entry(word)(string1 + count1 + 1:1) = '\' *> ' \\
                    display string-entry(word)(string1:count1 + 1) with no advancing
                    move 'Y' to display-pending
                    compute string1 = string1 + 2 + count1
                    compute length1 = length1 - 2 - count1
                when other
                    display string-entry(word)(string1:count1) with no advancing
                    move 'Y' to display-pending
                    add count1 to string1
                    subtract count1 from length1
                end-evaluate
            end-perform 
            perform pop-stack
        when opPRTI
            move stack(stack1) to display-integer
            display trim(display-integer) with no advancing
            move 'Y' to display-pending
            perform pop-stack
        end-evaluate
        add 1 to pc
    end-perform
    .
push-stack.
    if stack1 >= stack-lim
        string 'in vminterpreter at ' pc ' stack overflow at ' stack-lim into error-record
        perform report-error
    end-if
    add 1 to stack1 stack2
    >>d display ' push at ' pc space stack1 space stack2
    .
pop-stack.
    if stack1 < 2
        string 'in vminterpreter at ' pc ' stack underflow' into error-record
        perform report-error
    end-if
    >>d display ' pop at ' pc space stack1 space stack2
    subtract 1 from stack1 stack2
    .
load-code.
    perform read-input
    if input-status <> '00'
        string 'in vminterpreter no input data' into error-record
        perform report-error
    end-if

    unstring input-record delimited by all spaces into parm1 v-max parm2 s-max
    if v-max > v-lim
        string 'in vminterpreter datasize exceeds ' v-lim into error-record
        perform report-error
    end-if
    if s-max > s-lim
        string 'in vminterpreter number of strings exceeds ' s-lim into error-record
        perform report-error
    end-if

    perform read-input
    perform varying s from 1 by 1 until s > s-max
    or input-status <> '00'
        compute string-length(s) string-length(word) = length(trim(input-record)) - 2
        move input-record(2:string-length(word)) to string-entry(s)
        perform read-input
    end-perform
    if s <= s-max
        string 'in vminterpreter not all strings found' into error-record
        perform report-error
    end-if

    perform until input-status <> '00'
        initialize parameters
        unstring input-record delimited by all spaces into
            parm0 offset opcode parm1 parm2
        evaluate opcode
        when 'fetch'
            call 'emitbyte' using opFETCH
            call 'emitword' using parm1
        when 'store'
            call 'emitbyte' using opSTORE
            call 'emitword' using parm1
        when 'push'
            call 'emitbyte' using opPUSH
            call 'emitword' using parm1
        when 'add' call 'emitbyte' using opADD
        when 'sub' call 'emitbyte' using opSUB
        when 'mul' call 'emitbyte' using opMUL
        when 'div' call 'emitbyte' using opDIV
        when 'mod' call 'emitbyte' using opMOD
        when 'lt'  call 'emitbyte' using opLT
        when 'gt'  call 'emitbyte' using opGT
        when 'le'  call 'emitbyte' using opLE
        when 'ge'  call 'emitbyte' using opGE
        when 'eq'  call 'emitbyte' using opEQ
        when 'ne'  call 'emitbyte' using opNE
        when 'and' call 'emitbyte' using opAND
        when 'or'  call 'emitbyte' using opOR
        when 'not' call 'emitbyte' using opNOT
        when 'neg' call 'emitbyte' using opNEG
        when 'jmp'
             call 'emitbyte' using opJMP
             call 'emitword' using parm2
        when 'jz'
             call 'emitbyte' using opJZ
             call 'emitword' using parm2
        when 'prtc' call 'emitbyte' using opPRTC
        when 'prts' call 'emitbyte' using opPRTS
        when 'prti' call 'emitbyte' using opPRTI
        when 'halt' call 'emitbyte' using opHALT
        when other
            string 'in vminterpreter unknown opcode ' trim(opcode) ' at ' offset into error-record
            perform report-error
        end-evaluate
        perform read-input
    end-perform
    .
read-input.
    if program-name = spaces
        move '00' to input-status
        accept input-record on exception move '10' to input-status end-accept
        exit paragraph
    end-if
    if input-name = spaces
        string program-name delimited by space '.gen' into input-name
        open input input-file
        if input-status <> '00'
            string 'in vminterpreter ' trim(input-name) ' file open status ' input-status
                into error-record
            perform report-error
        end-if
    end-if
    read input-file into input-record
    evaluate input-status
    when '00'
        continue
    when '10'
        close input-file
    when other
        string 'in vminterpreter unexpected input-status: ' input-status into error-record
        perform report-error
    end-evaluate
    .
report-error.
    display error-record upon syserr
    stop run with error status -1
    .
identification division.
program-id. emitbyte.
data division.
linkage section.
01  opcode pic x.
procedure division using opcode.
start-emitbyte.
    if c >= c-lim
        string 'in vminterpreter emitbyte c exceeds ' c-lim into error-record
        call 'reporterror'
    end-if
    move opcode to kode(c:1)
    add 1 to c
    .
end program emitbyte.
   
identification division.
program-id. emitword.
data division.
working-storage section.
01  word-temp pic x(8).
linkage section.
01  word-value any length.
procedure division using word-value.
start-emitword.
    if c + word-length >= c-lim
        string 'in vminterpreter emitword c exceeds ' c-lim into error-record
        call 'reporterror'
    end-if
    move word-value to word-temp
    inspect word-temp converting '[' to ' '
    inspect word-temp converting ']' to ' '
    move numval(trim(word-temp)) to word
    move word-x to kode(c:word-length)
    add word-length to c
    .
end program emitword.

end program vminterpreter.
Output  —  Count:
prompt$ ./lexer <testcases/Count | ./parser | ./generator | ./vminterpreter 
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

Common Lisp

Works with: roswell version 21.10.14.111
Works with: SBCL version 2.2.3
Library: cl-ppcre
Library: trivia


I ran it with SBCL, CCL, and ECL. SBCL gave by far the best performance on mandel.vm, although I do not know all the optimization tricks one can employ.


#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
  (ros:ensure-asdf)
  #+quicklisp(ql:quickload '() :silent t)
  )

(defpackage :ros.script.vm.3858678051
  (:use :cl))
(in-package :ros.script.vm.3858678051)

;;;
;;; The Rosetta Code Virtual Machine, in Common Lisp.
;;;
;;; Notes:
;;;
;;;   * I have tried not to use foreign types or similar means of
;;;     optimization.
;;;
;;;   * Integers are stored in the VM's executable memory in
;;;     big-endian order. Not because I prefer it, but because I do
;;;     not want to get myself into a little-endian rut.
;;;

(require "cl-ppcre")
(require "trivia")

;;; Yes, I could compute how much memory is needed, or I could assume
;;; that the instructions are in address order. However, for *this*
;;; implementation I am going to use a large fixed-size memory and use
;;; the address fields of instructions to place the instructions.
(defconstant executable-memory-size 65536
  "The size of memory for executable code, in 8-bit words.")

;;; Similarly, I am going to have fixed size data and stack memory.
(defconstant data-memory-size 2048
  "The size of memory for stored data, in 32-bit words.")
(defconstant stack-memory-size 2048
  "The size of memory for the stack, in 32-bit words.")

;;; And so I am going to have specialized types for the different
;;; kinds of memory the platform contains. Also for its "word" and
;;; register types.
(deftype word ()
  '(unsigned-byte 32))
(deftype register ()
  '(simple-array word (1)))
(deftype executable-memory ()
  `(simple-array (unsigned-byte 8) ,(list executable-memory-size)))
(deftype data-memory ()
  `(simple-array word ,(list data-memory-size)))
(deftype stack-memory ()
  `(simple-array word ,(list stack-memory-size)))

(defconstant re-blank-line
  (ppcre:create-scanner "^\\s*$"))

(defconstant re-parse-instr-1
  (ppcre:create-scanner "^\\s*(\\d+)\\s*(.*\\S)"))

(defconstant re-parse-instr-2
  (ppcre:create-scanner "(?i)^(\\S+)\\s*(.*)"))

(defconstant re-parse-instr-3
  (ppcre:create-scanner "^[[(]?([0-9-]+)"))

(defconstant opcode-names
  #("halt"
    "add"
    "sub"
    "mul"
    "div"
    "mod"
    "lt"
    "gt"
    "le"
    "ge"
    "eq"
    "ne"
    "and"
    "or"
    "neg"
    "not"
    "prtc"
    "prti"
    "prts"
    "fetch"
    "store"
    "push"
    "jmp"
    "jz"))

(defun blank-line-p (s)
  (not (not (ppcre:scan re-blank-line s))))

(defun opcode-from-name (s)
  (position-if (lambda (name)
                 (string= s name))
               opcode-names))

(defun create-executable-memory ()
  (coerce (make-list executable-memory-size
                     :initial-element (opcode-from-name "halt"))
          'executable-memory))

(defun create-data-memory ()
  (coerce (make-list data-memory-size :initial-element 0)
          'data-memory))

(defun create-stack-memory ()
  (coerce (make-list stack-memory-size :initial-element 0)
          'stack-memory))

(defun create-register ()
  (coerce (make-list 1 :initial-element 0) 'register))

(defstruct machine
  (sp (create-register) :type register) ; Stack pointer.
  (ip (create-register) :type register) ; Instruction pointer (same
  ; thing as program counter).
  (code (create-executable-memory) :type executable-memory)
  (data (create-data-memory) :type data-memory)
  (stack (create-stack-memory) :type stack-memory)
  (strings nil)
  output *standard-output*)

(defun insert-instruction (memory instr)
  (declare (type executable-memory memory))
  (trivia:match instr
    ((list address opcode arg)
     (let ((instr-size (if arg 5 1)))
       (unless (<= (+ address instr-size) executable-memory-size)
         (warn "the VM's executable memory size is exceeded")
         (uiop:quit 1))
       (setf (elt memory address) opcode)
       (when arg
         ;; Big-endian order.
         (setf (elt memory (+ address 1)) (ldb (byte 8 24) arg))
         (setf (elt memory (+ address 2)) (ldb (byte 8 16) arg))
         (setf (elt memory (+ address 3)) (ldb (byte 8 8) arg))
         (setf (elt memory (+ address 4)) (ldb (byte 8 0) arg)))))))

(defun load-executable-memory (memory instr-lst)
  (declare (type executable-memory memory))
  (loop for instr in instr-lst
        do (insert-instruction memory instr)))

(defun parse-instruction (s)
  (if (blank-line-p s)
      nil
      (let* ((strings (nth-value 1 (ppcre:scan-to-strings
                                    re-parse-instr-1 s)))
             (address (parse-integer (elt strings 0)))
             (split (nth-value 1 (ppcre:scan-to-strings
                                  re-parse-instr-2 (elt strings 1))))
             (opcode-name (string-downcase (elt split 0)))
             (opcode (opcode-from-name opcode-name))
             (arguments (elt split 1))
             (has-arg (trivia:match opcode-name
                        ((or "fetch" "store" "push" "jmp" "jz") t)
                        (_ nil))))
        (if has-arg
            (let* ((argstr-lst
                     (nth-value 1 (ppcre:scan-to-strings
                                   re-parse-instr-3 arguments)))
                   (argstr (elt argstr-lst 0)))
              `(,address ,opcode ,(parse-integer argstr)))
            `(,address ,opcode ())))))

(defun read-instructions (inpf)
  (loop for line = (read-line inpf nil 'eoi)
        until (eq line 'eoi)
        for instr = (parse-instruction line)
        when instr collect instr))

(defun read-datasize-and-strings-count (inpf)
  (let ((line (read-line inpf)))
    (multiple-value-bind (_whole-match strings)
        ;; This is a permissive implementation.
        (ppcre:scan-to-strings
         "(?i)^\\s*Datasize\\s*:\\s*(\\d+)\\s*Strings\\s*:\\s*(\\d+)"
         line)
      (declare (ignore _whole-match))
      `(,(parse-integer (elt strings 0))
        ,(parse-integer (elt strings 1))))))

(defun parse-string-literal (s)
  ;; This is a permissive implementation, but only in that it skips
  ;; any leading space. It does not check carefully for outright
  ;; mistakes.
  (let* ((s (ppcre:regex-replace "^\\s*" s ""))
         (quote-mark (elt s 0))
         (i 1)
         (lst
           (loop until (char= (elt s i) quote-mark)
                 collect (let ((c (elt s i)))
                           (if (char= c #\\)
                               (let ((c0 (trivia:match (elt s (1+ i))
                                           (#\n #\newline)
                                           (c1 c1))))
                                 (setq i (+ i 2))
                                 c0)
                               (progn
                                 (setq i (1+ i))
                                 c))))))
    (coerce lst 'string)))

(defun read-string-literals (inpf strings-count)
  (loop for i from 1 to strings-count
        collect (parse-string-literal (read-line inpf))))

(defun open-inpf (inpf-filename)
  (if (string= inpf-filename "-")
      *standard-input*
      (open inpf-filename :direction :input)))

(defun open-outf (outf-filename)
  (if (string= outf-filename "-")
      *standard-output*
      (open outf-filename :direction :output
                          :if-exists :overwrite
                          :if-does-not-exist :create)))

(defun word-signbit-p (x)
  "True if and only if the sign bit is set."
  (declare (type word x))
  (/= 0 (logand x #x80000000)))

(defun word-add (x y)
  "Addition with overflow freely allowed."
  (declare (type word x))
  (declare (type word y))
  (coerce (logand (+ x y) #xFFFFFFFF) 'word))

(defun word-neg (x)
  "The two's complement."
  (declare (type word x))
  (word-add (logxor x #xFFFFFFFF) 1))

(defun word-sub (x y)
  "Subtraction with overflow freely allowed."
  (declare (type word x))
  (declare (type word y))
  (word-add x (word-neg y)))

(defun word-mul (x y)
  "Signed multiplication."
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-xy (the word
                          (logand (* abs-x abs-y) #xFFFFFFFF))))
        (if x<0
            (if y<0 abs-xy (word-neg abs-xy))
            (if y<0 (word-neg abs-xy) abs-xy))))))

(defun word-div (x y)
  "The quotient after signed integer division with truncation towards
zero."
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-x/y (the word
                           (logand (floor abs-x abs-y) #xFFFFFFFF))))
        (if x<0
            (if y<0 abs-x/y (word-neg abs-x/y))
            (if y<0 (word-neg abs-x/y) abs-x/y))))))

(defun word-mod (x y)
  "The remainder after signed integer division with truncation towards
zero."
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-x%y (the word
                           (logand (nth-value 1 (floor abs-x abs-y))
                                   #xFFFFFFFF))))
        (if x<0 (word-neg abs-x%y) abs-x%y)))))

(defun b2i (b)
  (declare (type boolean b))
  (if b 1 0))

(defun word-lt (x y)
  "Signed comparison: is x less than y?"
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (b2i (if x<0
             (if y<0 (< x y) t)
             (if y<0 nil (< x y))))))

(defun word-le (x y)
  "Signed comparison: is x less than or equal to y?"
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (b2i (if x<0
             (if y<0 (<= x y) t)
             (if y<0 nil (<= x y))))))

(defun word-gt (x y)
  "Signed comparison: is x greater than y?"
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (b2i (if x<0
             (if y<0 (> x y) nil)
             (if y<0 t (> x y))))))

(defun word-ge (x y)
  "Signed comparison: is x greater than or equal to y?"
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (b2i (if x<0
             (if y<0 (>= x y) nil)
             (if y<0 t (>= x y))))))

(defun word-eq (x y)
  "Is x equal to y?"
  (declare (type word x))
  (declare (type word y))
  (b2i (= x y)))

(defun word-ne (x y)
  "Is x not equal to y?"
  (declare (type word x))
  (declare (type word y))
  (b2i (/= x y)))

(defun word-cmp (x)
  "The logical complement."
  (declare (type word x))
  (b2i (= x 0)))

(defun word-and (x y)
  "The logical conjunction."
  (declare (type word x))
  (declare (type word y))
  (b2i (and (/= x 0) (/= y 0))))

(defun word-or (x y)
  "The logical disjunction."
  (declare (type word x))
  (declare (type word y))
  (b2i (or (/= x 0) (/= y 0))))

(defun unop (stack sp operation)
  "Perform a unary operation on the stack."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (declare (type (function (word) word) operation))
  (let ((i (elt sp 0)))
    (unless (<= 1 i)
      (warn "stack underflow")
      (uiop:quit 1))
    (let ((x (elt stack (1- i))))
      (setf (elt stack (1- i)) (funcall operation x)))))

(defun binop (stack sp operation)
  "Perform a binary operation on the stack."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (declare (type (function (word word) word) operation))
  (let ((i (elt sp 0)))
    (unless (<= 2 i)
      (warn "stack underflow")
      (uiop:quit 1))
    (let ((x (elt stack (- i 2)))
          (y (elt stack (1- i))))
      (setf (elt stack (- i 2)) (funcall operation x y)))
    (setf (elt sp 0) (1- i))))

(defun jri (code ip)
  "Jump relative immediate."
  (declare (type executable-memory code))
  (declare (type register ip))
  ;; Big-endian order.
  (let ((j (elt ip 0)))
    (unless (<= (+ j 4) executable-memory-size)
      (warn "address past end of executable memory")
      (uiop:quit 1))
    (let* ((offset (elt code (+ j 3)))
           (offset (dpb (elt code (+ j 2)) (byte 8 8) offset))
           (offset (dpb (elt code (+ j 1)) (byte 8 16) offset))
           (offset (dpb (elt code j) (byte 8 24) offset)))
      (setf (elt ip 0) (word-add j offset)))))

(defun jriz (stack sp code ip)
  "Jump relative immediate, if zero."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (declare (type executable-memory code))
  (declare (type register ip))
  (let ((i (elt sp 0)))
    (unless (<= 1 i)
      (warn "stack underflow")
      (uiop:quit 1))
    (let ((x (elt stack (1- i))))
      (setf (elt sp 0) (1- i))
      (if (= x 0)
          (jri code ip)
          (setf (elt ip 0) (+ (elt ip 0) 4))))))

(defun get-immediate-value (code ip)
  (declare (type executable-memory code))
  (declare (type register ip))
  ;; Big-endian order.
  (let ((j (elt ip 0)))
    (unless (<= (+ j 4) executable-memory-size)
      (warn "address past end of executable memory")
      (uiop:quit 1))
    (let* ((x (elt code (+ j 3)))
           (x (dpb (elt code (+ j 2)) (byte 8 8) x))
           (x (dpb (elt code (+ j 1)) (byte 8 16) x))
           (x (dpb (elt code j) (byte 8 24) x)))
      (setf (elt ip 0) (+ j 4))
      x)))

(defun pushi (stack sp code ip)
  "Push-immediate a value from executable memory onto the stack."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (declare (type executable-memory code))
  (declare (type register ip))
  (let ((i (elt sp 0)))
    (unless (< i stack-memory-size)
      (warn "stack overflow")
      (uiop:quit 1))
    (setf (elt stack i) (get-immediate-value code ip))
    (setf (elt sp 0) (1+ i))))

(defun fetch (stack sp code ip data)
  "Fetch data to the stack, using the storage location given in
executable memory."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (declare (type executable-memory code))
  (declare (type register ip))
  (declare (type data-memory data))
  (let ((i (elt sp 0)))
    (unless (< i stack-memory-size)
      (warn "stack overflow")
      (uiop:quit 1))
    (let* ((k (get-immediate-value code ip))
           (x (elt data k)))
      (setf (elt stack i) x)
      (setf (elt sp 0) (1+ i)))))

(defun pop-one (stack sp)
  (let ((i (elt sp 0)))
    (unless (<= 1 i)
      (warn "stack underflow")
      (uiop:quit 1))
    (let* ((x (elt stack (1- i))))
      (setf (elt sp 0) (1- i))
      x)))

(defun store (stack sp code ip data)
  "Store data from the stack, using the storage location given in
executable memory."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (declare (type executable-memory code))
  (declare (type register ip))
  (declare (type data-memory data))
  (let ((i (elt sp 0)))
    (unless (<= 1 i)
      (warn "stack underflow")
      (uiop:quit 1))
    (let ((k (get-immediate-value code ip))
          (x (pop-one stack sp)))
      (setf (elt data k) x))))

(defun prti (stack sp outf)
  "Print the top value of the stack, as a signed decimal value."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (let* ((n (pop-one stack sp))
         (n<0 (word-signbit-p n)))
    (if n<0
        (format outf "-~D" (word-neg n))
        (format outf "~D" n))))

(defun prtc (stack sp outf)
  "Print the top value of the stack, as a character."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (let* ((c (pop-one stack sp)))
    (format outf "~C" (code-char c))))

(defun prts (stack sp strings outf)
  "Print the string specified by the top of the stack."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (let* ((k (pop-one stack sp))
         (s (elt strings k)))
    (format outf "~A" s)))

(defmacro defun-machine-binop (op)
  (let ((machine-op (read-from-string
                     (concatenate 'string "machine-" (string op))))
        (word-op (read-from-string
                  (concatenate 'string "word-" (string op)))))
    `(defun ,machine-op (mach)
       (declare (type machine mach))
       (binop (machine-stack mach)
              (machine-sp mach)
              #',word-op))))

(defmacro defun-machine-unop (op)
  (let ((machine-op (read-from-string
                     (concatenate 'string "machine-" (string op))))
        (word-op (read-from-string
                  (concatenate 'string "word-" (string op)))))
    `(defun ,machine-op (mach)
       (declare (type machine mach))
       (unop (machine-stack mach)
             (machine-sp mach)
             #',word-op))))

(defun-machine-binop "add")
(defun-machine-binop "sub")
(defun-machine-binop "mul")
(defun-machine-binop "div")
(defun-machine-binop "mod")
(defun-machine-binop "lt")
(defun-machine-binop "gt")
(defun-machine-binop "le")
(defun-machine-binop "ge")
(defun-machine-binop "eq")
(defun-machine-binop "ne")
(defun-machine-binop "and")
(defun-machine-binop "or")

(defun-machine-unop "neg")
(defun machine-not (mach)
  (declare (type machine mach))
  (unop (machine-stack mach)
        (machine-sp mach)
        #'word-cmp))

(defun machine-prtc (mach)
  (declare (type machine mach))
  (prtc (machine-stack mach)
        (machine-sp mach)
        (machine-output mach)))

(defun machine-prti (mach)
  (declare (type machine mach))
  (prti (machine-stack mach)
        (machine-sp mach)
        (machine-output mach)))

(defun machine-prts (mach)
  (declare (type machine mach))
  (prts (machine-stack mach)
        (machine-sp mach)
        (machine-strings mach)
        (machine-output mach)))

(defun machine-fetch (mach)
  (declare (type machine mach))
  (fetch (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)
         (machine-data mach)))

(defun machine-store (mach)
  (declare (type machine mach))
  (store (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)
         (machine-data mach)))

(defun machine-push (mach)
  (declare (type machine mach))
  (pushi (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)))

(defun machine-jmp (mach)
  (declare (type machine mach))
  (jri (machine-code mach)
       (machine-ip mach)))

(defun machine-jz (mach)
  (declare (type machine mach))
  (jriz (machine-stack mach)
        (machine-sp mach)
        (machine-code mach)
        (machine-ip mach)))

(defun get-opcode (mach)
  (declare (type machine mach))
  (let ((code (machine-code mach))
        (ip (machine-ip mach)))
    (let ((j (elt ip 0)))
      (unless (< j executable-memory-size)
        (warn "address past end of executable memory")
        (uiop:quit 1))
      (let ((opcode (elt code j)))
        (setf (elt ip 0) (1+ j))
        opcode))))

(defun run-instruction (mach opcode)
  (declare (type machine mach))
  (declare (type fixnum opcode))
  (let ((op-mod-4 (logand opcode #x3))
        (op-div-4 (ash opcode -2)))
    (trivia:match op-div-4
      (0 (trivia:match op-mod-4
           (1 (machine-add mach))
           (2 (machine-sub mach))
           (3 (machine-mul mach))))
      (1 (trivia:match op-mod-4
           (0 (machine-div mach))
           (1 (machine-mod mach))
           (2 (machine-lt mach))
           (3 (machine-gt mach))))
      (2 (trivia:match op-mod-4
           (0 (machine-le mach))
           (1 (machine-ge mach))
           (2 (machine-eq mach))
           (3 (machine-ne mach))))
      (3 (trivia:match op-mod-4
           (0 (machine-and mach))
           (1 (machine-or mach))
           (2 (machine-neg mach))
           (3 (machine-not mach))))
      (4 (trivia:match op-mod-4
           (0 (machine-prtc mach))
           (1 (machine-prti mach))
           (2 (machine-prts mach))
           (3 (machine-fetch mach))))
      (5 (trivia:match op-mod-4
           (0 (machine-store mach))
           (1 (machine-push mach))
           (2 (machine-jmp mach))
           (3 (machine-jz mach)))))))

(defun run-vm (mach)
  (declare (type machine mach))
  (let ((opcode-for-halt (the fixnum (opcode-from-name "halt")))
        (opcode-for-add (the fixnum (opcode-from-name "add")))
        (opcode-for-jz (the fixnum (opcode-from-name "jz"))))
    (loop for opcode = (the fixnum (get-opcode mach))
          until (= opcode opcode-for-halt)
          do (progn (when (or (< opcode opcode-for-add)
                              (< opcode-for-jz opcode))
                      (warn "unsupported opcode")
                      (uiop:quit 1))
                    (run-instruction mach opcode)))))

(defun usage-error ()
  (princ "Usage: vm [INPUTFILE [OUTPUTFILE]]" *standard-output*)
  (terpri *standard-output*)
  (princ "If either INPUTFILE or OUTPUTFILE is \"-\", the respective"
         *standard-output*)
  (princ " standard I/O is used." *standard-output*)
  (terpri *standard-output*)
  (uiop:quit 1))

(defun get-filenames (argv)
  (trivia:match argv
    ((list) '("-" "-"))
    ((list inpf-filename) `(,inpf-filename "-"))
    ((list inpf-filename outf-filename) `(,inpf-filename
                                          ,outf-filename))
    (_ (usage-error))))

(defun main (&rest argv)
  (let* ((filenames (get-filenames argv))
         (inpf-filename (car filenames))
         (inpf (open-inpf inpf-filename))
         (outf-filename (cadr filenames))
         (outf (open-outf outf-filename))

         (sizes (read-datasize-and-strings-count inpf))
         (datasize (car sizes))
         (strings-count (cadr sizes))
         (strings (read-string-literals inpf strings-count))
         (instructions (read-instructions inpf))
         ;; We shall remain noncommittal about how strings are stored
         ;; on the hypothetical machine.
         (strings (coerce strings 'simple-vector))

         (mach (make-machine :strings strings
                             :output outf)))

    (unless (<= datasize data-memory-size)
      (warn "the VM's data memory size is exceeded")
      (uiop:quit 1))

    (load-executable-memory (machine-code mach) instructions)
    (run-vm mach)

    (unless (string= inpf-filename "-")
      (close inpf))
    (unless (string= outf-filename "-")
      (close outf))

    (uiop:quit 0)))

;;; vim: set ft=lisp lisp:


Output:
$ ./vm.ros compiler-tests/count.vm
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

D

Works with: gcc version 11.2.1
Works with: dmd version 2.096.1
Translation of: ATS


This program is fairly close to the ATS from which it was derived, although it differs greatly in certain details where the D code is significantly simpler, and was much easier to write.

If the D is optimized and compiled without bounds checks, the performance on the ASCII Mandelbrot seems comparable to that of the ATS. Differences, indeed, might rest mainly in the I/O library routines. It should be noted, though, that the ATS achieves bounds safety without runtime bounds checks; that is a major point in using it. Also, when debugging the D, I encountered a segfault due to assignment to a null class object; the ATS compiler would be much more likely to detect that kind of mistake.


//
// The Rosetta Code Virtual Machine in D.
//
// This code was migrated from an implementation in ATS. I have tried
// to keep it possible to compare the two languages easily, although
// in some cases the demonstration of "low level" techniques in ATS
// (such as avoiding memory leaks that might require garbage
// collection), or the use of linked lists as intermediate storage, or
// other such matters, seemed inappropriate to duplicate in D
// programming.
//
// (For example: in ATS, using a fully built linked list to initialize
// an array solves typechecking issues that simply do not exist in D's
// type system.)
//

import std.ascii;
import std.conv;
import std.stdint;
import std.stdio;
import std.string;
import std.typecons;

enum Op {
  HALT    = 0x0000,  // 00000
  ADD     = 0x0001,  // 00001
  SUB     = 0x0002,  // 00010
  MUL     = 0x0003,  // 00011
  DIV     = 0x0004,  // 00100
  MOD     = 0x0005,  // 00101
  LT      = 0x0006,  // 00110
  GT      = 0x0007,  // 00111
  LE      = 0x0008,  // 01000
  GE      = 0x0009,  // 01001
  EQ      = 0x000A,  // 01010
  NE      = 0x000B,  // 01011
  AND     = 0x000C,  // 01100
  OR      = 0x000D,  // 01101
  NEG     = 0x000E,  // 01110
  NOT     = 0x000F,  // 01111
  PRTC    = 0x0010,  // 10000
  PRTI    = 0x0011,  // 10001
  PRTS    = 0x0012,  // 10010
  FETCH   = 0x0013,  // 10011
  STORE   = 0x0014,  // 10100
  PUSH    = 0x0015,  // 10101
  JMP     = 0x0016,  // 10110
  JZ      = 0x0017   // 10111
}

const string[] opcodeOrder =
  ["halt",  // 00000   bit pattern
   "add",   // 00001
   "sub",   // 00010
   "mul",   // 00011
   "div",   // 00100
   "mod",   // 00101
   "lt",    // 00110
   "gt",    // 00111
   "le",    // 01000
   "ge",    // 01001
   "eq",    // 01010
   "ne",    // 01011
   "and",   // 01100
   "or",    // 01101
   "neg",   // 01110
   "not",   // 01111
   "prtc",  // 10000
   "prti",  // 10001
   "prts",  // 10010
   "fetch", // 10011
   "store", // 10100
   "push",  // 10101
   "jmp",   // 10110
   "jz"];   // 10111

enum Register {
  PC = 0,
  SP = 1,
  MAX = SP
}

alias vmint = uint32_t;

class VM {
  string[] strings;
  ubyte[] code;
  vmint[] data;
  vmint[] stack;
  vmint[Register.MAX + 1] registers;
}

class BadVMException : Exception
{
  this(string msg, string file = __FILE__, size_t line = __LINE__)
  {
    super(msg, file, line);
  }
}

class VMRuntimeException : Exception
{
  this(string msg, string file = __FILE__, size_t line = __LINE__)
  {
    super(msg, file, line);
  }
}

vmint
twosComplement (vmint x)
{
  // This computes the negative of x, if x is regarded as signed.
  pragma(inline);
  return (~x) + vmint(1U);
}

vmint
add (vmint x, vmint y)
{
  // This works whether x or y is regarded as unsigned or signed.
  pragma(inline);
  return x + y;
}

vmint
sub (vmint x, vmint y)
{
  // This works whether x or y is regarded as unsigned or signed.  
  pragma(inline);
  return x - y;
}

vmint
equality (vmint x, vmint y)
{
  pragma(inline);
  return vmint(x == y);
}

vmint
inequality (vmint x, vmint y)
{
  pragma(inline);
  return vmint(x != y);
}

vmint
signedLt (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) < int32_t(y));
}

vmint
signedGt (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) > int32_t(y));
}

vmint
signedLte (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) <= int32_t(y));
}

vmint
signedGte (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) >= int32_t(y));
}

vmint
signedMul (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) * int32_t(y));
}

vmint
signedDiv (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) / int32_t(y));
}

vmint
signedMod (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) % int32_t(y));
}

vmint
logicalNot (vmint x)
{
  pragma(inline);
  return vmint(!x);
}

vmint
logicalAnd (vmint x, vmint y)
{
  pragma(inline);
  return vmint((!!x) * (!!y));
}

vmint
logicalOr (vmint x, vmint y)
{
  pragma(inline);
  return (vmint(1) - vmint((!x) * (!y)));
}

vmint
parseDigits (string s, size_t i, size_t j)
{
  const badInteger = "bad integer";

  if (j == i)
    throw new BadVMException (badInteger);
  auto x = vmint(0);
  for (size_t k = i; k < j; k += 1)
    if (!isDigit (s[k]))
      throw new BadVMException (badInteger);
    else
      // The result is allowed to overflow freely.
      x = (vmint(10) * x) + vmint(s[k] - '0');
  return x;
}

vmint
parseInteger (string s, size_t i, size_t j)
{
  const badInteger = "bad integer";

  vmint retval;
  if (j == i)
    throw new BadVMException (badInteger);
  else if (j == i + vmint(1) && !isDigit (s[i]))
    throw new BadVMException (badInteger);
  else if (s[i] != '-')
    retval = parseDigits (s, i, j);
  else if (j == i + vmint(1))
    throw new BadVMException (badInteger);
  else
    retval = twosComplement (parseDigits (s, i + vmint(1), j));
  return retval;
}

size_t
skipWhitespace (string s, size_t n, size_t i)
{
  while (i < n && isWhite (s[i]))
    i += 1;
  return i;
}

size_t
skipNonwhitespace (string s, size_t n, size_t i)
{
  while (i < n && !isWhite (s[i]))
    i += 1;
  return i;
}

bool
substrEqual (string s, size_t i, size_t j, string t)
{
  // Is s[i .. j-1] equal to t?

  auto retval = false;
  auto m = t.length;
  if (m == j - i)
    {
      auto k = size_t(0);
      while (k < m && s[i + k] == t[k])
        k += 1;
      retval = (k == m);
    }
  return retval;
}

string
dequoteString (string s, size_t n)
{
  const badQuotedString = "bad quoted string";

  string t = "";
  s = strip(s);
  if (s.length < 2 || s[0] != '"' || s[$ - 1] != '"')
    throw new BadVMException (badQuotedString);
  auto i = 1;
  while (i < s.length - 1)
    if (s[i] != '\\')
      {
        t ~= s[i];
        i += 1;
      }
    else if (i + 1 == s.length - 1)
      throw new BadVMException (badQuotedString);
    else if (s[i + 1] == 'n')
      {
        t ~= '\n';
        i += 2;
      }
    else if (s[i + 1] == '\\')
      {
        t ~= '\\';
        i += 2;
      }
    else
      throw new BadVMException (badQuotedString);
  return t;
}

string[]
readStrings (File f, size_t stringsSize)
{
  const badQuotedString = "Bad quoted string.";

  string[] strings;
  strings.length = stringsSize;
  for (size_t k = 0; k < stringsSize; k += 1)
    {
      auto line = f.readln();
      strings[k] = dequoteString (line, line.length);
    }
  return strings;
}

ubyte
opcodeNameTo_ubyte (string str, size_t i, size_t j)
{
  size_t k = 0;
  while (k < opcodeOrder.length &&
         !substrEqual (str, i, j, opcodeOrder[k]))
    k += 1;
  if (k == opcodeOrder.length)
    throw new BadVMException ("unrecognized opcode name");
  return to!ubyte(k);
}

ubyte
vmintByte0 (vmint i)
{
  return (i & 0xFF);
}

ubyte
vmintByte1 (vmint i)
{
  return ((i >> 8) & 0xFF);
}

ubyte
vmintByte2 (vmint i)
{
  return ((i >> 16) & 0xFF);
}

ubyte
vmintByte3 (vmint i)
{
  return (i >> 24);
}

ubyte[]
parseInstruction (string line)
{
  const bad_instruction = "bad VM instruction";

  const n = line.length;
  auto i = skipWhitespace (line, n, 0);

  // Skip the address field.
  i = skipNonwhitespace (line, n, i);

  i = skipWhitespace (line, n, i);
  auto j = skipNonwhitespace (line, n, i);
  auto opcode = opcodeNameTo_ubyte (line, i, j);

  auto startOfArgument = j;

  ubyte[] finishPush ()
  {
    const i1 = skipWhitespace (line, n, startOfArgument);
    const j1 = skipNonwhitespace (line, n, i1);
    const arg = parseInteger (line, i1, j1);
    // Little-endian storage.
    return [opcode, vmintByte0 (arg), vmintByte1 (arg),
            vmintByte2 (arg), vmintByte3 (arg)];
  }

  ubyte[] finishFetchOrStore ()
  {
    const i1 = skipWhitespace (line, n, startOfArgument);
    const j1 = skipNonwhitespace (line, n, i1);
    if (j1 - i1 < 3 || line[i1] != '[' || line[j1 - 1] != ']')
      throw new BadVMException (bad_instruction);
    const arg = parseInteger (line, i1 + 1, j1 - 1);
    // Little-endian storage.
    return [opcode, vmintByte0 (arg), vmintByte1 (arg),
            vmintByte2 (arg), vmintByte3 (arg)];
  }

  ubyte[] finishJmpOrJz ()
  {
    const i1 = skipWhitespace (line, n, startOfArgument);
    const j1 = skipNonwhitespace (line, n, i1);
    if (j1 - i1 < 3 || line[i1] != '(' || line[j1 - 1] != ')')
      throw new BadVMException (bad_instruction);
    const arg = parseInteger (line, i1 + 1, j1 - 1);
    // Little-endian storage.
    return [opcode, vmintByte0 (arg), vmintByte1 (arg),
            vmintByte2 (arg), vmintByte3 (arg)];
  }

  ubyte[] retval;
  switch (opcode)
    {
    case Op.PUSH:
      retval = finishPush ();
      break;
    case Op.FETCH:
    case Op.STORE:
      retval = finishFetchOrStore ();
      break;
    case Op.JMP:
    case Op.JZ:
      retval = finishJmpOrJz ();
      break;
    default:
      retval = [opcode];
      break;
    }

  return retval;
}

ubyte[]
readCode (File f)
{
  // Read the instructions from the input, producing an array of
  // array of instruction bytes.
  ubyte[] code = [];
  auto line = f.readln();
  while (line !is null)
    {
      code ~= parseInstruction (line);
      line = f.readln();
    }
  return code;
}

void
parseHeaderLine (string line, ref size_t dataSize,
                 ref size_t stringsSize)
{
  const bad_vm_header_line = "bad VM header line";

  const n = line.length;
  auto i = skipWhitespace (line, n, 0);
  auto j = skipNonwhitespace (line, n, i);
  if (!substrEqual (line, i, j, "Datasize:"))
    throw new BadVMException (bad_vm_header_line);
  i = skipWhitespace (line, n, j);
  j = skipNonwhitespace (line, n, i);
  dataSize = parseInteger (line, i, j);
  i = skipWhitespace (line, n, j);
  j = skipNonwhitespace (line, n, i);
  if (!substrEqual (line, i, j, "Strings:"))
    throw new BadVMException (bad_vm_header_line);
  i = skipWhitespace (line, n, j);
  j = skipNonwhitespace (line, n, i);
  stringsSize = parseInteger (line, i, j);
}

VM
readVM (File f)
{
  const line = f.readln();

  size_t dataSize;
  size_t stringsSize;
  parseHeaderLine (line, dataSize, stringsSize);

  VM vm = new VM();
  vm.strings = readStrings (f, stringsSize);
  vm.code = readCode (f);
  vm.data.length = dataSize;
  vm.stack.length = 65536; // A VERY big stack, MUCH bigger than is
                           // "reasonable" for this VM. The same size
                           // as in the ATS, however.
  vm.registers[Register.PC] = vmint(0);
  vm.registers[Register.SP] = vmint(0);

  return vm;
}

vmint
pop (VM vm)
{
  pragma(inline);
  const spBefore = vm.registers[Register.SP];
  if (spBefore == 0)
    throw new VMRuntimeException ("stack underflow");
  const spAfter = spBefore - vmint(1);
  vm.registers[Register.SP] = spAfter;
  return vm.stack[spAfter];
}

void
push (VM vm, vmint x)
{
  pragma(inline);
  const spBefore = vm.registers[Register.SP];
  if (vm.stack.length <= spBefore)
    throw new VMRuntimeException ("stack overflow");
  vm.stack[spBefore] = x;
  const spAfter = spBefore + vmint(1);
  vm.registers[Register.SP] = spAfter;
}

vmint
fetchData (VM vm, vmint index)
{
  pragma(inline);
  if (vm.data.length <= index)
    throw new VMRuntimeException
      ("fetch from outside the data section");
  return vm.data[index];
}

void
storeData (VM vm, vmint index, vmint x)
{
  pragma(inline);
  if (vm.data.length <= index)
    throw new VMRuntimeException
      ("store to outside the data section");
  vm.data[index] = x;
}

vmint
getArgument (VM vm)
{
  pragma(inline);
  auto pc = vm.registers[Register.PC];
  if (vm.code.length <= pc + vmint(4))
    throw new VMRuntimeException
      ("the program counter is out of bounds");
  // The data is stored little-endian.
  const byte0 = vmint (vm.code[pc]);
  const byte1 = vmint (vm.code[pc + vmint(1)]);
  const byte2 = vmint (vm.code[pc + vmint(2)]);
  const byte3 = vmint (vm.code[pc + vmint(3)]);
  return (byte0) | (byte1 << 8) | (byte2 << 16) | (byte3 << 24);
}

void
skipArgument (VM vm)
{
  pragma(inline);
  vm.registers[Register.PC] += vmint(4);
}

//
// The string mixins below are going to do for us *some* of what the
// ATS template system did for us. The two methods hardly resemble
// each other, but both can be used to construct function definitions
// at compile time.
//

template
UnaryOperation (alias name, alias func)
{
  const char[] UnaryOperation =
    "void " ~
    name ~ " (VM vm)
    {
      pragma(inline);
      const sp = vm.registers[Register.SP];
      if (sp == vmint(0))
        throw new VMRuntimeException (\"stack underflow\");
      const x = vm.stack[sp - vmint(1)];
      const z = " ~ func ~ " (x);
      vm.stack[sp - vmint(1)] = z;
    }";
}

template
BinaryOperation (alias name, alias func)
{
  const char[] BinaryOperation =
    "void " ~
    name ~ " (VM vm)
    {
      pragma(inline);
      const spBefore = vm.registers[Register.SP];
      if (spBefore <= vmint(1))
        throw new VMRuntimeException (\"stack underflow\");
      const spAfter = spBefore - vmint(1);
      vm.registers[Register.SP] = spAfter;
      const x = vm.stack[spAfter - vmint(1)];
      const y = vm.stack[spAfter];
      const z = " ~ func ~ "(x, y);
      vm.stack[spAfter - vmint(1)] = z;
    }";
}

mixin (UnaryOperation!("uopNeg", "twosComplement"));
mixin (UnaryOperation!("uopNot", "logicalNot"));

mixin (BinaryOperation!("binopAdd", "add"));
mixin (BinaryOperation!("binopSub", "sub"));
mixin (BinaryOperation!("binopMul", "signedMul"));
mixin (BinaryOperation!("binopDiv", "signedDiv"));
mixin (BinaryOperation!("binopMod", "signedMod"));
mixin (BinaryOperation!("binopEq", "equality"));
mixin (BinaryOperation!("binopNe", "inequality"));
mixin (BinaryOperation!("binopLt", "signedLt"));
mixin (BinaryOperation!("binopGt", "signedGt"));
mixin (BinaryOperation!("binopLe", "signedLte"));
mixin (BinaryOperation!("binopGe", "signedGte"));
mixin (BinaryOperation!("binopAnd", "logicalAnd"));
mixin (BinaryOperation!("binopOr", "logicalOr"));

void
doPush (VM vm)
{
  pragma(inline);
  const arg = getArgument (vm);
  push (vm, arg);
  skipArgument (vm);
}

void
doFetch (VM vm)
{
  pragma(inline);
  const i = getArgument (vm);
  const x = fetchData (vm, i);
  push (vm, x);
  skipArgument (vm);
}

void
doStore (VM vm)
{
  pragma(inline);
  const i = getArgument (vm);
  const x = pop (vm);
  storeData (vm, i, x);
  skipArgument (vm);
}

void
doJmp (VM vm)
{
  pragma(inline);
  const arg = getArgument (vm);
  vm.registers[Register.PC] += arg;
}

void
doJz (VM vm)
{
  pragma(inline);
  const x = pop (vm);
  if (x == vmint(0))
    doJmp (vm);
  else
    skipArgument (vm);
}

void
doPrtc (File fOut, VM vm)
{
  const x = pop (vm);
  fOut.write (to!char(x));
}

void
doPrti (File fOut, VM vm)
{
  const x = pop (vm);
  fOut.write (int32_t(x));
}

void
doPrts (File fOut, VM vm)
{
  const i = pop (vm);
  if (vm.strings.length <= i)
    throw new VMRuntimeException ("string index out of bounds");
  fOut.write (vm.strings[i]);
}

void
vmStep (File fOut, VM vm, ref bool machineHalt, ref bool badOpcode)
{
  const pc = vm.registers[Register.PC];
  if (vm.code.length <= pc)
    throw new VMRuntimeException
      ("the program counter is out of bounds");
  vm.registers[Register.PC] = pc + vmint(1);
  const opcode = vm.code[pc];
  const uOpcode = uint(opcode);

  // Dispatch by bifurcation on the bit pattern of the opcode. This
  // method is logarithmic in the number of opcode values.

  machineHalt = false;
  badOpcode = false;
  if ((uOpcode & (~0x1FU)) == 0U)
    {
      if ((uOpcode & 0x10U) == 0U)
        {
          if ((uOpcode & 0x08U) == 0U)
            {
              if ((uOpcode & 0x04U) == 0U)
                {
                  if ((uOpcode & 0x02U) == 0U)
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        machineHalt = true;
                      else
                        binopAdd (vm);
                    }
                  else
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        binopSub (vm);
                      else
                        binopMul (vm);
                    }
                }
              else
                {
                  if ((uOpcode & 0x02U) == 0U)
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        binopDiv (vm);
                      else
                        binopMod (vm);
                    }
                  else
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        binopLt (vm);
                      else
                        binopGt (vm);
                    }
                }
            }
          else
            {
              if ((uOpcode & 0x04U) == 0U)
                {
                  if ((uOpcode & 0x02U) == 0U)
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        binopLe (vm);
                      else
                        binopGe (vm);
                    }
                  else
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        binopEq (vm);
                      else
                        binopNe (vm);
                    }
                }
              else
                {
                  if ((uOpcode & 0x02U) == 0U)
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        binopAnd (vm);
                      else
                        binopOr (vm);
                    }
                  else
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        uopNeg (vm);
                      else
                        uopNot (vm);
                    }
                }
            }
        }
      else
        {
          if ((uOpcode & 0x08U) == 0U)
            {
              if ((uOpcode & 0x04U) == 0U)
                {
                  if ((uOpcode & 0x02U) == 0U)
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        doPrtc (fOut, vm);
                      else
                        doPrti (fOut, vm);
                    }
                  else
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        doPrts (fOut, vm);
                      else
                        doFetch (vm);
                    }
                }
              else
                {
                  if ((uOpcode & 0x02U) == 0U)
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        doStore (vm);
                      else
                        doPush (vm);
                    }
                  else
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        doJmp (vm);
                      else
                        doJz (vm);
                    }
                }
            }
          else
            badOpcode = true;
        }
    }
  else
    badOpcode = true;
}

void
vmContinue (File fOut, VM vm)
{
  auto machineHalt = false;
  auto badOpcode = false;
  while (!machineHalt && !badOpcode)
    vmStep (fOut, vm, machineHalt, badOpcode);
  if (badOpcode)
    throw new VMRuntimeException ("unrecognized opcode at runtime");
}

void
vmInitialize (VM vm)
{
  foreach (ref x; vm.data)
    x = vmint(0);
  vm.registers[Register.PC] = vmint(0);
  vm.registers[Register.SP] = vmint(0);
}

void
vmRun (File fOut, VM vm)
{
  vmInitialize (vm);
  vmContinue (fOut, vm);
}

void
ensure_that_vmint_is_suitable ()
{
  // Try to guarantee that vmint is exactly 32 bits, and that it
  // allows overflow in either direction.
  assert (vmint(0xFFFFFFFFU) + vmint(1U) == vmint(0U));
  assert (vmint(0U) - vmint(1U) == vmint(0xFFFFFFFFU));
  assert (vmint(-1234) == twosComplement (vmint(1234)));
}

int
main (char[][] args)
{
  auto inpFilename = "-";
  auto outFilename = "-";
  if (2 <= args.length)
    inpFilename = to!string (args[1]);
  if (3 <= args.length)
    outFilename = to!string (args[2]);

  auto inpF = stdin;
  if (inpFilename != "-")
    inpF = File (inpFilename, "r");
  auto vm = readVM (inpF);
  if (inpFilename != "-")
    inpF.close();

  auto outF = stdout;
  if (outFilename != "-")
    outF = File (outFilename, "w");
  ensure_that_vmint_is_suitable ();
  vmRun (outF, vm);
  if (outFilename != "-")
    outF.close();

  return 0;
}


Output:
$ gdc -Wall -Wextra -fno-bounds-check -O3 -march=native -fno-stack-protector vm_in_D.d && ./a.out compiler-tests/count.vm
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9


Forth

Tested with Gforth 0.7.3

CREATE BUF 0 ,              \ single-character look-ahead buffer
: PEEK   BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: GETC   PEEK  0 BUF ! ;
: SPACE?   DUP BL = SWAP 9 14 WITHIN OR ;
: >SPACE   BEGIN PEEK SPACE? WHILE GETC DROP REPEAT ;
: DIGIT?   48 58 WITHIN ;
: >INT ( -- n)   >SPACE  0
   BEGIN  PEEK DIGIT?
   WHILE  GETC [CHAR] 0 -  SWAP 10 * +  REPEAT ;
CREATE A 0 ,
: C@A ( -- c)  A @ C@ ;
: C@A+ ( -- c)  C@A  1 CHARS A +! ;
: C!A+ ( c --)  A @ C!  1 CHARS A +! ;
: WORD ( -- c-addr)  >SPACE  PAD 1+ A !
   BEGIN PEEK SPACE? INVERT WHILE GETC C!A+ REPEAT
   >SPACE  PAD A @ OVER - 1- PAD C! ;
: >STRING ( -- c-addr)  >SPACE GETC DROP  PAD 1+ A !
   BEGIN PEEK [CHAR] " <> WHILE GETC C!A+ REPEAT
   GETC DROP  PAD A @ OVER - 1- PAD C! ;
: \INTERN ( c-addr -- c-addr)  HERE >R  A ! C@A+ DUP C,
   BEGIN DUP WHILE C@A+  
     DUP [CHAR] \ = IF DROP -1 R@ +!  C@A+ 
       [CHAR] n = IF 10 ELSE [CHAR] \ THEN
     THEN C,  1-
   REPEAT  DROP R> ;
: .   0 .R ;

CREATE DATA 0 ,
CREATE STRINGS 0 ,
: >DATA   HERE DATA !
   WORD DROP  >INT 4 * BEGIN DUP WHILE 0 C, 1- REPEAT DROP ;
: >STRINGS   HERE STRINGS !
   WORD DROP  >INT DUP >R CELLS  ALLOT
   0 BEGIN DUP R@ < WHILE 
     DUP CELLS >STRING \INTERN STRINGS @ ROT + !  1+
   REPEAT R> DROP DROP ;
: >HEADER   >DATA >STRINGS ;
: i32! ( n addr --)
   OVER           $FF AND OVER C! 1+
   OVER  8 RSHIFT $FF AND OVER C! 1+
   OVER 16 RSHIFT $FF AND OVER C! 1+
   SWAP 24 RSHIFT $FF AND SWAP C! ;
: i32@ ( addr -- n) >R  \ This is kinda slow... hmm
   R@     C@
   R@ 1 + C@  8 LSHIFT OR
   R@ 2 + C@ 16 LSHIFT OR
   R> 3 + C@ 24 LSHIFT OR
   DUP $7FFFFFFF AND SWAP $80000000 AND - ;  \ sign extend
: i32, ( n --)  HERE  4 ALLOT  i32! ;
: i32@+ ( -- n)  A @ i32@  A @ 4 + A ! ;
CREATE BYTECODE 0 ,
: @fetch   i32@+ 4 * DATA @ + i32@ ;
: @store   i32@+ 4 * DATA @ + i32! ;
: @jmp     i32@+ BYTECODE @ + A ! ;
: @jz      IF 4 A +! ELSE @jmp THEN ;
: @prts    CELLS STRINGS @ + @ COUNT TYPE ;
: @div     >R S>D R> SM/REM SWAP DROP ;
CREATE OPS
' @fetch , ' @store , ' i32@+ , ' @jmp ,   ' @jz ,
' EMIT ,   ' . ,      ' @prts , ' NEGATE , ' 0= ,
' + ,      ' - ,      ' * ,     ' @div ,   ' MOD ,
' < ,      ' > ,      ' <= ,    ' >= ,
' = ,      ' <> ,     ' AND ,   ' OR ,     ' BYE ,
CREATE #OPS 0 ,
: OP:   CREATE #OPS @ ,  1 #OPS +!  DOES> @ ;
OP: fetch  OP: store  OP: push  OP: jmp  OP: jz
OP: prtc   OP: prti   OP: prts  OP: neg  OP: not
OP: add    OP: sub    OP: mul   OP: div  OP: mod
OP: lt     OP: gt     OP: le    OP: ge
OP: eq     OP: ne     OP: and   OP: or   OP: halt
: >OP   WORD FIND
   0= IF ." Unrecognized opcode" ABORT THEN EXECUTE ;
: >i32   >INT i32, ;
: >[i32]  GETC DROP >i32 GETC DROP ;
: >OFFSET   WORD DROP ( drop relative offset) >i32 ;
CREATE >PARAM  ' >[i32] DUP , , ' >i32 , ' >OFFSET DUP , ,
: >BYTECODE   HERE >R
   BEGIN >INT DROP  >OP >R  R@ C,
     R@ 5 < IF R@ CELLS >PARAM + @ EXECUTE THEN
   R> halt = UNTIL  R> BYTECODE ! ;
: RUN   BYTECODE @ A !
   BEGIN C@A+ CELLS OPS + @ EXECUTE AGAIN ;
>HEADER >BYTECODE RUN

Fortran

Works with: gfortran version 11.2.1

Fortran 2008/2018 code with some limited use of the C preprocessor. If you are on a platform with case-sensitive filenames, and call the source file vm.F90, then gfortran will know to use the C preprocessor.

module compiler_type_kinds
  use, intrinsic :: iso_fortran_env, only: int32
  use, intrinsic :: iso_fortran_env, only: int64

  implicit none
  private

  ! Synonyms.
  integer, parameter, public :: size_kind = int64
  integer, parameter, public :: length_kind = size_kind
  integer, parameter, public :: nk = size_kind

  ! Synonyms for character capable of storing a Unicode code point.
  integer, parameter, public :: unicode_char_kind = selected_char_kind ('ISO_10646')
  integer, parameter, public :: ck = unicode_char_kind

  ! Synonyms for integers capable of storing a Unicode code point.
  integer, parameter, public :: unicode_ichar_kind = int32
  integer, parameter, public :: ick = unicode_ichar_kind

  ! Synonyms for integers in the virtual machine or the interpreter’s
  ! runtime. (The Rosetta Code task says integers in the virtual
  ! machine are 32-bit, but there is nothing in the task that prevents
  ! us using 64-bit integers in the compiler and interpreter.)
  integer, parameter, public :: runtime_int_kind = int64
  integer, parameter, public :: rik = runtime_int_kind
end module compiler_type_kinds

module helpers
  use, non_intrinsic :: compiler_type_kinds, only: nk, rik, ck

  implicit none
  private

  public :: new_storage_size
  public :: next_power_of_two

  public :: isspace
  public :: quoted_string

  public :: int32_to_vm_bytes
  public :: uint32_to_vm_bytes
  public :: int32_from_vm_bytes
  public :: uint32_from_vm_bytes

  public :: bool2int

  character(1, kind = ck), parameter, public :: horizontal_tab_char = char (9, kind = ck)
  character(1, kind = ck), parameter, public :: linefeed_char = char (10, kind = ck)
  character(1, kind = ck), parameter, public :: vertical_tab_char = char (11, kind = ck)
  character(1, kind = ck), parameter, public :: formfeed_char = char (12, kind = ck)
  character(1, kind = ck), parameter, public :: carriage_return_char = char (13, kind = ck)
  character(1, kind = ck), parameter, public :: space_char = ck_' '

  ! The following is correct for Unix and its relatives.
  character(1, kind = ck), parameter, public :: newline_char = linefeed_char

  character(1, kind = ck), parameter, public :: backslash_char = char (92, kind = ck)

contains

  elemental function new_storage_size (length_needed) result (size)
    integer(kind = nk), intent(in) :: length_needed
    integer(kind = nk) :: size

    ! Increase storage by orders of magnitude.

    if (2_nk**32 < length_needed) then
       size = huge (1_nk)
    else
       size = next_power_of_two (length_needed)
    end if
  end function new_storage_size

  elemental function next_power_of_two (x) result (y)
    integer(kind = nk), intent(in) :: x
    integer(kind = nk) :: y

    !
    ! It is assumed that no more than 64 bits are used.
    !
    ! The branch-free algorithm is that of
    ! https://archive.is/nKxAc#RoundUpPowerOf2
    !
    ! Fill in bits until one less than the desired power of two is
    ! reached, and then add one.
    !

    y = x - 1
    y = ior (y, ishft (y, -1))
    y = ior (y, ishft (y, -2))
    y = ior (y, ishft (y, -4))
    y = ior (y, ishft (y, -8))
    y = ior (y, ishft (y, -16))
    y = ior (y, ishft (y, -32))
    y = y + 1
  end function next_power_of_two

  elemental function isspace (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool

    bool = (ch == horizontal_tab_char) .or.  &
         & (ch == linefeed_char) .or.        &
         & (ch == vertical_tab_char) .or.    &
         & (ch == formfeed_char) .or.        &
         & (ch == carriage_return_char) .or. &
         & (ch == space_char)
  end function isspace

  function quoted_string (str) result (qstr)
    character(*, kind = ck), intent(in) :: str
    character(:, kind = ck), allocatable :: qstr

    integer(kind = nk) :: n, i, j

    ! Compute n = the size of qstr.
    n = 2_nk
    do i = 1_nk, len (str, kind = nk)
       select case (str(i:i))
       case (newline_char, backslash_char)
          n = n + 2
       case default
          n = n + 1
       end select
    end do

    allocate (character(n, kind = ck) :: qstr)

    ! Quote the string.
    qstr(1:1) = ck_'"'
    j = 2_nk
    do i = 1_nk, len (str, kind = nk)
       select case (str(i:i))
       case (newline_char)
          qstr(j:j) = backslash_char
          qstr((j + 1):(j + 1)) = ck_'n'
          j = j + 2
       case (backslash_char)
          qstr(j:j) = backslash_char
          qstr((j + 1):(j + 1)) = backslash_char
          j = j + 2
       case default
          qstr(j:j) = str(i:i)
          j = j + 1
       end select
    end do
    if (j /= n) error stop      ! Check code correctness.
    qstr(n:n) = ck_'"'
  end function quoted_string

  subroutine int32_to_vm_bytes (n, bytes, i)
    integer(kind = rik), intent(in) :: n
    character(1), intent(inout) :: bytes(0:*)
    integer(kind = rik), intent(in) :: i

    !
    ! The virtual machine is presumed to be little-endian. Because I
    ! slightly prefer little-endian.
    !

    bytes(i) = achar (ibits (n, 0, 8))
    bytes(i + 1) = achar (ibits (n, 8, 8))
    bytes(i + 2) = achar (ibits (n, 16, 8))
    bytes(i + 3) = achar (ibits (n, 24, 8))
  end subroutine int32_to_vm_bytes

  subroutine uint32_to_vm_bytes (n, bytes, i)
    integer(kind = rik), intent(in) :: n
    character(1), intent(inout) :: bytes(0:*)
    integer(kind = rik), intent(in) :: i

    call int32_to_vm_bytes (n, bytes, i)
  end subroutine uint32_to_vm_bytes

  subroutine int32_from_vm_bytes (n, bytes, i)
    integer(kind = rik), intent(out) :: n
    character(1), intent(in) :: bytes(0:*)
    integer(kind = rik), intent(in) :: i

    !
    ! The virtual machine is presumed to be little-endian. Because I
    ! slightly prefer little-endian.
    !

    call uint32_from_vm_bytes (n, bytes, i)
    if (ibits (n, 31, 1) == 1) then
       ! Extend the sign bit.
       n = ior (n, not ((2_rik ** 32) - 1))
    end if
  end subroutine int32_from_vm_bytes

  subroutine uint32_from_vm_bytes (n, bytes, i)
    integer(kind = rik), intent(out) :: n
    character(1), intent(in) :: bytes(0:*)
    integer(kind = rik), intent(in) :: i

    !
    ! The virtual machine is presumed to be little-endian. Because I
    ! slightly prefer little-endian.
    !

    integer(kind = rik) :: n0, n1, n2, n3

    n0 = iachar (bytes(i), kind = rik)
    n1 = ishft (iachar (bytes(i + 1), kind = rik), 8)
    n2 = ishft (iachar (bytes(i + 2), kind = rik), 16)
    n3 = ishft (iachar (bytes(i + 3), kind = rik), 24)
    n = ior (n0, ior (n1, ior (n2, n3)))
  end subroutine uint32_from_vm_bytes

  elemental function bool2int (bool) result (int)
    logical, intent(in) :: bool
    integer(kind = rik) :: int

    if (bool) then
       int = 1_rik
    else
       int = 0_rik
    end if
  end function bool2int

end module helpers

module string_buffers
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, intrinsic :: iso_fortran_env, only: int64
  use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
  use, non_intrinsic :: helpers

  implicit none
  private

  public :: strbuf_t
  public :: skip_whitespace
  public :: skip_non_whitespace
  public :: skip_whitespace_backwards
  public :: at_end_of_line

  type :: strbuf_t
     integer(kind = nk), private :: len = 0
     !
     ! ‘chars’ is made public for efficient access to the individual
     ! characters.
     !
     character(1, kind = ck), allocatable, public :: chars(:)
   contains
     procedure, pass, private :: ensure_storage => strbuf_t_ensure_storage
     procedure, pass :: to_unicode_full_string => strbuf_t_to_unicode_full_string
     procedure, pass :: to_unicode_substring => strbuf_t_to_unicode_substring
     procedure, pass :: length => strbuf_t_length
     procedure, pass :: set => strbuf_t_set
     procedure, pass :: append => strbuf_t_append
     generic :: to_unicode => to_unicode_full_string
     generic :: to_unicode => to_unicode_substring
     generic :: assignment(=) => set
  end type strbuf_t

contains

  function strbuf_t_to_unicode_full_string (strbuf) result (s)
    class(strbuf_t), intent(in) :: strbuf
    character(:, kind = ck), allocatable :: s

    !
    ! This does not actually ensure that the string is valid Unicode;
    ! any 31-bit ‘character’ is supported.
    !

    integer(kind = nk) :: i

    allocate (character(len = strbuf%len, kind = ck) :: s)
    do i = 1, strbuf%len
       s(i:i) = strbuf%chars(i)
    end do
  end function strbuf_t_to_unicode_full_string

  function strbuf_t_to_unicode_substring (strbuf, i, j) result (s)
    !
    ! ‘Extreme’ values of i and j are allowed, as shortcuts for ‘from
    ! the beginning’, ‘up to the end’, or ‘empty substring’.
    !
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i, j
    character(:, kind = ck), allocatable :: s

    !
    ! This does not actually ensure that the string is valid Unicode;
    ! any 31-bit ‘character’ is supported.
    !

    integer(kind = nk) :: i1, j1
    integer(kind = nk) :: n
    integer(kind = nk) :: k

    i1 = max (1_nk, i)
    j1 = min (strbuf%len, j)
    n = max (0_nk, (j1 - i1) + 1_nk)

    allocate (character(n, kind = ck) :: s)
    do k = 1, n
       s(k:k) = strbuf%chars(i1 + (k - 1_nk))
    end do
  end function strbuf_t_to_unicode_substring

  elemental function strbuf_t_length (strbuf) result (n)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk) :: n

    n = strbuf%len
  end function strbuf_t_length

  subroutine strbuf_t_ensure_storage (strbuf, length_needed)
    class(strbuf_t), intent(inout) :: strbuf
    integer(kind = nk), intent(in) :: length_needed

    integer(kind = nk) :: len_needed
    integer(kind = nk) :: new_size
    type(strbuf_t) :: new_strbuf

    len_needed = max (length_needed, 1_nk)

    if (.not. allocated (strbuf%chars)) then
       ! Initialize a new strbuf%chars array.
       new_size = new_storage_size (len_needed)
       allocate (strbuf%chars(1:new_size))
    else if (ubound (strbuf%chars, 1) < len_needed) then
       ! Allocate a new strbuf%chars array, larger than the current
       ! one, but containing the same characters.
       new_size = new_storage_size (len_needed)
       allocate (new_strbuf%chars(1:new_size))
       new_strbuf%chars(1:strbuf%len) = strbuf%chars(1:strbuf%len)
       call move_alloc (new_strbuf%chars, strbuf%chars)
    end if
  end subroutine strbuf_t_ensure_storage

  subroutine strbuf_t_set (dst, src)
    class(strbuf_t), intent(inout) :: dst
    class(*), intent(in) :: src

    integer(kind = nk) :: n
    integer(kind = nk) :: i

    select type (src)
    type is (character(*, kind = ck))
       n = len (src, kind = nk)
       call dst%ensure_storage(n)
       do i = 1, n
          dst%chars(i) = src(i:i)
       end do
       dst%len = n
    type is (character(*))
       n = len (src, kind = nk)
       call dst%ensure_storage(n)
       do i = 1, n
          dst%chars(i) = src(i:i)
       end do
       dst%len = n
    class is (strbuf_t)
       n = src%len
       call dst%ensure_storage(n)
       dst%chars(1:n) = src%chars(1:n)
       dst%len = n
    class default
       error stop
    end select
  end subroutine strbuf_t_set

  subroutine strbuf_t_append (dst, src)
    class(strbuf_t), intent(inout) :: dst
    class(*), intent(in) :: src

    integer(kind = nk) :: n_dst, n_src, n
    integer(kind = nk) :: i

    select type (src)
    type is (character(*, kind = ck))
       n_dst = dst%len
       n_src = len (src, kind = nk)
       n = n_dst + n_src
       call dst%ensure_storage(n)
       do i = 1, n_src
          dst%chars(n_dst + i) = src(i:i)
       end do
       dst%len = n
    type is (character(*))
       n_dst = dst%len
       n_src = len (src, kind = nk)
       n = n_dst + n_src
       call dst%ensure_storage(n)
       do i = 1, n_src
          dst%chars(n_dst + i) = src(i:i)
       end do
       dst%len = n
    class is (strbuf_t)
       n_dst = dst%len
       n_src = src%len
       n = n_dst + n_src
       call dst%ensure_storage(n)
       dst%chars((n_dst + 1):n) = src%chars(1:n_src)
       dst%len = n
    class default
       error stop
    end select
  end subroutine strbuf_t_append

  function skip_whitespace (strbuf, i) result (j)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    integer(kind = nk) :: j

    logical :: done

    j = i
    done = .false.
    do while (.not. done)
       if (at_end_of_line (strbuf, j)) then
          done = .true.
       else if (.not. isspace (strbuf%chars(j))) then
          done = .true.
       else
          j = j + 1
       end if
    end do
  end function skip_whitespace

  function skip_non_whitespace (strbuf, i) result (j)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    integer(kind = nk) :: j

    logical :: done

    j = i
    done = .false.
    do while (.not. done)
       if (at_end_of_line (strbuf, j)) then
          done = .true.
       else if (isspace (strbuf%chars(j))) then
          done = .true.
       else
          j = j + 1
       end if
    end do
  end function skip_non_whitespace

  function skip_whitespace_backwards (strbuf, i) result (j)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    integer(kind = nk) :: j

    logical :: done

    j = i
    done = .false.
    do while (.not. done)
       if (j == -1) then
          done = .true.
       else if (.not. isspace (strbuf%chars(j))) then
          done = .true.
       else
          j = j - 1
       end if
    end do
  end function skip_whitespace_backwards

  function at_end_of_line (strbuf, i) result (bool)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    logical :: bool

    bool = (strbuf%length() < i)
  end function at_end_of_line

end module string_buffers

module reading_one_line_from_a_stream
  use, intrinsic :: iso_fortran_env, only: input_unit
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
  use, non_intrinsic :: string_buffers

  implicit none
  private

  ! get_line_from_stream: read an entire input line from a stream into
  ! a strbuf_t.
  public :: get_line_from_stream

  character(1, kind = ck), parameter :: linefeed_char = char (10, kind = ck)

  ! The following is correct for Unix and its relatives.
  character(1, kind = ck), parameter :: newline_char = linefeed_char

contains

  subroutine get_line_from_stream (unit_no, eof, no_newline, strbuf)
    integer, intent(in) :: unit_no
    logical, intent(out) :: eof ! End of file?
    logical, intent(out) :: no_newline ! There is a line but it has no
                                       ! newline? (Thus eof also must
                                       ! be .true.)
    class(strbuf_t), intent(inout) :: strbuf

    character(1, kind = ck) :: ch

    strbuf = ''
    call get_ch (unit_no, eof, ch)
    do while (.not. eof .and. ch /= newline_char)
       call strbuf%append (ch)
       call get_ch (unit_no, eof, ch)
    end do
    no_newline = eof .and. (strbuf%length() /= 0)
  end subroutine get_line_from_stream

  subroutine get_ch (unit_no, eof, ch)
    !
    ! Read a single code point from the stream.
    !
    ! Currently this procedure simply inputs ‘ASCII’ bytes rather than
    ! Unicode code points.
    !
    integer, intent(in) :: unit_no
    logical, intent(out) :: eof
    character(1, kind = ck), intent(out) :: ch

    integer :: stat
    character(1) :: c = '*'

    eof = .false.

    if (unit_no == input_unit) then
       call get_input_unit_char (c, stat)
    else
       read (unit = unit_no, iostat = stat) c
    end if

    if (stat < 0) then
       ch = ck_'*'
       eof = .true.
    else if (0 < stat) then
       write (error_unit, '("Input error with status code ", I0)') stat
       stop 1
    else
       ch = char (ichar (c, kind = ick), kind = ck)
    end if
  end subroutine get_ch

!!!
!!! If you tell gfortran you want -std=f2008 or -std=f2018, you likely
!!! will need to add also -fall-intrinsics or -U__GFORTRAN__
!!!
!!! The first way, you get the FGETC intrinsic. The latter way, you
!!! get the C interface code that uses getchar(3).
!!!
#ifdef __GFORTRAN__

  subroutine get_input_unit_char (c, stat)
    !
    ! The following works if you are using gfortran.
    !
    ! (FGETC is considered a feature for backwards compatibility with
    ! g77. However, I know of no way to reconfigure input_unit as a
    ! Fortran 2003 stream, for use with ordinary ‘read’.)
    !
    character, intent(inout) :: c
    integer, intent(out) :: stat

    call fgetc (input_unit, c, stat)
  end subroutine get_input_unit_char

#else

  subroutine get_input_unit_char (c, stat)
    !
    ! An alternative implementation of get_input_unit_char. This
    ! actually reads input from the C standard input, which might not
    ! be the same as input_unit.
    !
    use, intrinsic :: iso_c_binding, only: c_int
    character, intent(inout) :: c
    integer, intent(out) :: stat

    interface
       !
       ! Use getchar(3) to read characters from standard input. This
       ! assumes there is actually such a function available, and that
       ! getchar(3) does not exist solely as a macro. (One could write
       ! one’s own getchar() if necessary, of course.)
       !
       function getchar () result (c) bind (c, name = 'getchar')
         use, intrinsic :: iso_c_binding, only: c_int
         integer(kind = c_int) :: c
       end function getchar
    end interface

    integer(kind = c_int) :: i_char

    i_char = getchar ()
    !
    ! The C standard requires that EOF have a negative value. If the
    ! value returned by getchar(3) is not EOF, then it will be
    ! representable as an unsigned char. Therefore, to check for end
    ! of file, one need only test whether i_char is negative.
    !
    if (i_char < 0) then
       stat = -1
    else
       stat = 0
       c = char (i_char)
    end if
  end subroutine get_input_unit_char

#endif

end module reading_one_line_from_a_stream

module vm_reader
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, non_intrinsic :: compiler_type_kinds
  use, non_intrinsic :: helpers
  use, non_intrinsic :: string_buffers
  use, non_intrinsic :: reading_one_line_from_a_stream

  implicit none
  private

  public :: vm_code_t
  public :: vm_t
  public :: read_vm

  !
  ! Arbitrarily chosen opcodes.
  !
  ! I think there should be a no-operation ‘nop’ opcode, to reserve
  ! space for later hand-patching. :)
  !
  integer, parameter, public :: opcode_nop = 0
  integer, parameter, public :: opcode_halt = 1
  integer, parameter, public :: opcode_add = 2
  integer, parameter, public :: opcode_sub = 3
  integer, parameter, public :: opcode_mul = 4
  integer, parameter, public :: opcode_div = 5
  integer, parameter, public :: opcode_mod = 6
  integer, parameter, public :: opcode_lt = 7
  integer, parameter, public :: opcode_gt = 8
  integer, parameter, public :: opcode_le = 9
  integer, parameter, public :: opcode_ge = 10
  integer, parameter, public :: opcode_eq = 11
  integer, parameter, public :: opcode_ne = 12
  integer, parameter, public :: opcode_and = 13
  integer, parameter, public :: opcode_or = 14
  integer, parameter, public :: opcode_neg = 15
  integer, parameter, public :: opcode_not = 16
  integer, parameter, public :: opcode_prtc = 17
  integer, parameter, public :: opcode_prti = 18
  integer, parameter, public :: opcode_prts = 19
  integer, parameter, public :: opcode_fetch = 20
  integer, parameter, public :: opcode_store = 21
  integer, parameter, public :: opcode_push = 22
  integer, parameter, public :: opcode_jmp = 23
  integer, parameter, public :: opcode_jz = 24

  character(8, kind = ck), parameter, public :: opcode_names(0:24) = &
       & (/ "nop     ",   &
       &    "halt    ",   &
       &    "add     ",   &
       &    "sub     ",   &
       &    "mul     ",   &
       &    "div     ",   &
       &    "mod     ",   &
       &    "lt      ",   &
       &    "gt      ",   &
       &    "le      ",   &
       &    "ge      ",   &
       &    "eq      ",   &
       &    "ne      ",   &
       &    "and     ",   &
       &    "or      ",   &
       &    "neg     ",   &
       &    "not     ",   &
       &    "prtc    ",   &
       &    "prti    ",   &
       &    "prts    ",   &
       &    "fetch   ",   &
       &    "store   ",   &
       &    "push    ",   &
       &    "jmp     ",   &
       &    "jz      " /)

  type :: vm_code_t
     integer(kind = rik), private :: len = 0_rik
     character(1), allocatable :: bytes(:)
   contains
     procedure, pass, private :: ensure_storage => vm_code_t_ensure_storage
     procedure, pass :: length => vm_code_t_length
  end type vm_code_t

  type :: vm_t
     integer(kind = rik), allocatable :: string_boundaries(:)
     character(:, kind = ck), allocatable :: strings
     character(1), allocatable :: data(:)
     character(1), allocatable :: stack(:)
     type(vm_code_t) :: code
     integer(kind = rik) :: sp = 0_rik
     integer(kind = rik) :: pc = 0_rik
  end type vm_t

contains

  subroutine vm_code_t_ensure_storage (code, length_needed)
    class(vm_code_t), intent(inout) :: code
    integer(kind = nk), intent(in) :: length_needed

    integer(kind = nk) :: len_needed
    integer(kind = nk) :: new_size
    type(vm_code_t) :: new_code

    len_needed = max (length_needed, 1_nk)

    if (.not. allocated (code%bytes)) then
       ! Initialize a new code%bytes array.
       new_size = new_storage_size (len_needed)
       allocate (code%bytes(0:(new_size - 1)))
    else if (ubound (code%bytes, 1) < len_needed - 1) then
       ! Allocate a new code%bytes array, larger than the current one,
       ! but containing the same bytes.
       new_size = new_storage_size (len_needed)
       allocate (new_code%bytes(0:(new_size - 1)))
       new_code%bytes(0:(code%len - 1)) = code%bytes(0:(code%len - 1))
       call move_alloc (new_code%bytes, code%bytes)
    end if
  end subroutine vm_code_t_ensure_storage

  elemental function vm_code_t_length (code) result (len)
    class(vm_code_t), intent(in) :: code
    integer(kind = rik) :: len

    len = code%len
  end function vm_code_t_length

  subroutine read_vm (inp, strbuf, vm)
    integer, intent(in) :: inp
    type(strbuf_t), intent(inout) :: strbuf
    type(vm_t), intent(out) :: vm

    integer(kind = rik) :: data_size
    integer(kind = rik) :: number_of_strings

    ! Read the header.
    call read_datasize_and_number_of_strings (inp, strbuf, data_size, number_of_strings)

    ! Allocate storage for data_size 32-bit numbers. Initialize them
    ! to zero, for no better reason than that C initializes global
    ! variables to zero.
    allocate (vm%data(0_rik:(4_rik * (data_size - 1))), source = achar (0))

    ! Allocate storage for indices/bounds of the strings to be loaded
    ! into the string storage space.
    allocate (vm%string_boundaries(0_rik:number_of_strings))

    ! Fill the strings storage and the string boundaries array.
    call read_strings (inp, strbuf, number_of_strings, vm)

    ! Read the program instructions.
    call read_code (inp, strbuf, vm)

    ! Allocate a stack. Let us say that the stack size must be a
    ! multiple of 4, and is fixed at 65536 = 4**8 bytes. Pushing a
    ! 32-bit integer increases the stack pointer by 4, popping
    ! decreases it by 4.
    allocate (vm%stack(0_rik:(4_rik ** 8)))
  end subroutine read_vm

  subroutine read_datasize_and_number_of_strings (inp, strbuf, data_size, number_of_strings)
    integer, intent(in) :: inp
    type(strbuf_t), intent(inout) :: strbuf
    integer(kind = rik), intent(out) :: data_size
    integer(kind = rik), intent(out) :: number_of_strings

    logical :: eof
    logical :: no_newline
    integer(kind = nk) :: i, j
    character(:, kind = ck), allocatable :: data_size_str
    character(:, kind = ck), allocatable :: number_of_strings_str
    integer :: stat

    call get_line_from_stream (inp, eof, no_newline, strbuf)
    if (eof) call bad_vm_assembly

    i = skip_whitespace (strbuf, 1_nk)
    i = skip_datasize_keyword (strbuf, i)
    i = skip_whitespace (strbuf, i)
    i = skip_specific_character (strbuf, i, ck_':')
    i = skip_whitespace (strbuf, i)
    j = skip_non_whitespace (strbuf, i)
    if (j == i) call bad_vm_assembly
    allocate (data_size_str, source = strbuf%to_unicode (i, j - 1))

    i = skip_whitespace(strbuf, j)
    i = skip_strings_keyword (strbuf, i)
    i = skip_whitespace (strbuf, i)
    i = skip_specific_character (strbuf, i, ck_':')
    i = skip_whitespace (strbuf, i)
    j = skip_non_whitespace (strbuf, i)
    if (j == i) call bad_vm_assembly
    allocate (number_of_strings_str, source = strbuf%to_unicode (i, j - 1))

    read (data_size_str, *, iostat = stat) data_size
    if (stat /= 0) call bad_vm_assembly
    read (number_of_strings_str, *, iostat = stat) number_of_strings
    if (stat /= 0) call bad_vm_assembly
  end subroutine read_datasize_and_number_of_strings

  subroutine read_strings (inp, strbuf, number_of_strings, vm)
    integer, intent(in) :: inp
    type(strbuf_t), intent(inout) :: strbuf
    integer(kind = rik), intent(in) :: number_of_strings
    type(vm_t), intent(inout) :: vm

    type(strbuf_t) :: strings_temporary
    integer(kind = rik) :: i

    vm%string_boundaries(0) = 0_rik
    do i = 0_rik, number_of_strings - 1
       call read_one_string (inp, strbuf, strings_temporary)
       vm%string_boundaries(i + 1) = strings_temporary%length()
    end do
    allocate (vm%strings, source = strings_temporary%to_unicode())
  end subroutine read_strings

  subroutine read_one_string (inp, strbuf, strings_temporary)
    integer, intent(in) :: inp
    type(strbuf_t), intent(inout) :: strbuf
    type(strbuf_t), intent(inout) :: strings_temporary

    logical :: eof
    logical :: no_newline
    integer(kind = nk) :: i
    logical :: done

    call get_line_from_stream (inp, eof, no_newline, strbuf)
    if (eof) call bad_vm_assembly
    i = skip_whitespace (strbuf, 1_nk)
    i = skip_specific_character (strbuf, i, ck_'"')
    done = .false.
    do while (.not. done)
       if (i == strbuf%length() + 1) call bad_vm_assembly
       if (strbuf%chars(i) == ck_'"') then
          done = .true.
       else if (strbuf%chars(i) == backslash_char) then
          if (i == strbuf%length()) call bad_vm_assembly
          select case (strbuf%chars(i + 1))
          case (ck_'n')
             call strings_temporary%append(newline_char)
          case (backslash_char)
             call strings_temporary%append(backslash_char)
          case default
             call bad_vm_assembly
          end select
          i = i + 2
       else
          call strings_temporary%append(strbuf%chars(i))
          i = i + 1
       end if
    end do
  end subroutine read_one_string

  subroutine read_code (inp, strbuf, vm)
    integer, intent(in) :: inp
    type(strbuf_t), intent(inout) :: strbuf
    type(vm_t), intent(inout) :: vm

    logical :: eof
    logical :: no_newline

    call get_line_from_stream (inp, eof, no_newline, strbuf)
    do while (.not. eof)
       call parse_instruction (strbuf, vm%code)
       call get_line_from_stream (inp, eof, no_newline, strbuf)
    end do
  end subroutine read_code

  subroutine parse_instruction (strbuf, code)
    type(strbuf_t), intent(in) :: strbuf
    type(vm_code_t), intent(inout) :: code

    integer(kind = nk) :: i, j
    integer :: stat

    integer :: opcode
    integer(kind = rik) :: i_vm
    integer(kind = rik) :: arg

    character(8, kind = ck) :: opcode_name_str
    character(:, kind = ck), allocatable :: i_vm_str
    character(:, kind = ck), allocatable :: arg_str

    i = skip_whitespace (strbuf, 1_nk)
    j = skip_non_whitespace (strbuf, i)
    if (j == i) call bad_vm_assembly
    allocate (i_vm_str, source = strbuf%to_unicode(i, j - 1))
    read (i_vm_str, *, iostat = stat) i_vm
    if (stat /= 0) call bad_vm_assembly

    i = skip_whitespace (strbuf, j)
    j = skip_non_whitespace (strbuf, i)
    opcode_name_str = ck_'        '
    opcode_name_str(1:(j - i)) = strbuf%to_unicode(i, j - 1)
    opcode = findloc (opcode_names, opcode_name_str, 1) - 1
    if (opcode == -1) call bad_vm_assembly

    select case (opcode)

    case (opcode_push)
       call code%ensure_storage(i_vm + 5)
       code%bytes(i_vm) = achar (opcode)
       i = skip_whitespace (strbuf, j)
       j = skip_non_whitespace (strbuf, i)
       if (j == i) call bad_vm_assembly
       allocate (arg_str, source = strbuf%to_unicode(i, j - 1))
       read (arg_str, *, iostat = stat) arg
       if (stat /= 0) call bad_vm_assembly
       call int32_to_vm_bytes (arg, code%bytes, i_vm + 1)
       code%len = max (code%len, i_vm + 5)

    case (opcode_fetch, opcode_store)
       call code%ensure_storage(i_vm + 5)
       code%bytes(i_vm) = achar (opcode)
       i = skip_whitespace (strbuf, j)
       i = skip_specific_character (strbuf, i, ck_'[')
       i = skip_whitespace (strbuf, i)
       j = skip_non_whitespace (strbuf, i)
       if (j == i) call bad_vm_assembly
       if (strbuf%chars(j - 1) == ck_']') j = j - 1
       allocate (arg_str, source = strbuf%to_unicode(i, j - 1))
       read (arg_str, *, iostat = stat) arg
       if (stat /= 0) call bad_vm_assembly
       call uint32_to_vm_bytes (arg, code%bytes, i_vm + 1)
       code%len = max (code%len, i_vm + 5)

    case (opcode_jmp, opcode_jz)
       call code%ensure_storage(i_vm + 5)
       code%bytes(i_vm) = achar (opcode)
       call code%ensure_storage(i_vm + 5)
       code%bytes(i_vm) = achar (opcode)
       i = skip_whitespace (strbuf, j)
       i = skip_specific_character (strbuf, i, ck_'(')
       i = skip_whitespace (strbuf, i)
       j = skip_non_whitespace (strbuf, i)
       if (j == i) call bad_vm_assembly
       if (strbuf%chars(j - 1) == ck_')') j = j - 1
       allocate (arg_str, source = strbuf%to_unicode(i, j - 1))
       read (arg_str, *, iostat = stat) arg
       if (stat /= 0) call bad_vm_assembly
       call int32_to_vm_bytes (arg, code%bytes, i_vm + 1)
       code%len = max (code%len, i_vm + 5)

    case default
       call code%ensure_storage(i_vm + 1)
       code%bytes(i_vm) = achar (opcode)
       code%len = max (code%len, i_vm + 1)
    end select

  end subroutine parse_instruction

  function skip_datasize_keyword (strbuf, i) result (j)
    type(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    integer(kind = nk) :: j

    j = skip_specific_character (strbuf, i, ck_'D')
    j = skip_specific_character (strbuf, j, ck_'a')
    j = skip_specific_character (strbuf, j, ck_'t')
    j = skip_specific_character (strbuf, j, ck_'a')
    j = skip_specific_character (strbuf, j, ck_'s')
    j = skip_specific_character (strbuf, j, ck_'i')
    j = skip_specific_character (strbuf, j, ck_'z')
    j = skip_specific_character (strbuf, j, ck_'e')
  end function skip_datasize_keyword

  function skip_strings_keyword (strbuf, i) result (j)
    type(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    integer(kind = nk) :: j

    j = skip_specific_character (strbuf, i, ck_'S')
    j = skip_specific_character (strbuf, j, ck_'t')
    j = skip_specific_character (strbuf, j, ck_'r')
    j = skip_specific_character (strbuf, j, ck_'i')
    j = skip_specific_character (strbuf, j, ck_'n')
    j = skip_specific_character (strbuf, j, ck_'g')
    j = skip_specific_character (strbuf, j, ck_'s')
  end function skip_strings_keyword

  function skip_specific_character (strbuf, i, ch) result (j)
    type(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    character(1, kind = ck), intent(in) :: ch
    integer(kind = nk) :: j

    if (strbuf%length() < i) call bad_vm_assembly
    if (strbuf%chars(i) /= ch) call bad_vm_assembly
    j = i + 1
  end function skip_specific_character

  subroutine bad_vm_assembly
    write (error_unit, '("The input is not a correct virtual machine program.")')
    stop 1
  end subroutine bad_vm_assembly

end module vm_reader

module vm_runner
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, non_intrinsic :: compiler_type_kinds
  use, non_intrinsic :: helpers
  use, non_intrinsic :: vm_reader

  implicit none
  private

  public :: run_vm

contains

  subroutine run_vm (outp, vm)
    integer, intent(in) :: outp
    type(vm_t), intent(inout) :: vm

    logical :: done
    integer :: opcode

    vm%sp = 0
    vm%pc = 0
    done = .false.
    do while (.not. done)
       if (vm%pc < 0 .or. vm%code%length() <= vm%pc) call pc_error
       opcode = iachar (vm%code%bytes(vm%pc))
       vm%pc = vm%pc + 1
       select case (opcode)
       case (opcode_nop)
          continue
       case (opcode_halt)
          done = .true.
       case (opcode_add)
          call alu_add (vm)
       case (opcode_sub)
          call alu_sub (vm)
       case (opcode_mul)
          call alu_mul (vm)
       case (opcode_div)
          call alu_div (vm)
       case (opcode_mod)
          call alu_mod (vm)
       case (opcode_lt)
          call alu_lt (vm)
       case (opcode_gt)
          call alu_gt (vm)
       case (opcode_le)
          call alu_le (vm)
       case (opcode_ge)
          call alu_ge (vm)
       case (opcode_eq)
          call alu_eq (vm)
       case (opcode_ne)
          call alu_ne (vm)
       case (opcode_and)
          call alu_and (vm)
       case (opcode_or)
          call alu_or (vm)
       case (opcode_neg)
          call alu_neg (vm)
       case (opcode_not)
          call alu_not (vm)
       case (opcode_prtc)
          call prtc (outp, vm)
       case (opcode_prti)
          call prti (outp, vm)
       case (opcode_prts)
          call prts (outp, vm)
       case (opcode_fetch)
          call fetch_int32 (vm)
       case (opcode_store)
          call store_int32 (vm)
       case (opcode_push)
          call push_int32 (vm)
       case (opcode_jmp)
          call jmp (vm)
       case (opcode_jz)
          call jz (vm)
       case default
          write (error_unit, '("VM opcode unrecognized: ", I0)') opcode
          stop 1
       end select
    end do
  end subroutine run_vm

  subroutine push_int32 (vm)
    type(vm_t), intent(inout) :: vm

    !
    ! Push the 32-bit integer data at pc to the stack, then increment
    ! pc by 4.
    !

    if (ubound (vm%stack, 1) < vm%sp) then
       write (error_unit, '("VM stack overflow")')
       stop 1
    end if
    if (vm%code%length() <= vm%pc + 4) call pc_error
    vm%stack(vm%sp:(vm%sp + 3)) = vm%code%bytes(vm%pc:(vm%pc + 3))
    vm%sp = vm%sp + 4
    vm%pc = vm%pc + 4
  end subroutine push_int32

  subroutine fetch_int32 (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: i
    integer(kind = rik) :: x

    if (vm%code%length() <= vm%pc + 4) call pc_error
    call uint32_from_vm_bytes (i, vm%code%bytes, vm%pc)
    vm%pc = vm%pc + 4

    if (ubound (vm%data, 1) < i * 4) then
       write (error_unit, '("VM data access error")')
       stop 1
    end if
    call int32_from_vm_bytes (x, vm%data, i * 4)

    if (ubound (vm%stack, 1) < vm%sp) then
       write (error_unit, '("VM stack overflow")')
       stop 1
    end if
    call int32_to_vm_bytes (x, vm%stack, vm%sp)
    vm%sp = vm%sp + 4
  end subroutine fetch_int32

  subroutine store_int32 (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: i
    integer(kind = rik) :: x

    if (vm%code%length() <= vm%pc + 4) call pc_error
    call uint32_from_vm_bytes (i, vm%code%bytes, vm%pc)
    vm%pc = vm%pc + 4

    call ensure_there_is_enough_stack_data (vm, 4_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 4)
    vm%sp = vm%sp - 4

    if (ubound (vm%data, 1) < i * 4) then
       write (error_unit, '("VM data access error")')
       stop 1
    end if
    call int32_to_vm_bytes (x, vm%data, i * 4)
  end subroutine store_int32

  subroutine jmp (vm)
    type(vm_t), intent(inout) :: vm

    !
    ! Add the 32-bit data at pc to pc itself.
    !

    integer(kind = rik) :: x

    if (vm%code%length() <= vm%pc + 4) call pc_error
    call int32_from_vm_bytes (x, vm%code%bytes, vm%pc)
    vm%pc = vm%pc + x
  end subroutine jmp

  subroutine jz (vm)
    type(vm_t), intent(inout) :: vm

    !
    ! Conditionally add the 32-bit data at pc to pc itself.
    !

    integer(kind = rik) :: x

    call ensure_there_is_enough_stack_data (vm, 4_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 4)
    vm%sp = vm%sp - 4
    if (x == 0) then
       if (vm%code%length() <= vm%pc + 4) call pc_error
       call int32_from_vm_bytes (x, vm%code%bytes, vm%pc)
       vm%pc = vm%pc + x
    else
       vm%pc = vm%pc + 4
    end if
  end subroutine jz

  subroutine alu_neg (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x

    call ensure_there_is_enough_stack_data (vm, 4_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 4)
    x = -x
    call int32_to_vm_bytes (x, vm%stack, vm%sp - 4)
  end subroutine alu_neg

  subroutine alu_not (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x

    call ensure_there_is_enough_stack_data (vm, 4_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 4)
    x = bool2int (x == 0_rik)
    call int32_to_vm_bytes (x, vm%stack, vm%sp - 4)
  end subroutine alu_not

  subroutine alu_add (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = x + y
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_add

  subroutine alu_sub (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = x - y
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_sub

  subroutine alu_mul (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = x * y
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_mul

  subroutine alu_div (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = x / y                   ! This works like ‘/’ in C.
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_div

  subroutine alu_mod (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = mod (x, y)              ! This works like ‘%’ in C.
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_mod

  subroutine alu_lt (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = bool2int (x < y)
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_lt

  subroutine alu_gt (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = bool2int (x > y)
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_gt

  subroutine alu_le (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = bool2int (x <= y)
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_le

  subroutine alu_ge (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = bool2int (x >= y)
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_ge

  subroutine alu_eq (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = bool2int (x == y)
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_eq

  subroutine alu_ne (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = bool2int (x /= y)
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_ne

  subroutine alu_and (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = bool2int (x /= 0 .and. y /= 0)
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_and

  subroutine alu_or (vm)
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x, y, z

    call ensure_there_is_enough_stack_data (vm, 8_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
    call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
    z = bool2int (x /= 0 .or. y /= 0)
    call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
    vm%sp = vm%sp - 4
  end subroutine alu_or

  subroutine ensure_there_is_enough_stack_data (vm, n)
    type(vm_t), intent(in) :: vm
    integer(kind = rik), intent(in) :: n

    if (vm%sp < n) then
       write (error_unit, '("VM stack underflow")')
       stop 1
    end if
  end subroutine ensure_there_is_enough_stack_data

  subroutine prtc (outp, vm)
    integer, intent(in) :: outp
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x

    call ensure_there_is_enough_stack_data (vm, 4_rik)
    call uint32_from_vm_bytes (x, vm%stack, vm%sp - 4)
    write (outp, '(A1)', advance = 'no') char (x, kind = ck)
    vm%sp = vm%sp - 4
  end subroutine prtc

  subroutine prti (outp, vm)
    integer, intent(in) :: outp
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x

    call ensure_there_is_enough_stack_data (vm, 4_rik)
    call int32_from_vm_bytes (x, vm%stack, vm%sp - 4)
    write (outp, '(I0)', advance = 'no') x
    vm%sp = vm%sp - 4
  end subroutine prti

  subroutine prts (outp, vm)
    integer, intent(in) :: outp
    type(vm_t), intent(inout) :: vm

    integer(kind = rik) :: x
    integer(kind = rik) :: i, j

    call ensure_there_is_enough_stack_data (vm, 4_rik)
    call uint32_from_vm_bytes (x, vm%stack, vm%sp - 4)
    if (ubound (vm%string_boundaries, 1) - 1 < x) then
       write (error_unit, '("VM string boundary error")')
       stop 1
    end if
    i = vm%string_boundaries(x)
    j = vm%string_boundaries(x + 1)
    write (outp, '(A)', advance = 'no') vm%strings((i + 1):j)
    vm%sp = vm%sp - 4
  end subroutine prts

  subroutine pc_error
    write (error_unit, '("VM program counter error")')
    stop 1
  end subroutine pc_error

end module vm_runner

program vm
  use, intrinsic :: iso_fortran_env, only: input_unit
  use, intrinsic :: iso_fortran_env, only: output_unit
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, non_intrinsic :: compiler_type_kinds
  use, non_intrinsic :: string_buffers
  use, non_intrinsic :: vm_reader
  use, non_intrinsic :: vm_runner

  implicit none

  integer, parameter :: inp_unit_no = 100
  integer, parameter :: outp_unit_no = 101

  integer :: arg_count
  character(200) :: arg
  integer :: inp
  integer :: outp

  arg_count = command_argument_count ()
  if (3 <= arg_count) then
     call print_usage
  else
     if (arg_count == 0) then
        inp = input_unit
        outp = output_unit
     else if (arg_count == 1) then
        call get_command_argument (1, arg)
        inp = open_for_input (trim (arg))
        outp = output_unit
     else if (arg_count == 2) then
        call get_command_argument (1, arg)
        inp = open_for_input (trim (arg))
        call get_command_argument (2, arg)
        outp = open_for_output (trim (arg))
     end if

     block
       type(strbuf_t) :: strbuf
       type(vm_t) :: vm

       call read_vm (inp, strbuf, vm)
       call run_vm (outp, vm)
     end block
  end if

contains

  function open_for_input (filename) result (unit_no)
    character(*), intent(in) :: filename
    integer :: unit_no

    integer :: stat

    open (unit = inp_unit_no, file = filename, status = 'old', &
         & action = 'read', access = 'stream', form = 'unformatted',  &
         & iostat = stat)
    if (stat /= 0) then
       write (error_unit, '("Error: failed to open ", 1A, " for input")') filename
       stop 1
    end if
    unit_no = inp_unit_no
  end function open_for_input

  function open_for_output (filename) result (unit_no)
    character(*), intent(in) :: filename
    integer :: unit_no

    integer :: stat

    open (unit = outp_unit_no, file = filename, action = 'write', iostat = stat)
    if (stat /= 0) then
       write (error_unit, '("Error: failed to open ", 1A, " for output")') filename
       stop 1
    end if
    unit_no = outp_unit_no
  end function open_for_output

  subroutine print_usage
    character(200) :: progname

    call get_command_argument (0, progname)
    write (output_unit, '("Usage: ", 1A, " [INPUT_FILE [OUTPUT_FILE]]")') &
         &      trim (progname)
  end subroutine print_usage
  
end program vm
Output:

$ gfortran -O3 -Wall -Wextra -fcheck=all -std=f2018 -U__GFORTRAN__ -g -o vm vm.F90 && ./lex count.t | ./parse | ./gen | ./vm

count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

Go

Translation of: Python
package main

import (
    "bufio"
    "encoding/binary"
    "fmt"
    "log"
    "math"
    "os"
    "strconv"
    "strings"
)

type code = byte

const (
    fetch code = iota
    store
    push
    add
    sub
    mul
    div
    mod
    lt
    gt
    le
    ge
    eq
    ne
    and
    or
    neg
    not
    jmp
    jz
    prtc
    prts
    prti
    halt
)

var codeMap = map[string]code{
    "fetch": fetch,
    "store": store,
    "push":  push,
    "add":   add,
    "sub":   sub,
    "mul":   mul,
    "div":   div,
    "mod":   mod,
    "lt":    lt,
    "gt":    gt,
    "le":    le,
    "ge":    ge,
    "eq":    eq,
    "ne":    ne,
    "and":   and,
    "or":    or,
    "neg":   neg,
    "not":   not,
    "jmp":   jmp,
    "jz":    jz,
    "prtc":  prtc,
    "prts":  prts,
    "prti":  prti,
    "halt":  halt,
}

var (
    err        error
    scanner    *bufio.Scanner
    object     []code
    stringPool []string
)

func reportError(msg string) {
    log.Fatalf("error : %s\n", msg)
}

func check(err error) {
    if err != nil {
        log.Fatal(err)
    }
}

func btoi(b bool) int32 {
    if b {
        return 1
    }
    return 0
}

func itob(i int32) bool {
    if i != 0 {
        return true
    }
    return false
}

func emitByte(c code) {
    object = append(object, c)
}

func emitWord(n int) {
    bs := make([]byte, 4)
    binary.LittleEndian.PutUint32(bs, uint32(n))
    for _, b := range bs {
        emitByte(code(b))
    }
}

/*** Virtual Machine interpreter ***/
func runVM(dataSize int) {
    stack := make([]int32, dataSize+1)
    pc := int32(0)
    for {
        op := object[pc]
        pc++
        switch op {
        case fetch:
            x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
            stack = append(stack, stack[x])
            pc += 4
        case store:
            x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
            ln := len(stack)
            stack[x] = stack[ln-1]
            stack = stack[:ln-1]
            pc += 4
        case push:
            x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
            stack = append(stack, x)
            pc += 4
        case add:
            ln := len(stack)
            stack[ln-2] += stack[ln-1]
            stack = stack[:ln-1]
        case sub:
            ln := len(stack)
            stack[ln-2] -= stack[ln-1]
            stack = stack[:ln-1]
        case mul:
            ln := len(stack)
            stack[ln-2] *= stack[ln-1]
            stack = stack[:ln-1]
        case div:
            ln := len(stack)
            stack[ln-2] = int32(float64(stack[ln-2]) / float64(stack[ln-1]))
            stack = stack[:ln-1]
        case mod:
            ln := len(stack)
            stack[ln-2] = int32(math.Mod(float64(stack[ln-2]), float64(stack[ln-1])))
            stack = stack[:ln-1]
        case lt:
            ln := len(stack)
            stack[ln-2] = btoi(stack[ln-2] < stack[ln-1])
            stack = stack[:ln-1]
        case gt:
            ln := len(stack)
            stack[ln-2] = btoi(stack[ln-2] > stack[ln-1])
            stack = stack[:ln-1]
        case le:
            ln := len(stack)
            stack[ln-2] = btoi(stack[ln-2] <= stack[ln-1])
            stack = stack[:ln-1]
        case ge:
            ln := len(stack)
            stack[ln-2] = btoi(stack[ln-2] >= stack[ln-1])
            stack = stack[:ln-1]
        case eq:
            ln := len(stack)
            stack[ln-2] = btoi(stack[ln-2] == stack[ln-1])
            stack = stack[:ln-1]
        case ne:
            ln := len(stack)
            stack[ln-2] = btoi(stack[ln-2] != stack[ln-1])
            stack = stack[:ln-1]
        case and:
            ln := len(stack)
            stack[ln-2] = btoi(itob(stack[ln-2]) && itob(stack[ln-1]))
            stack = stack[:ln-1]
        case or:
            ln := len(stack)
            stack[ln-2] = btoi(itob(stack[ln-2]) || itob(stack[ln-1]))
            stack = stack[:ln-1]
        case neg:
            ln := len(stack)
            stack[ln-1] = -stack[ln-1]
        case not:
            ln := len(stack)
            stack[ln-1] = btoi(!itob(stack[ln-1]))
        case jmp:
            x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
            pc += x
        case jz:
            ln := len(stack)
            v := stack[ln-1]
            stack = stack[:ln-1]
            if v != 0 {
                pc += 4
            } else {
                x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
                pc += x
            }
        case prtc:
            ln := len(stack)
            fmt.Printf("%c", stack[ln-1])
            stack = stack[:ln-1]
        case prts:
            ln := len(stack)
            fmt.Printf("%s", stringPool[stack[ln-1]])
            stack = stack[:ln-1]
        case prti:
            ln := len(stack)
            fmt.Printf("%d", stack[ln-1])
            stack = stack[:ln-1]
        case halt:
            return
        default:
            reportError(fmt.Sprintf("Unknown opcode %d\n", op))
        }
    }
}

func translate(s string) string {
    var d strings.Builder
    for i := 0; i < len(s); i++ {
        if s[i] == '\\' && (i+1) < len(s) {
            if s[i+1] == 'n' {
                d.WriteByte('\n')
                i++
            } else if s[i+1] == '\\' {
                d.WriteByte('\\')
                i++
            }
        } else {
            d.WriteByte(s[i])
        }
    }
    return d.String()
}

func loadCode() int {
    var dataSize int
    firstLine := true
    for scanner.Scan() {
        line := strings.TrimRight(scanner.Text(), " \t")
        if len(line) == 0 {
            if firstLine {
                reportError("empty line")
            } else {
                break
            }
        }
        lineList := strings.Fields(line)
        if firstLine {
            dataSize, err = strconv.Atoi(lineList[1])
            check(err)
            nStrings, err := strconv.Atoi(lineList[3])
            check(err)
            for i := 0; i < nStrings; i++ {
                scanner.Scan()
                s := strings.Trim(scanner.Text(), "\"\n")
                stringPool = append(stringPool, translate(s))
            }
            firstLine = false
            continue
        }
        offset, err := strconv.Atoi(lineList[0])
        check(err)
        instr := lineList[1]
        opCode, ok := codeMap[instr]
        if !ok {
            reportError(fmt.Sprintf("Unknown instruction %s at %d", instr, opCode))
        }
        emitByte(opCode)
        switch opCode {
        case jmp, jz:
            p, err := strconv.Atoi(lineList[3])
            check(err)
            emitWord(p - offset - 1)
        case push:
            value, err := strconv.Atoi(lineList[2])
            check(err)
            emitWord(value)
        case fetch, store:
            value, err := strconv.Atoi(strings.Trim(lineList[2], "[]"))
            check(err)
            emitWord(value)
        }
    }
    check(scanner.Err())
    return dataSize
}

func main() {
    codeGen, err := os.Open("codegen.txt")
    check(err)
    defer codeGen.Close()
    scanner = bufio.NewScanner(codeGen)
    runVM(loadCode())
}
Output:

Using the 'while count' example:

count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

Icon

Translation of: ObjectIcon
# -*- Icon -*-
#
# The Rosetta Code virtual machine in Icon. Migrated from the
# ObjectIcon.
#
# See https://rosettacode.org/wiki/Compiler/virtual_machine_interpreter
#

record VirtualMachine(code, global_data, strings, stack, pc)

global opcode_names
global opcode_values
global op_halt
global op_add
global op_sub
global op_mul
global op_div
global op_mod
global op_lt
global op_gt
global op_le
global op_ge
global op_eq
global op_ne
global op_and
global op_or
global op_neg
global op_not
global op_prtc
global op_prti
global op_prts
global op_fetch
global op_store
global op_push
global op_jmp
global op_jz

global whitespace_chars

procedure main(args)
  local f_inp, f_out
  local vm

  whitespace_chars := ' \t\n\r\f\v'
  initialize_opcodes()

  if 3 <= *args then {
    write("Usage: ", &progname, " [INPUT_FILE [OUTPUT_FILE]]")
    exit(1)
  }

  if 1 <= *args then {
    f_inp := open(args[1], "r") | {
      write(&errout, "Failed to open ", args[1], " for reading.")
      exit(1)
    }
  } else {
    f_inp := &input
  }

  if 2 <= *args then {
    f_out := open(args[2], "w") | {
      write(&errout, "Failed to open ", args[2], " for writing.")
      exit(1)
    }
  } else {
    f_out := &output
  }

  vm := VirtualMachine()
  read_assembly_code(f_inp, vm)
  run_vm(f_out, vm)
end

procedure initialize_opcodes()
  local i

  opcode_names :=
      ["halt", "add", "sub", "mul", "div",
       "mod", "lt", "gt", "le", "ge",
       "eq", "ne", "and", "or", "neg",
       "not", "prtc", "prti", "prts", "fetch",
       "store", "push", "jmp", "jz"]

  opcode_values := table()
  every i := 1 to *opcode_names do
      opcode_values[opcode_names[i]] := char(i)

  op_halt := opcode_values["halt"]
  op_add := opcode_values["add"]
  op_sub := opcode_values["sub"]
  op_mul := opcode_values["mul"]
  op_div := opcode_values["div"]
  op_mod := opcode_values["mod"]
  op_lt := opcode_values["lt"]
  op_gt := opcode_values["gt"]
  op_le := opcode_values["le"]
  op_ge := opcode_values["ge"]
  op_eq := opcode_values["eq"]
  op_ne := opcode_values["ne"]
  op_and := opcode_values["and"]
  op_or := opcode_values["or"]
  op_neg := opcode_values["neg"]
  op_not := opcode_values["not"]
  op_prtc := opcode_values["prtc"]
  op_prti := opcode_values["prti"]
  op_prts := opcode_values["prts"]
  op_fetch := opcode_values["fetch"]
  op_store := opcode_values["store"]
  op_push := opcode_values["push"]
  op_jmp := opcode_values["jmp"]
  op_jz := opcode_values["jz"]
end

procedure int2bytes (n)
  local bytes

  # The VM is little-endian.

  bytes := "****"
  bytes[1] := char (iand(n, 16rFF))
  bytes[2] := char(iand(ishift(n, -8), 16rFF))
  bytes[3] := char(iand(ishift(n, -16), 16rFF))
  bytes[4] := char(iand(ishift(n, -24), 16rFF))
  return bytes
end

procedure bytes2int(bytes, i)
  local n0, n1, n2, n3, n

  # The VM is little-endian.

  n0 := ord(bytes[i])
  n1 := ishift(ord(bytes[i + 1]), 8)
  n2 := ishift(ord(bytes[i + 2]), 16)
  n3 := ishift(ord(bytes[i + 3]), 24)
  n := ior (n0, ior (n1, ior (n2, n3)))

  # Do not forget to extend the sign bit.
  return (if n3 <= 16r7F then n else ior(n, icom(16rFFFFFFFF)))
end

procedure read_assembly_code(f, vm)
  local data_size, number_of_strings
  local line, ch
  local i
  local address
  local opcode

  # Read the header line.
  line := read(f) | bad_vm()
  line ? {
    tab(many(whitespace_chars))
    tab(match("Datasize")) | bad_vm()
    tab(many(whitespace_chars))
    tab(any(':')) | bad_vm()
    tab(many(whitespace_chars))
    data_size :=
        integer(tab(many(&digits))) | bad_vm()
    tab(many(whitespace_chars))
    tab(match("Strings")) | bad_vm()
    tab(many(whitespace_chars))
    tab(any(':')) | bad_vm()
    tab(many(whitespace_chars))
    number_of_strings :=
        integer(tab(many(&digits))) | bad_vm()
  }

  # Read the strings.
  vm.strings := list(number_of_strings)
  every i := 1 to number_of_strings do {
    vm.strings[i] := ""
    line := read(f) | bad_vm()
    line ? {
      tab(many(whitespace_chars))
      tab(any('"')) | bad_vm()
      while ch := tab(any(~'"')) do {
        if ch == '\\' then {
          ch := tab(any('n\\')) | bad_vm()
          vm.strings[i] ||:=
              (if (ch == "n") then "\n" else "\\")
        } else {
          vm.strings[i] ||:= ch
        }
      }
    }
  }

  # Read the code.
  vm.code := ""
  while line := read(f) do {
    line ? {
      tab(many(whitespace_chars))
      address := integer(tab(many(&digits))) | bad_vm()
      tab(many(whitespace_chars))
      opcode := tab(many(~whitespace_chars)) | bad_vm()
      vm.code ||:= opcode_values[opcode]
      case opcode of {
        "push": {
          tab(many(whitespace_chars))
          vm.code ||:=
              int2bytes(integer(tab(many(&digits)))) |
              int2bytes(integer(tab(any('-')) ||
                                tab(many(&digits)))) |
              bad_vm()
        }
        "fetch" | "store": {
          tab(many(whitespace_chars))
          tab(any('[')) | bad_vm()
          tab(many(whitespace_chars))
          vm.code ||:=
              int2bytes(integer(tab(many(&digits)))) |
              bad_vm()
          tab(many(whitespace_chars))
          tab(any(']')) | bad_vm()
        }
        "jmp" | "jz": {
          tab(many(whitespace_chars))
          tab(any('(')) | bad_vm()
          tab(many(whitespace_chars))
          vm.code ||:=
              int2bytes(integer(tab(many(&digits)))) |
              int2bytes(integer(tab(any('-')) ||
                                tab(many(&digits)))) |
              bad_vm()
          tab(many(whitespace_chars))
          tab(any(')')) | bad_vm()
          tab(many(whitespace_chars))
          tab(many(&digits)) | bad_vm()
        }
        default: {
          # Do nothing
        }
      }
    }
  }

  # Create a global data area.
  vm.global_data := list(data_size, &null)

  initialize_vm(vm)
end

procedure run_vm(f_out, vm)
  initialize_vm(vm)
  continue_vm(f_out, vm)
end

procedure continue_vm(f_out, vm)
  while vm.code[vm.pc] ~== op_halt do
      step_vm(f_out, vm)
end

procedure step_vm(f_out, vm)
  local opcode

  opcode := vm.code[vm.pc]
  vm.pc +:= 1
  case opcode of {
    op_add:   binop(vm, "+")
    op_sub:   binop(vm, "-")
    op_mul:   binop(vm, "*")
    op_div:   binop(vm, "/")
    op_mod:   binop(vm, "%")
    op_lt:    comparison(vm, "<")
    op_gt:    comparison(vm, ">")
    op_le:    comparison(vm, "<=")
    op_ge:    comparison(vm, ">=")
    op_eq:    comparison(vm, "=")
    op_ne:    comparison(vm, "~=")
    op_and:   logical_and(vm)
    op_or:    logical_or(vm)
    op_neg:   negate(vm)
    op_not:   logical_not(vm)
    op_prtc:  printc(f_out, vm)
    op_prti:  printi(f_out, vm)
    op_prts:  prints(f_out, vm)
    op_fetch: fetch_global(vm)
    op_store: store_global(vm)
    op_push:  push_argument(vm)
    op_jmp:   jump(vm)
    op_jz:    jump_if_zero(vm)
    default:  bad_opcode()
  }
end

procedure negate(vm)
  vm.stack[1] := -vm.stack[1]
end

procedure binop(vm, func)
  vm.stack[2] := func(vm.stack[2], vm.stack[1])
  pop(vm.stack)
end

procedure comparison(vm, func)
  vm.stack[2] := (if func(vm.stack[2], vm.stack[1]) then 1 else 0)
  pop(vm.stack)
end

procedure logical_and(vm)
  vm.stack[2] :=
      (if vm.stack[2] ~= 0 & vm.stack[1] ~= 0 then 1 else 0)
  pop(vm.stack)
end

procedure logical_or(vm)
  vm.stack[2] :=
      (if vm.stack[2] ~= 0 | vm.stack[1] ~= 0 then 1 else 0)
  pop(vm.stack)
end

procedure logical_not(vm)
  vm.stack[1] := (if vm.stack[1] ~= 0 then 0 else 1)
end

procedure printc(f_out, vm)
  writes(f_out, char(pop(vm.stack)))
end

procedure printi(f_out, vm)
  writes(f_out, pop(vm.stack))
end

procedure prints(f_out, vm)
  writes(f_out, vm.strings[pop(vm.stack) + 1])
end

procedure fetch_global(vm)
  push(vm.stack, vm.global_data[get_argument(vm) + 1])
  vm.pc +:= 4
end

procedure store_global(vm)
  vm.global_data[get_argument(vm) + 1] := pop(vm.stack)
  vm.pc +:= 4
end

procedure push_argument(vm)
  push(vm.stack, get_argument(vm))
  vm.pc +:= 4
end

procedure jump(vm)
  vm.pc +:= get_argument(vm)
end

procedure jump_if_zero(vm)
  if pop(vm.stack) = 0 then
      vm.pc +:= get_argument(vm)
  else
      vm.pc +:= 4
end

procedure get_argument(vm)
  return bytes2int(vm.code, vm.pc)
end

procedure initialize_vm(vm)
  # The program counter starts at 1, for convenient indexing into
  # the code[] array. Icon indexing starts at 1 (for a *very* good
  # reason, but that’s a topic for another day).
  vm.pc := 1
  vm.stack := []
end

procedure bad_vm()
  write(&errout, "Bad VM.")
  exit(1)
end

procedure bad_opcode()
  write(&errout, "Bad opcode.")
  exit(1)
end
Output:

$ icont -u vm-icn.icn && ./vm-icn compiler-tests/count.vm

count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

J

Implementation:

(opcodes)=: opcodes=: ;:{{)n
 fetch store push add sub mul div mod lt gt le ge
 eq ne and or neg not jmp jz prtc prts prti halt
}}-.LF

unpack=: {{
  lines=. <;._2 y
  'ds0 ds s0 s'=.;:0{::lines
  assert.'Datasize:Strings:'-:ds0,s0
  vars=: (".ds)#0
  strings=: rplc&('\\';'\';'\n';LF)L:0 '"'-.L:0~(1+i.".s){lines
  object=: ;xlate L:1 (;:'()[]') -.~L:1 ;:L:0 '-_' rplc~L:0 (1+".s)}.lines
  outbuf=: stack=: i.0
}}

xlate=: {{
  if.2<#y do.
    (opcodes i. 1{y),(4#256)#:".2{::y
  else.
    opcodes i. 1{y
  end.
}}

NB. ensure we maintain 32 bit signed int representation
signadj=: _2147483648+4294967296|2147483648+] 
getint=: signadj@(256 #. ])

PUSH=: {{ stack=:stack,signadj y }}
POP=:  {{ (stack=: _1 }. stack) ] _1 {  stack }}
POP2=: {{ (stack=: _2 }. stack) ] _2 {. stack }}
emit=:{{
  outbuf=: outbuf,y
  if.LF e. outbuf do.
    ndx=. outbuf i:LF
    echo ndx{.outbuf
    outbuf=: }.ndx}.outbuf
  end.
}}

run_vm=: {{
  unpack y
  stack=: i.pc=:0
  lim=. <:#object
  while.do.
    pc=: pc+1 [ op=: (pc { object){opcodes
    i=. getint (lim<.pc+i.4) { object
    k=. 0
    select.op
      case.fetch do. k=.4 [PUSH i{vars
      case.store do. k=.4 [vars=: (POP'') i} vars
      case.push do.  k=.4 [PUSH i
      case.add do. PUSH +/POP2''
      case.sub do. PUSH -/POP2''
      case.mul do. PUSH */POP2''
      case.div do. PUSH<.%/POP2''
      case.mod do. PUSH |~/POP2''
      case.lt  do. PUSH </POP2''
      case.le  do. PUSH <:/POP2''
      case.eq  do. PUSH =/POP2''
      case.ne  do. PUSH ~:/POP2''
      case.ge  do. PUSH >:/POP2''
      case.gt  do. PUSH >/POP2''
      case.and do. PUSH */0~:POP2''
      case.or  do. PUSH +./0~:POP2''
      case.neg do. PUSH -POP''
      case.not do. PUSH 0=POP''
      case.jmp do. k=. i
      case.jz  do. k=. (0=POP''){4,i
      case.prtc do. emit u:POP''
      case.prts do. emit (POP''){::strings
      case.prti do. emit rplc&'_-'":POP''
      case.halt do. if.#outbuf do.echo outbuf end.EMPTY return.
    end.
    pc=: pc+k
  end.      
}}

Task example:

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

   run_vm gen syntax lex count
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

Julia

mutable struct VM32
    code::Vector{UInt8}
    stack::Vector{Int32}
    data::Vector{Int32}
    strings::Vector{String}
    offsets::Vector{Int32}
    lastargs::Vector{Int32}
    ip::Int32
    VM32() = new(Vector{UInt8}(), Vector{Int32}(), Vector{Int32}(),
                 Vector{String}(), Vector{Int32}(), Vector{Int32}(), 1)
end

halt, add, sub, mul, Div, mod, not, neg, and, or, lt, gt, le, ge, ne, eq, prts,
    prti, prtc, store, Fetch, push, jmp, jz = UInt8.(collect(1:24))

function assemble(io)
    vm = VM32()
    header = readline(io)
    datasize, nstrings = match(r"\w+:\s*(\d+)\s+\w+:\s*(\d+)", header).captures
    vm.data = zeros(Int32, parse(Int, datasize) + 4)
    for i in 1:parse(Int, nstrings)
        line = replace(strip(readline(io), ['"', '\n']), r"\\." => x -> x[end] == 'n' ? "\n" : string(x[end]))
        push!(vm.strings, line)
    end
    while !eof(io)
        line = readline(io)
        offset, op, arg1, arg2 = match(r"(\d+)\s+(\w+)\s*(\S+)?\s*(\S+)?", line).captures
        op = op in ["fetch", "div"] ? uppercasefirst(op) : op
        push!(vm.code, eval(Symbol(op)))
        if arg1 != nothing
            v = parse(Int32, strip(arg1, ['[', ']', '(', ')']))
            foreach(x -> push!(vm.code, x), reinterpret(UInt8, [v]))
        end
        if arg2 != nothing
            push!(vm.lastargs, (x = tryparse(Int32, arg2)) == nothing ? 0 : x)
        end
        push!(vm.offsets, parse(Int32, offset))
    end
    vm
end

function runvm(vm)
    value() = (x = vm.ip; vm.ip += 4; reinterpret(Int32, vm.code[x:x+3])[1])
    tobool(x) = (x != 0)
    ops = Dict(
        halt  => () -> exit(),
        add   => () -> begin vm.stack[end-1] += vm.stack[end]; pop!(vm.stack); vm.stack[end] end,
        sub   => () -> begin vm.stack[end-1] -= vm.stack[end]; pop!(vm.stack); vm.stack[end] end,
        mul   => () -> begin vm.stack[end-1] *= vm.stack[end]; pop!(vm.stack); vm.stack[end] end,
        Div   => () -> begin vm.stack[end-1] /= vm.stack[end]; pop!(vm.stack); vm.stack[end] end,
        mod   => () -> begin vm.stack[end-1] %= vm.stack[1]; pop!(vm.stack); vm.stack[end] end,
        not   => () -> vm.stack[end] = vm.stack[end] ? 0 : 1,
        neg   => () -> vm.stack[end] = -vm.stack[end],
        and   => () -> begin vm.stack[end-1] = tobool(vm.stack[end-1]) && tobool(vm.stack[end]) ? 1 : 0; pop!(vm.stack); vm.stack[end] end,
        or    => () -> begin vm.stack[end-1] = tobool(vm.stack[end-1]) || tobool(vm.stack[end]) ? 1 : 0; pop!(vm.stack); vm.stack[end] end,
        lt    => () -> begin x = (vm.stack[end-1] < vm.stack[end] ? 1 : 0); pop!(vm.stack); vm.stack[end] = x end,
        gt    => () -> begin x = (vm.stack[end-1] > vm.stack[end] ? 1 : 0); pop!(vm.stack); vm.stack[end] = x end,
        le    => () -> begin x = (vm.stack[end-1] <= vm.stack[end] ? 1 : 0); pop!(vm.stack); vm.stack[end] = x end,
        ge    => () -> begin x = (vm.stack[end-1] >= vm.stack[end] ? 1 : 0); pop!(vm.stack); vm.stack[end] = x end,
        ne    => () -> begin x = (vm.stack[end-1] != vm.stack[end] ? 1 : 0); pop!(vm.stack); vm.stack[end] = x end,
        eq    => () -> begin x = (vm.stack[end-1] == vm.stack[end] ? 1 : 0); pop!(vm.stack); vm.stack[end] = x end,
        prts  => () -> print(vm.strings[pop!(vm.stack) + 1]),
        prti  => () -> print(pop!(vm.stack)),
        prtc  => () -> print(Char(pop!(vm.stack))),
        store => () -> vm.data[value() + 1] = pop!(vm.stack),
        Fetch => () -> push!(vm.stack, vm.data[value() + 1]),
        push  => () -> push!(vm.stack, value()),
        jmp   => () -> vm.ip += value(),
        jz    => () -> if pop!(vm.stack) == 0 vm.ip += value() else vm.ip += 4 end)
    vm.ip = 1
    while true
        op = vm.code[vm.ip]
        vm.ip += 1
        ops[op]()
    end
end

const testasm = """
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   """

const iob = IOBuffer(testasm)
const vm = assemble(iob)
runvm(vm)
Output:

count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

M2000 Interpreter

Using Select Case

Module Virtual_Machine_Interpreter (a$){
	\\ function to extract string, replacing escape codes.
	Function GetString$(a$) {
		s=instr(a$, chr$(34))
		m=rinstr(a$,chr$(34))-s
		if m>1 then
			\\ process escape codes
			=format$(mid$(a$, s+1, m-1))
		else
			=""
		end if
	}
	\\ module to print a string to console using codes, 13, 10, 9
	Module printsrv (a$) {
		for i=1 to len(a$)
			select case chrcode(Mid$(a$,i,1))
			case 13
				cursor 0
			case 10
				cursor 0 : Print
			case 9
				cursor ((pos+tab) div tab)*tab
			else case
			{
				m=pos :if pos>=width then Print : m=pos
				Print Mid$(a$,i,1);
				if m<=width then cursor m+1
			}
			end select
		next i
	}
	const nl$=chr$(13)+chr$(10)
	\\ we can set starting value to any number  n where 0<=n<=232
	enum op {	halt_=232, add_, sub_, mul_, div_, mod_, not_, neg_, and_, or_, lt_,
		    	gt_, le_, ge_, ne_, eq_, prts_, prti_, prtc_, store_, fetch_, push_,
			jmp_, jz_
    	}
	Rem : Form 120, 60 ' change console width X height to run Ascii Mandlebrot examlpe
	Report "Virtual Assembly Code:"+{
	}+a$
	Print "Prepare Byte Code"
	
	\\ get datasize
	a$=rightpart$(a$, "Datasize:")
	m=0
	data_size=val(a$, "int", m)
	a$=mid$(a$, m)
	\\ make stack
	if data_size>0 then Buffer Clear stack_ as long*data_size
	\\ dim or redim buffer append 1000 long as is.
	Buffer stack_ as long*(1000+data_size)
	\\ get strings
	a$=rightpart$(a$, "Strings:")
	m=0
	strings=val(a$, "int", m)
	a$=rightpart$(a$, nl$)
	
	if strings>0 then
		Dim strings$(strings)
		for i=0 to strings-1
			strings$(i)=GetString$(leftpart$(a$, nl$))
			a$=rightpart$(a$, nl$)
		Next i
	End if
	buffer clear code_ as byte*1000
	do
		m=0
		offset=val(a$,"int", m)
		if m<0 then exit
		a$=mid$(a$,m)
		line$=trim$(leftpart$(a$,nl$))
		if line$="" then line$=trim$(a$) else a$=trim$(rightpart$(a$, nl$))
		op$=if$(instr(line$," ")>0->leftpart$(line$," "), line$)
		if not valid(eval(op$+"_")) then exit
		opc=eval(op$+"_")
		Return code_, offset:=opc
		if opc>=store_ then
			line$=rightpart$(line$," ")
			select case opc
			case store_, fetch_
				Return code_, offset+1:=val(rightpart$(leftpart$(line$,"]"),"[")) as long : offset+=4
			case push_
				Return code_, offset+1:=uint(val(line$)) as long : offset+=4
			case jz_, jmp_
				Return code_, offset+1:=val(rightpart$(line$,")")) as long : offset+=4
			end select 
		end if
	Always
	Print "Press any key" : Push key$ : Drop
	\\ Prepare VM
	let pc=0, sp=len(stack_) div 4
	do {
		func=eval(code_, pc)
		pc++     
		select case func 
		case halt_
			exit
		case push_
			sp--:return stack_, sp:=eval(code_, pc as long):pc+=4
		case jz_
			sp++: if eval(stack_, sp-1)=0 then pc=eval(code_, pc as long) else pc+=4
		case jmp_
			pc=eval(code_, pc as long)
		case fetch_
			sp--:Return stack_, sp:=eval(stack_, eval(code_, pc as long)):pc+=4
		case store_
			Return stack_, eval(code_, pc as long):=eval(stack_, sp):sp++:pc+=4
		case add_
			Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))+sint(eval(stack_, sp))):sp++
		case sub_
			Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))-sint(eval(stack_, sp))):sp++
		case mul_
			Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))*sint(eval(stack_, sp))):sp++
		case div_
			Return stack_, sp+1:=uint(sint(eval(stack_, sp+1)) div sint(eval(stack_, sp))):sp++
		case mod_
			Return stack_, sp+1:=uint(sint(eval(stack_, sp+1)) mod sint(eval(stack_, sp))) :sp++
		case not_
			Return stack_, sp:=if(eval(stack_, sp)=0->uint(-1),0)
		case neg_  \\ we can use neg(sint(value))+1 or uint(-sint(value))
			Return stack_, sp:=uint(-sint(eval(stack_, sp)))
		case and_
			Return stack_, sp+1:=binary.and(eval(stack_, sp+1),eval(stack_, sp)):sp++	
		case or_
			Return stack_, sp+1:=binary.or(eval(stack_, sp+1),eval(stack_, sp)):sp++	
		case lt_
			Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))<sint(eval(stack_, sp))->-1, 0)):sp++
		case gt_
			Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))>sint(eval(stack_, sp))->-1, 0)):sp++
		case le_
			Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))<=sint(eval(stack_, sp))->-1, 0)):sp++
		case ge_
			Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))>=sint(eval(stack_, sp))->-1, 0)):sp++
		case ne_
			Return stack_, sp+1:=uint(if(eval(stack_, sp+1)<>eval(stack_, sp)->-1, 0)):sp++
		case eq_
			Return stack_, sp+1:=uint(if(eval(stack_, sp+1)=eval(stack_, sp)->-1, 0)):sp++
		case prts_
			printsrv strings$(eval(stack_,sp)):sp++
		case prti_
			printsrv str$(sint(eval(stack_,sp)),0):sp++
		case prtc_
			printsrv chrcode$(eval(stack_,sp)):sp++
		else case
			Error "Unkown op "+str$(func) 
		end select			
	} always
	Print "done"
}
Virtual_Machine_Interpreter {
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
}

Using Lambda functions

A call local to function pass the current scope to function, so it's like a call to subroutine, but faster.

Module Virtual_Machine_Interpreter (a$){
	\\ function to extract string, replacing escape codes.
	Function GetString$(a$) {
		s=instr(a$, chr$(34))
		m=rinstr(a$,chr$(34))-s
		if m>1 then
			\\ process escape codes
			=format$(mid$(a$, s+1, m-1))
		else
			=""
		end if
	}
	\\ module to print a string to console using codes, 13, 10, 9
	Module printsrv (a$) {
		for i=1 to len(a$)
			select case chrcode(Mid$(a$,i,1))
			case 13
				cursor 0
			case 10
				cursor 0 : Print
			case 9
				cursor ((pos+tab) div tab)*tab
			else case
			{
				m=pos :if pos>=width then Print : m=pos
				Print Mid$(a$,i,1);
				if m<=width then cursor m+1
			}
			end select
		next i
	}
	const nl$=chr$(13)+chr$(10)
	\\ we can set starting value to any number  n where 0<=n<=232
	enum op {	halt_=232, add_, sub_, mul_, div_, mod_, not_, neg_, and_, or_, lt_,
		    	gt_, le_, ge_, ne_, eq_, prts_, prti_, prtc_, store_, fetch_, push_,
			jmp_, jz_
    	}
     	exit_now=false
	Inventory  func=halt_:=lambda->{exit_now=true}
	Append  func, push_:=lambda->{sp--:return stack_, sp:=eval(code_, pc as long):pc+=4}
	Append  func, jz_:=lambda->{
		sp++: if eval(stack_, sp-1)=0 then pc=eval(code_, pc as long) else pc+=4
	}
	Append  func, jmp_:=lambda->{pc=eval(code_, pc as long)}
	Append  func, fetch_:=lambda->{sp--:Return stack_, sp:=eval(stack_, eval(code_, pc as long)):pc+=4}
	Append  func, store_:=lambda->{Return stack_, eval(code_, pc as long):=eval(stack_, sp):sp++:pc+=4}
	Append  func, add_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))+sint(eval(stack_, sp))):sp++}
	Append  func, sub_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))-sint(eval(stack_, sp))):sp++}
	Append  func, mul_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))*sint(eval(stack_, sp))):sp++}
	Append  func, div_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1)) div sint(eval(stack_, sp))):sp++}
	Append  func, mod_:=lambda->{Return stack_, sp+1:=uint(sint(eval(stack_, sp+1)) mod sint(eval(stack_, sp))) :sp++}
	Append  func, not_:=lambda->{Return stack_, sp:=if(eval(stack_, sp)=0->uint(-1),0)}
	Append  func, neg_:=lambda->{Return stack_, sp:=uint(-sint(eval(stack_, sp)))}
	Append  func, and_:=lambda->{Return stack_, sp+1:=binary.and(eval(stack_, sp+1),eval(stack_, sp)):sp++	}
	Append  func, or_:=lambda->{Return stack_, sp+1:=binary.or(eval(stack_, sp+1),eval(stack_, sp)):sp++	}
	Append  func, lt_:=lambda->{Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))<sint(eval(stack_, sp))->-1, 0)):sp++}
	Append  func, gt_:=lambda->{Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))>sint(eval(stack_, sp))->-1, 0)):sp++}
	Append  func, le_:=lambda->{Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))<=sint(eval(stack_, sp))->-1, 0)):sp++}
	Append  func, ge_:=lambda->{Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))>=sint(eval(stack_, sp))->-1, 0)):sp++}
	Append  func, ne_:=lambda->{Return stack_, sp+1:=uint(if(eval(stack_, sp+1)<>eval(stack_, sp)->-1, 0)):sp++}
	Append  func, eq_:=lambda->{Return stack_, sp+1:=uint(if(eval(stack_, sp+1)=eval(stack_, sp)->-1, 0)):sp++}
	Append  func, prts_:=lambda->{printsrv strings$(eval(stack_,sp)):sp++}
	Append  func, prti_:=lambda->{printsrv str$(sint(eval(stack_,sp)),0):sp++}
	Append  func, prtc_:=lambda->{printsrv chrcode$(eval(stack_,sp)):sp++}
	Rem : Form 120, 60 ' change console width X height to run Ascii Mandlebrot examlpe
	Report "Virtual Assembly Code:"+{
	}+a$
	Print "Prepare Byte Code"
 
	\\ get datasize
	a$=rightpart$(a$, "Datasize:")
	m=0
	data_size=val(a$, "int", m)
	a$=mid$(a$, m)
	\\ make stack
	if data_size>0 then Buffer Clear stack_ as long*data_size
	\\ dim or redim buffer append 1000 long as is.
	Buffer stack_ as long*(1000+data_size)
	\\ get strings
	a$=rightpart$(a$, "Strings:")
	m=0
	strings=val(a$, "int", m)
	a$=rightpart$(a$, nl$)
 
	if strings>0 then
		Dim strings$(strings)
		for i=0 to strings-1
			strings$(i)=GetString$(leftpart$(a$, nl$))
			a$=rightpart$(a$, nl$)
		Next i
	End if
	buffer clear code_ as byte*1000
	do
		m=0
		offset=val(a$,"int", m)
		if m<0 then exit
		a$=mid$(a$,m)
		line$=trim$(leftpart$(a$,nl$))
		if line$="" then line$=trim$(a$) else a$=trim$(rightpart$(a$, nl$))
		op$=if$(instr(line$," ")>0->leftpart$(line$," "), line$)
		if not valid(eval(op$+"_")) then exit
		opc=eval(op$+"_")
		Return code_, offset:=opc
		if opc>=store_ then
			line$=rightpart$(line$," ")
			select case opc
			case store_, fetch_
				Return code_, offset+1:=val(rightpart$(leftpart$(line$,"]"),"[")) as long : offset+=4
			case push_
				Return code_, offset+1:=uint(val(line$)) as long : offset+=4
			case jz_, jmp_
				Return code_, offset+1:=val(rightpart$(line$,")")) as long : offset+=4
			end select 
		end if
	Always
	Print "Press any key" : Push key$ : Drop
	\\ Prepare VM
	let pc=0, sp=len(stack_) div 4
	do
		b=func(eval(code_, pc))
		pc++
		call local b()
	until exit_now
	Print "done"
}
Virtual_Machine_Interpreter {
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
}

Mercury

Works with: Mercury version 20.06.1


In the hope of achieving good speed, this implementation takes advantage of Mercury's support for signed and unsigned fixed-width integer types.

The speed on mandel.vm seems better than that of my Common Lisp implementation on SBCL. (The Common Lisp implementation is not written for speed.) Neither of these programs is anywhere near as fast as my ATS implementation, which should be about as fast as a quality C implementation.

One huge advantage for Mercury over SBCL is program size. The compiled program for Mercury is 65080 bytes long, with links to shared libraries for Mercury and Boehm GC. With SBCL I get a dumped executable file 13738880 bytes long, and I believe that is after compression; also, it takes a bit of time to start up. My program compiled with ATS is 37264 bytes long and links only to the default C libraries.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% The Rosetta Code Virtual Machine, in Mercury.
%%%
%%% (This particular machine is arbitrarily chosen to be big-endian.)
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

:- module vm.

:- interface.
:- import_module io.
:- pred main(io::di, io::uo) is det.

:- implementation.
:- import_module array.
:- import_module bool.
:- import_module char.
:- import_module exception.
:- import_module int.
:- import_module int32.
:- import_module list.
:- import_module string.
:- import_module uint.
:- import_module uint8.
:- import_module uint32.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% uint32 operations.
%%%

:- func twos_cmp(uint32) = uint32.
:- mode twos_cmp(in) = out is det.
:- pragma inline(twos_cmp/1).
twos_cmp(U) = NegU :-
  (NegU = (\U) + 1_u32).

:- func unsigned_add(uint32, uint32) = uint32.
:- mode unsigned_add(in, in) = out is det.
:- pragma inline(unsigned_add/2).
unsigned_add(U, V) = U_plus_V :-
  (U_plus_V = U + V).

:- func unsigned_sub(uint32, uint32) = uint32.
:- mode unsigned_sub(in, in) = out is det.
:- pragma inline(unsigned_sub/2).
unsigned_sub(U, V) = U_minus_V :-
  (U_minus_V = U - V).

:- func signed_mul(uint32, uint32) = uint32.
:- mode signed_mul(in, in) = out is det.
:- pragma inline(signed_mul/2).
signed_mul(U, V) = UV :-
  UV = cast_from_int32(cast_from_uint32(U) * cast_from_uint32(V)).

:- func signed_quot(uint32, uint32) = uint32.
:- mode signed_quot(in, in) = out is det.
:- pragma inline(signed_quot/2).
signed_quot(U, V) = U_quot_V :- % Truncation towards zero.
  U_quot_V = cast_from_int32(cast_from_uint32(U)
                             // cast_from_uint32(V)).

:- func signed_rem(uint32, uint32) = uint32.
:- mode signed_rem(in, in) = out is det.
:- pragma inline(signed_rem/2).
signed_rem(U, V) = U_rem_V :-   % Truncation towards zero, sign of U.
  U_rem_V = cast_from_int32(cast_from_uint32(U)
                            rem cast_from_uint32(V)).

:- func signed_lt(uint32, uint32) = uint32.
:- mode signed_lt(in, in) = out is det.
:- pragma inline(signed_lt/2).
signed_lt(U, V) = U_lt_V :-
  if (int32.cast_from_uint32(U) < int32.cast_from_uint32(V))
  then (U_lt_V = 1_u32)
  else (U_lt_V = 0_u32).

:- func signed_le(uint32, uint32) = uint32.
:- mode signed_le(in, in) = out is det.
:- pragma inline(signed_le/2).
signed_le(U, V) = U_le_V :-
  if (int32.cast_from_uint32(U) =< int32.cast_from_uint32(V))
  then (U_le_V = 1_u32)
  else (U_le_V = 0_u32).

:- func signed_gt(uint32, uint32) = uint32.
:- mode signed_gt(in, in) = out is det.
:- pragma inline(signed_gt/2).
signed_gt(U, V) = U_gt_V :-
  U_gt_V = signed_lt(V, U).

:- func signed_ge(uint32, uint32) = uint32.
:- mode signed_ge(in, in) = out is det.
:- pragma inline(signed_ge/2).
signed_ge(U, V) = U_ge_V :-
  U_ge_V = signed_le(V, U).

:- func unsigned_eq(uint32, uint32) = uint32.
:- mode unsigned_eq(in, in) = out is det.
:- pragma inline(unsigned_eq/2).
unsigned_eq(U, V) = U_eq_V :-
  if (U = V)
  then (U_eq_V = 1_u32)
  else (U_eq_V = 0_u32).

:- func unsigned_ne(uint32, uint32) = uint32.
:- mode unsigned_ne(in, in) = out is det.
:- pragma inline(unsigned_ne/2).
unsigned_ne(U, V) = U_ne_V :-
  if (U \= V)
  then (U_ne_V = 1_u32)
  else (U_ne_V = 0_u32).

:- func logical_cmp(uint32) = uint32.
:- mode logical_cmp(in) = out is det.
:- pragma inline(logical_cmp/1).
logical_cmp(U) = NotU :-
  if (U = 0_u32)
  then (NotU = 1_u32)
  else (NotU = 0_u32).

:- func logical_and(uint32, uint32) = uint32.
:- mode logical_and(in, in) = out is det.
:- pragma inline(logical_and/2).
logical_and(U, V) = U_and_V :-
  if (U \= 0_u32, V \= 0_u32)
  then (U_and_V = 1_u32)
  else (U_and_V = 0_u32).

:- func logical_or(uint32, uint32) = uint32.
:- mode logical_or(in, in) = out is det.
:- pragma inline(logical_or/2).
logical_or(U, V) = U_or_V :-
  if (U \= 0_u32; V \= 0_u32)
  then (U_or_V = 1_u32)
  else (U_or_V = 0_u32).

:- pred to_bytes(uint32, uint8, uint8, uint8, uint8).
:- mode to_bytes(in, out, out, out, out) is det.
:- pragma inline(to_bytes/5).
to_bytes(U, B3, B2, B1, B0) :-
  (B0 = cast_from_int(cast_to_int(U /\ 0xFF_u32))),
  (B1 = cast_from_int(cast_to_int((U >> 8) /\ 0xFF_u32))),
  (B2 = cast_from_int(cast_to_int((U >> 16) /\ 0xFF_u32))),
  (B3 = cast_from_int(cast_to_int((U >> 24) /\ 0xFF_u32))).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% String operations.
%%%

:- pred digit_u32(char, uint32).
:- mode digit_u32(in, out) is semidet.
digit_u32(('0'), 0_u32).
digit_u32(('1'), 1_u32).
digit_u32(('2'), 2_u32).
digit_u32(('3'), 3_u32).
digit_u32(('4'), 4_u32).
digit_u32(('5'), 5_u32).
digit_u32(('6'), 6_u32).
digit_u32(('7'), 7_u32).
digit_u32(('8'), 8_u32).
digit_u32(('9'), 9_u32).

:- pred is_not_digit(char).
:- mode is_not_digit(in) is semidet.
is_not_digit(C) :-
  not is_digit(C).

:- pred is_not_alnum_nor_minus(char).
:- mode is_not_alnum_nor_minus(in) is semidet.
is_not_alnum_nor_minus(C) :-
  not (is_alnum(C); C = ('-')).

:- pred det_string_to_uint32(string, uint32).
:- mode det_string_to_uint32(in, out) is det.
det_string_to_uint32(S, U) :-
  to_char_list(S) = CL,
  (if (det_string_to_uint32_loop(CL, 0_u32, U1))
   then (U = U1)
   else throw("cannot convert string to uint32")).

:- pred det_string_to_uint32_loop(list(char), uint32, uint32).
:- mode det_string_to_uint32_loop(in, in, out) is semidet.
det_string_to_uint32_loop([], U0, U1) :- U1 = U0.
det_string_to_uint32_loop([C | Tail], U0, U1) :-
  digit_u32(C, Digit),
  det_string_to_uint32_loop(Tail, (U0 * 10_u32) + Digit, U1).

:- pred det_signed_string_to_uint32(string, uint32).
:- mode det_signed_string_to_uint32(in, out) is det.
det_signed_string_to_uint32(S, U) :-
  if prefix(S, "-")
  then (det_remove_prefix("-", S, S1),
        det_string_to_uint32(S1, U1),
        U = twos_cmp(U1))
  else det_string_to_uint32(S, U).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Parsing the "assembly" language.
%%%

:- func opcode_halt  = uint8.
:- func opcode_add   = uint8.
:- func opcode_sub   = uint8.
:- func opcode_mul   = uint8.
:- func opcode_div   = uint8.
:- func opcode_mod   = uint8.
:- func opcode_lt    = uint8.
:- func opcode_gt    = uint8.
:- func opcode_le    = uint8.
:- func opcode_ge    = uint8.
:- func opcode_eq    = uint8.
:- func opcode_ne    = uint8.
:- func opcode_and   = uint8.
:- func opcode_or    = uint8.
:- func opcode_neg   = uint8.
:- func opcode_not   = uint8.
:- func opcode_prtc  = uint8.
:- func opcode_prti  = uint8.
:- func opcode_prts  = uint8.
:- func opcode_fetch = uint8.
:- func opcode_store = uint8.
:- func opcode_push  = uint8.
:- func opcode_jmp   = uint8.
:- func opcode_jz    = uint8.
opcode_halt  = 0_u8.
opcode_add   = 1_u8.
opcode_sub   = 2_u8.
opcode_mul   = 3_u8.
opcode_div   = 4_u8.
opcode_mod   = 5_u8.
opcode_lt    = 6_u8.
opcode_gt    = 7_u8.
opcode_le    = 8_u8.
opcode_ge    = 9_u8.
opcode_eq    = 10_u8.
opcode_ne    = 11_u8.
opcode_and   = 12_u8.
opcode_or    = 13_u8.
opcode_neg   = 14_u8.
opcode_not   = 15_u8.
opcode_prtc  = 16_u8.
opcode_prti  = 17_u8.
opcode_prts  = 18_u8.
opcode_fetch = 19_u8.
opcode_store = 20_u8.
opcode_push  = 21_u8.
opcode_jmp   = 22_u8.
opcode_jz    = 23_u8.

:- pred opcode(string, uint8).
:- mode opcode(in, out) is semidet.
%:- mode opcode(out, in) is semidet.  <-- Not needed.
opcode("halt",  opcode_halt).
opcode("add",   opcode_add).
opcode("sub",   opcode_sub).
opcode("mul",   opcode_mul).
opcode("div",   opcode_div).
opcode("mod",   opcode_mod).
opcode("lt",    opcode_lt).
opcode("gt",    opcode_gt).
opcode("le",    opcode_le).
opcode("ge",    opcode_ge).
opcode("eq",    opcode_eq).
opcode("ne",    opcode_ne).
opcode("and",   opcode_and).
opcode("or",    opcode_or).
opcode("neg",   opcode_neg).
opcode("not",   opcode_not).
opcode("prtc",  opcode_prtc).
opcode("prti",  opcode_prti).
opcode("prts",  opcode_prts).
opcode("fetch", opcode_fetch).
opcode("store", opcode_store).
opcode("push",  opcode_push).
opcode("jmp",   opcode_jmp).
opcode("jz",    opcode_jz).

:- pred parse_header(string, uint32, uint32).
:- mode parse_header(in, out, out) is det.
parse_header(S, Datasize, Strings_Count) :-
  % Split S on any non-digit characters, leaving a list of the two
  % runs of digits.
  if (words_separator(is_not_digit, S) = [S_Datasize, S_Strings])
  % Convert the runs of digits to uint32.
  then (det_string_to_uint32(S_Datasize, Datasize),
        det_string_to_uint32(S_Strings, Strings_Count))
  else throw("cannot parse the header").

:- pred parse_string_literal(string, string).
:- mode parse_string_literal(in, out) is det.
parse_string_literal(S0, S) :-
  % Strip leading/trailing space.
  S1 = strip(S0),
  % Remove the " characters.
  det_remove_prefix("\"", S1, S2),
  det_remove_suffix(S2, "\"") = S3,
  % Deal with "\\" and "\n".
  replace_escapes(S3, S).

:- pred replace_escapes(string, string).
:- mode replace_escapes(in, out) is det.
replace_escapes(S0, S) :-
  CL0 = to_char_list(S0),
  replace_escapes(CL0, [], CL),
  S = from_rev_char_list(CL).

:- pred replace_escapes(list(char), list(char), list(char)).
:- mode replace_escapes(in, in, out) is det.
replace_escapes([], Dst0, Dst) :-
  Dst = Dst0.
replace_escapes([C | Tail], Dst0, Dst) :-
  if (C \= ('\\'))
  then replace_escapes(Tail, [C | Dst0], Dst)
  else (if (Tail = [C1 | Tail1])
        then (if (C1 = ('n'))
              then replace_escapes(Tail1, [('\n') | Dst0], Dst)
              else if (C1 = ('\\'))
              then replace_escapes(Tail1, [('\\') | Dst0], Dst)
              else throw("illegal escape sequence"))
        else throw("truncated escape sequence")).

:- pred parse_instruction(string, {uint32, uint8, uint32}).
:- mode parse_instruction(in, out) is det.
parse_instruction(S, {Address, Opcode, Arg}) :-
  words_separator(is_not_alnum_nor_minus, S) = Lst,
  (if parse_instr_lst(Lst, {Addr, Op, A})
   then (Address = Addr, Opcode = Op, Arg = A)
   else throw("cannot parse instruction")).

:- pred parse_instr_lst(list(string), {uint32, uint8, uint32}).
:- mode parse_instr_lst(in, out) is semidet.
parse_instr_lst([S_Address, S_Opcode],
                {Address, Opcode, Arg}) :-
  det_string_to_uint32(S_Address, Address),
  opcode(S_Opcode, Opcode),
  Arg = 0_u32.
parse_instr_lst([S_Address, S_Opcode, S_Arg | _],
                {Address, Opcode, Arg}) :-
  det_string_to_uint32(S_Address, Address),
  opcode(S_Opcode, Opcode),
  det_signed_string_to_uint32(S_Arg, Arg).

:- pred parse_assembly((io.text_input_stream), uint32, uint32,
                       array(string),
                       list({uint32, uint8, uint32}),
                       io, io).
:- mode parse_assembly(in, out, out, out, out, di, uo) is det.
parse_assembly(InpF, Datasize, Strings_Count, Strings,
               Instructions, !IO) :-
  read_line_as_string(InpF, Res, !IO),
  (if (Res = ok(Line))
   then (parse_header(Line, Datasize, Strings_Count),
         read_and_parse_strings(InpF, Strings_Count, Strings, !IO),
         read_and_parse_instructions(InpF, Instructions, !IO))
   else if (Res = eof)
   then throw("empty input")
   else throw("read error")).

:- pred read_and_parse_strings((io.text_input_stream), uint32,
                               array(string), io, io).
:- mode read_and_parse_strings(in, in, out, di, uo) is det.
read_and_parse_strings(InpF, Strings_Count, Strings, !IO) :-
  read_n_string_literals(InpF, Strings_Count, [], Lst, !IO),
  Strings = array(Lst).

:- pred read_n_string_literals((io.text_input_stream), uint32,
                               list(string), list(string),
                               io, io).
:- mode read_n_string_literals(in, in, in, out, di, uo) is det.
read_n_string_literals(InpF, N, Lst0, Lst, !IO) :-
  if (N = 0_u32)
  then (Lst = reverse(Lst0))
  else (read_line_as_string(InpF, Res, !IO),
        (if (Res = ok(Line))
         then (parse_string_literal(Line, S),
               read_n_string_literals(InpF, N - 1_u32,
                                      [S | Lst0], Lst, !IO))
         else if (Res = eof)
         then throw("premature end of input")
         else throw("read error"))).

:- pred read_and_parse_instructions((io.text_input_stream),
                                    list({uint32, uint8, uint32}),
                                    io, io).
:- mode read_and_parse_instructions(in, out, di, uo) is det.
read_and_parse_instructions(InpF, Instructions, !IO) :-
  read_all_instructions(InpF, [], Instructions, !IO).

:- pred read_all_instructions((io.text_input_stream),
                              list({uint32, uint8, uint32}),
                              list({uint32, uint8, uint32}),
                              io, io).
:- mode read_all_instructions(in, in, out, di, uo) is det.
read_all_instructions(InpF, Lst0, Lst, !IO) :-
  read_line_as_string(InpF, Res, !IO),
  (if (Res = eof)
   then (Lst = Lst0)           % There is no need to reverse the list.
   else if (Res = ok(Line))
   then (strip(Line) = S,
         (if is_empty(S)
          then read_all_instructions(InpF, Lst0, Lst, !IO)
          else (parse_instruction(S, Instr),
                read_all_instructions(InpF, [Instr | Lst0], Lst,
                                      !IO))))
   else throw("read error")).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Constructing the executable memory.
%%%

:- func greatest_address(list({uint32, uint8, uint32}),
                         uint32) = uint32.
:- mode greatest_address(in, in) = out is det.
greatest_address([], Min_Result) = Result :-
  Result = Min_Result.
greatest_address([{Addr, _, _} | Tail], Min_Result) = Result :-
  if (Min_Result < Addr)
  then (Result = greatest_address(Tail, Addr))
  else (Result = greatest_address(Tail, Min_Result)).

:- pred executable_memory(list({uint32, uint8, uint32}),
                          array(uint8)).
:- mode executable_memory(in, out) is det.
executable_memory(Instructions, Code) :-
  greatest_address(Instructions, 0_u32) = Addr,
  Code_Size = (Addr + 5_u32),   % At least enough memory.
  init(cast_to_int(Code_Size), opcode_halt, Code0),
  fill_executable_memory(Instructions, Code0, Code).

:- pred fill_executable_memory(list({uint32, uint8, uint32}),
                               array(uint8), array(uint8)).
:- mode fill_executable_memory(in, array_di, array_uo) is det.
fill_executable_memory([], !Code) :- true.
fill_executable_memory([Instr | Tail], !Code) :-
  Instr = {Address, Opcode, Arg},
  Addr = cast_to_int(Address),
  set(Addr, Opcode, !Code),
  (if (Opcode = opcode_fetch;
       Opcode = opcode_store;
       Opcode = opcode_push;
       Opcode = opcode_jmp;
       Opcode = opcode_jz)
   then (to_bytes(Arg, B3, B2, B1, B0),
         % Store the argument in big-endian order.
         set(Addr + 1, B3, !Code),
         set(Addr + 2, B2, !Code),
         set(Addr + 3, B1, !Code),
         set(Addr + 4, B0, !Code))
   else true),
  fill_executable_memory(Tail, !Code).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%e
%%%
%%% Executing the code.
%%%

:- pred machine_add(array(uint32), array(uint32), uint32, uint32).
:- mode machine_add(array_di, array_uo, in, out) is det.
:- pragma inline(machine_add/4).
machine_add(Stack0, Stack, SP0, SP) :-
  Result = unsigned_add(lookup(Stack0, cast_to_int(SP - 1_u32)),
                        lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_sub(array(uint32), array(uint32), uint32, uint32).
:- mode machine_sub(array_di, array_uo, in, out) is det.
:- pragma inline(machine_sub/4).
machine_sub(Stack0, Stack, SP0, SP) :-
  Result = unsigned_sub(lookup(Stack0, cast_to_int(SP - 1_u32)),
                        lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_mul(array(uint32), array(uint32), uint32, uint32).
:- mode machine_mul(array_di, array_uo, in, out) is det.
:- pragma inline(machine_mul/4).
machine_mul(Stack0, Stack, SP0, SP) :-
  Result = signed_mul(lookup(Stack0, cast_to_int(SP - 1_u32)),
                      lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_div(array(uint32), array(uint32), uint32, uint32).
:- mode machine_div(array_di, array_uo, in, out) is det.
:- pragma inline(machine_div/4).
machine_div(Stack0, Stack, SP0, SP) :-
  Result = signed_quot(lookup(Stack0, cast_to_int(SP - 1_u32)),
                       lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_mod(array(uint32), array(uint32), uint32, uint32).
:- mode machine_mod(array_di, array_uo, in, out) is det.
:- pragma inline(machine_mod/4).
machine_mod(Stack0, Stack, SP0, SP) :-
  Result = signed_rem(lookup(Stack0, cast_to_int(SP - 1_u32)),
                      lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_lt(array(uint32), array(uint32), uint32, uint32).
:- mode machine_lt(array_di, array_uo, in, out) is det.
:- pragma inline(machine_lt/4).
machine_lt(Stack0, Stack, SP0, SP) :-
  Result = signed_lt(lookup(Stack0, cast_to_int(SP - 1_u32)),
                     lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_le(array(uint32), array(uint32), uint32, uint32).
:- mode machine_le(array_di, array_uo, in, out) is det.
:- pragma inline(machine_le/4).
machine_le(Stack0, Stack, SP0, SP) :-
  Result = signed_le(lookup(Stack0, cast_to_int(SP - 1_u32)),
                     lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_gt(array(uint32), array(uint32), uint32, uint32).
:- mode machine_gt(array_di, array_uo, in, out) is det.
:- pragma inline(machine_gt/4).
machine_gt(Stack0, Stack, SP0, SP) :-
  Result = signed_gt(lookup(Stack0, cast_to_int(SP - 1_u32)),
                     lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_ge(array(uint32), array(uint32), uint32, uint32).
:- mode machine_ge(array_di, array_uo, in, out) is det.
:- pragma inline(machine_ge/4).
machine_ge(Stack0, Stack, SP0, SP) :-
  Result = signed_ge(lookup(Stack0, cast_to_int(SP - 1_u32)),
                     lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_eq(array(uint32), array(uint32), uint32, uint32).
:- mode machine_eq(array_di, array_uo, in, out) is det.
:- pragma inline(machine_eq/4).
machine_eq(Stack0, Stack, SP0, SP) :-
  Result = unsigned_eq(lookup(Stack0, cast_to_int(SP - 1_u32)),
                       lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_ne(array(uint32), array(uint32), uint32, uint32).
:- mode machine_ne(array_di, array_uo, in, out) is det.
:- pragma inline(machine_ne/4).
machine_ne(Stack0, Stack, SP0, SP) :-
  Result = unsigned_ne(lookup(Stack0, cast_to_int(SP - 1_u32)),
                       lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_and(array(uint32), array(uint32), uint32, uint32).
:- mode machine_and(array_di, array_uo, in, out) is det.
:- pragma inline(machine_and/4).
machine_and(Stack0, Stack, SP0, SP) :-
  Result = logical_and(lookup(Stack0, cast_to_int(SP - 1_u32)),
                       lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_or(array(uint32), array(uint32), uint32, uint32).
:- mode machine_or(array_di, array_uo, in, out) is det.
:- pragma inline(machine_or/4).
machine_or(Stack0, Stack, SP0, SP) :-
  Result = logical_or(lookup(Stack0, cast_to_int(SP - 1_u32)),
                      lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_neg(array(uint32), array(uint32), uint32, uint32).
:- mode machine_neg(array_di, array_uo, in, out) is det.
:- pragma inline(machine_neg/4).
machine_neg(Stack0, Stack, SP0, SP) :-
  SP = SP0,
  (I = uint32.cast_to_int(SP0)),
  Result = twos_cmp(lookup(Stack0, I - 1)),
  set(I - 1, Result, Stack0, Stack).

:- pred machine_not(array(uint32), array(uint32), uint32, uint32).
:- mode machine_not(array_di, array_uo, in, out) is det.
:- pragma inline(machine_not/4).
machine_not(Stack0, Stack, SP0, SP) :-
  SP = SP0,
  (I = uint32.cast_to_int(SP0)),
  Result = logical_cmp(lookup(Stack0, I - 1)),
  set(I - 1, Result, Stack0, Stack).

:- pred machine_prtc((io.text_output_stream),
                     array(uint32), array(uint32),
                     uint32, uint32, io, io).
:- mode machine_prtc(in, array_di, array_uo, in, out,
                     di, uo) is det.
machine_prtc(OutF, Stack0, Stack, SP0, SP, !IO) :-
  Stack = Stack0,
  (I = uint32.cast_to_int(SP0)),
  X = lookup(Stack0, I - 1),
  C = (char.det_from_int(uint32.cast_to_int(X))),
  (io.write_char(OutF, C, !IO)),
  SP = SP0 - 1_u32.

:- pred machine_prti((io.text_output_stream),
                     array(uint32), array(uint32),
                     uint32, uint32, io, io).
:- mode machine_prti(in, array_di, array_uo, in, out,
                     di, uo) is det.
machine_prti(OutF, Stack0, Stack, SP0, SP, !IO) :-
  Stack = Stack0,
  (I = uint32.cast_to_int(SP0)),
  (X = int32.cast_from_uint32(lookup(Stack0, I - 1))),
  (io.write_int32(OutF, X, !IO)),
  SP = SP0 - 1_u32.

:- pred machine_prts((io.text_output_stream),
                     array(string),
                     array(uint32), array(uint32),
                     uint32, uint32, io, io).
:- mode machine_prts(in, in, array_di, array_uo, in, out,
                     di, uo) is det.
machine_prts(OutF, Strings, Stack0, Stack, SP0, SP, !IO) :-
  Stack = Stack0,
  (I = uint32.cast_to_int(SP0)),
  (K = uint32.cast_to_int(lookup(Stack0, I - 1))),
  S = lookup(Strings, K),
  (io.write_string(OutF, S, !IO)),
  SP = SP0 - 1_u32.

:- func get_immediate(array(uint8), uint32) = uint32.
:- mode get_immediate(in, in) = out is det.
:- pragma inline(get_immediate/2).
get_immediate(Code, IP) = Immediate_Value :-
  % Big-endian order.
  I = cast_to_int(IP),
  B3 = lookup(Code, I),
  B2 = lookup(Code, I + 1),
  B1 = lookup(Code, I + 2),
  B0 = lookup(Code, I + 3),
  Immediate_Value = from_bytes_be(B3, B2, B1, B0).

:- pred machine_fetch(array(uint32), array(uint32),
                      array(uint8), uint32, uint32,
                      array(uint32), array(uint32),
                      uint32, uint32).
:- mode machine_fetch(array_di, array_uo, in, in, out,
                      array_di, array_uo, in, out) is det.
:- pragma inline(machine_fetch/9).
machine_fetch(Data0, Data, Code, IP0, IP, !Stack, SP0, SP) :-
  Data = Data0,
  K = get_immediate(Code, IP0),
  IP = IP0 + 4_u32,
  X = lookup(Data0, cast_to_int(K)),
  set(cast_to_int(SP0), X, !Stack),
  SP = SP0 + 1_u32.

:- pred machine_store(array(uint32), array(uint32),
                      array(uint8), uint32, uint32,
                      array(uint32), array(uint32),
                      uint32, uint32).
:- mode machine_store(array_di, array_uo, in, in, out,
                      array_di, array_uo, in, out) is det.
:- pragma inline(machine_store/9).
machine_store(!Data, Code, IP0, IP, Stack0, Stack, SP0, SP) :-
  Stack = Stack0,
  K = get_immediate(Code, IP0),
  IP = IP0 + 4_u32,
  SP = SP0 - 1_u32,
  X = lookup(Stack0, cast_to_int(SP)),
  set(cast_to_int(K), X, !Data).

:- pred machine_push(array(uint8), uint32, uint32,
                     array(uint32), array(uint32),
                     uint32, uint32).
:- mode machine_push(in, in, out, array_di, array_uo, in, out) is det.
:- pragma inline(machine_push/7).
machine_push(Code, IP0, IP, !Stack, SP0, SP) :-
  X = get_immediate(Code, IP0),
  IP = IP0 + 4_u32,
  set(cast_to_int(SP0), X, !Stack),
  SP = SP0 + 1_u32.

:- pred machine_jmp(array(uint8), uint32, uint32).
:- mode machine_jmp(in, in, out) is det.
:- pragma inline(machine_jmp/3).
machine_jmp(Code, IP0, IP) :-
  Offset = get_immediate(Code, IP0),
  IP = unsigned_add(IP0, Offset).

:- pred machine_jz(array(uint8), uint32, uint32,
                   array(uint32), array(uint32),
                   uint32, uint32).
:- mode machine_jz(in, in, out, array_di, array_uo, in, out) is det.
:- pragma inline(machine_jz/7).
machine_jz(Code, IP0, IP, Stack0, Stack, SP0, SP) :-
  Stack = Stack0,
  SP = SP0 - 1_u32,
  X = lookup(Stack0, cast_to_int(SP)),
  (if (X = 0_u32)
   then (Offset = get_immediate(Code, IP0),
         IP = unsigned_add(IP0, Offset))
   else (IP = IP0 + 4_u32)).

:- pred run_one_instruction((io.text_output_stream),
                            array(string),
                            array(uint32), array(uint32),
                            array(uint8), uint32, uint32,
                            array(uint32), array(uint32),
                            uint32, uint32, bool, io, io).
:- mode run_one_instruction(in, in, array_di, array_uo,
                            in, in, out, array_di, array_uo,
                            in, out, out, di, uo) is det.
run_one_instruction(OutF, Strings, !Data,
                    Code, IP0, IP, !Stack, !SP,
                    Halt, !IO) :-
  %
  % In the following implementation, any unrecognized instruction
  % causes a HALT, just as an actual "halt" opcode would.
  %
  Opcode = lookup(Code, cast_to_int(IP0)),
  IP1 = IP0 + 1_u32,
  I = (Opcode >> 2),
  J = (Opcode /\ 0x03_u8),
  (if (I = 0_u8)
   then (IP = IP1,
         (if (J = 0_u8)
          then (Halt = yes)
          else if (J = 1_u8)
          then (machine_add(!Stack, !SP),
                Halt = no)
          else if (J = 2_u8)
          then (machine_sub(!Stack, !SP),
                Halt = no)
          else (machine_mul(!Stack, !SP),
                Halt = no)))
   else if (I = 1_u8)
   then (Halt = no,
         IP = IP1,
         (if (J = 0_u8)
          then machine_div(!Stack, !SP)
          else if (J = 1_u8)
          then machine_mod(!Stack, !SP)
          else if (J = 2_u8)
          then machine_lt(!Stack, !SP)
          else machine_gt(!Stack, !SP)))
   else if (I = 2_u8)
   then (Halt = no,
         IP = IP1,
         (if (J = 0_u8)
          then machine_le(!Stack, !SP)
          else if (J = 1_u8)
          then machine_ge(!Stack, !SP)
          else if (J = 2_u8)
          then machine_eq(!Stack, !SP)
          else machine_ne(!Stack, !SP)))
   else if (I = 3_u8)
   then (Halt = no,
         IP = IP1,
         (if (J = 0_u8)
          then machine_and(!Stack, !SP)
          else if (J = 1_u8)
          then machine_or(!Stack, !SP)
          else if (J = 2_u8)
          then machine_neg(!Stack, !SP)
          else machine_not(!Stack, !SP)))
   else if (I = 4_u8)
   then (Halt = no,
         (if (J = 0_u8)
          then (machine_prtc(OutF, !Stack, !SP, !IO),
                IP = IP1)
          else if (J = 1_u8)
          then (machine_prti(OutF, !Stack, !SP, !IO),
                IP = IP1)
          else if (J = 2_u8)
          then (machine_prts(OutF, Strings, !Stack, !SP, !IO),
                IP = IP1)
          else machine_fetch(!Data, Code, IP1, IP, !Stack, !SP)))
   else if (I = 5_u8)
   then (Halt = no,
         (if (J = 0_u8)
          then machine_store(!Data, Code, IP1, IP, !Stack, !SP)
          else if (J = 1_u8)
          then machine_push(Code, IP1, IP, !Stack, !SP)
          else if (J = 2_u8)
          then machine_jmp(Code, IP1, IP)
          else machine_jz(Code, IP1, IP, !Stack, !SP)))
   else (Halt = yes, IP = IP1)).

:- pred run_program((io.text_output_stream), array(string),
                    array(uint32), array(uint32),
                    array(uint8), uint32, uint32,
                    array(uint32), array(uint32),
                    uint32, uint32, io, io).
:- mode run_program(in, in, array_di, array_uo,
                    in, in, out, array_di, array_uo,
                    in, out, di, uo) is det.
run_program(OutF, Strings, !Data, Code, !IP, !Stack, !SP, !IO) :-
  run_one_instruction(OutF, Strings, !Data, Code, !IP, !Stack, !SP,
                      Halt, !IO),
  (if (Halt = yes)
   then true
   else run_program(OutF, Strings, !Data, Code, !IP, !Stack,
                    !SP, !IO)).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

:- pred open_InpF(text_input_stream, string, io, io).
:- mode open_InpF(out, in, di, uo) is det.
open_InpF(InpF, InpF_filename, !IO) :-
  if (InpF_filename = "-")
  then (InpF = io.stdin_stream)
  else (open_input(InpF_filename, InpF_result, !IO),
        (if (InpF_result = ok(F))
         then (InpF = F)
         else throw("Error: cannot open " ++ InpF_filename ++
                    " for input"))).

:- pred open_OutF(text_output_stream, string, io, io).
:- mode open_OutF(out, in, di, uo) is det.
open_OutF(OutF, OutF_filename, !IO) :-
  if (OutF_filename = "-")
  then (OutF = io.stdout_stream)
  else (open_output(OutF_filename, OutF_result, !IO),
        (if (OutF_result = ok(F))
         then (OutF = F)
         else throw("Error: cannot open " ++ OutF_filename ++
                    " for output"))).

:- pred main_program(string, string, io, io).
:- mode main_program(in, in, di, uo) is det.
main_program(InpF_filename, OutF_filename, !IO) :-
  open_InpF(InpF, InpF_filename, !IO),
  open_OutF(OutF, OutF_filename, !IO),
  parse_assembly(InpF, Datasize, _Strings_Count, Strings,
                 Instructions, !IO),
  (if (InpF_filename = "-")
   then true
   else close_input(InpF, !IO)),
  executable_memory(Instructions, Code),
  init(cast_to_int(Datasize), 0_u32, Data0),
  init(2048, 0_u32, Stack0),    % Stack is 2048 words.
  IP0 = 0_u32,
  SP0 = 0_u32,
  run_program(OutF, Strings, Data0, _Data, Code, IP0, _IP,
              Stack0, _Stack, SP0, _SP, !IO),
  (if (OutF_filename = "-")
   then true
   else close_output(OutF, !IO)).

:- pred usage_error(io, io).
:- mode usage_error(di, uo) is det.
usage_error(!IO) :-
  progname("lex", ProgName, !IO),
  (io.format("Usage: %s [INPUT_FILE [OUTPUT_FILE]]\n",
             [s(ProgName)], !IO)),
  (io.write_string(
        "If INPUT_FILE is \"-\" or not present then standard input is used.\n",
        !IO)),
  (io.write_string(
        "If OUTPUT_FILE is \"-\" or not present then standard output is used.\n",
        !IO)),
  set_exit_status(1, !IO).

main(!IO) :-
  command_line_arguments(Args, !IO),
  (if (Args = [])
   then (InpF_filename = "-",
         OutF_filename = "-",
         main_program(InpF_filename, OutF_filename, !IO))
   else if (Args = [F1])
   then (InpF_filename = F1,
         OutF_filename = "-",
         main_program(InpF_filename, OutF_filename, !IO))
   else if (Args = [F1, F2])
   then (InpF_filename = F1,
         OutF_filename = F2,
         main_program(InpF_filename, OutF_filename, !IO))
   else usage_error(!IO)).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Instructions for GNU Emacs--
%%% local variables:
%%% mode: mercury
%%% prolog-indent-width: 2
%%% end:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


Output:
$ mmc -O6 -intermod-opt --make vm && ./vm compiler-tests/count.vm
Making Mercury/int3s/vm.int3
Making Mercury/ints/vm.int
Making Mercury/cs/vm.c
Making Mercury/os/vm.o
Making vm
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

Nim

import os, parseutils, strutils, strscans, strformat

type

  Value = int32
  BytesValue = array[4, byte]
  Address = int32

  OpCode = enum
           opFetch = "fetch"
           opStore = "store"
           opPush = "push"
           opJmp = "jmp"
           opJz = "jz"
           opAdd = "add"
           opSub = "sub"
           opMul = "mul"
           opDiv = "div"
           opMod = "mod"
           opLt = "lt"
           opgt = "gt"
           opLe = "le"
           opGe = "ge"
           opEq = "eq"
           opNe = "ne"
           opAnd = "and"
           opOr = "or"
           opNeg = "neg"
           opNot = "not"
           opPrtc = "prtc"
           opPrti = "prti"
           opPrts = "prts"
           opHalt = "halt"
           opInvalid = "invalid"

  # Virtual machine description.
  VM = object
    stack: seq[Value]     # Evaluation stack.
    memory: seq[byte]     # Memory to store program.
    data: seq[Value]      # Data storage.
    strings: seq[string]  # String storage.
    pc: Address           # Program counter.

  # Exceptions.
  LoadingError = object of CatchableError
  RuntimeError = object of CatchableError


####################################################################################################
# Running program.

proc checkStackLength(vm: VM; minLength: int) {.inline.} =
  ## Check that evaluation stack contains at least "minLength" elements.
  if vm.stack.len < minLength:
    raise newException(RuntimeError, &"not enough operands on the stack (pc = {vm.pc}).")

#---------------------------------------------------------------------------------------------------

proc getOperand(vm: var VM): Value =
  ## Get a 32 bits operand.

  type Union {.union.} = object
    value: Value
    bytes: BytesValue

  if vm.pc + 4 >= vm.memory.len:
    raise newException(RuntimeError, &"out of memory (pc = {vm.pc}).")

  var aux: Union
  let address = vm.pc + 1
  for idx in 0..3:
    aux.bytes[idx] = vm.memory[address + idx]
  result = aux.value

#---------------------------------------------------------------------------------------------------

proc run(vm: var VM) =
  ## Run a program loaded in VM memory.

  vm.pc = 0

  while true:

    if vm.pc notin 0..vm.memory.high:
      raise newException(RuntimeError, &"out of memory (pc = {vm.pc}).")

    let opcode = OpCode(vm.memory[vm.pc])
    case opcode

    of opFetch, opStore:
      let index = vm.getOperand()
      if index notin 0..vm.data.high:
        raise newException(RuntimeError, &"wrong memory index (pc = {vm.pc}).")
      if opcode == opFetch:
        vm.stack.add(vm.data[index])
      else:
        vm.checkStackLength(1)
        vm.data[index] = vm.stack.pop()
      inc vm.pc, 4

    of opPush:
      let value = vm.getOperand()
      vm.stack.add(value)
      inc vm.pc, 4

    of opJmp:
      let offset = vm.getOperand()
      inc vm.pc, offset

    of opJz:
      let offset = vm.getOperand()
      vm.checkStackLength(1)
      let value = vm.stack.pop()
      inc vm.pc, if value == 0: offset else: 4

    of opAdd..opOr:
      # Two operands instructions.
      vm.checkStackLength(2)
      let op2 = vm.stack.pop()
      let op1 = vm.stack.pop()
      case range[opAdd..opOr](opcode)
      of opAdd:
        vm.stack.add(op1 + op2)
      of opSub:
        vm.stack.add(op1 - op2)
      of opMul:
        vm.stack.add(op1 * op2)
      of opDiv:
        vm.stack.add(op1 div op2)
      of opMod:
        vm.stack.add(op1 mod op2)
      of opLt:
        vm.stack.add(Value(op1 < op2))
      of opgt:
        vm.stack.add(Value(op1 > op2))
      of opLe:
        vm.stack.add(Value(op1 <= op2))
      of opGe:
        vm.stack.add(Value(op1 >= op2))
      of opEq:
        vm.stack.add(Value(op1 == op2))
      of opNe:
        vm.stack.add(Value(op1 != op2))
      of opAnd:
        vm.stack.add(op1 and op2)
      of opOr:
        vm.stack.add(op1 or op2)

    of opNeg..opPrts:
      # One operand instructions.
      vm.checkStackLength(1)
      let op = vm.stack.pop()
      case range[opNeg..opPrts](opcode)
      of opNeg:
        vm.stack.add(-op)
      of opNot:
        vm.stack.add(not op)
      of opPrtc:
        stdout.write(chr(op))
      of opPrti:
        stdout.write(op)
      of opPrts:
        if op notin 0..vm.strings.high:
          raise newException(RuntimeError, &"wrong string index (pc = {vm.pc}).")
        stdout.write(vm.strings[op])

    of opHalt:
      break

    of opInvalid:
      discard   # Not possible.

    inc vm.pc


####################################################################################################
# Loading assembly file.

proc parseHeader(line: string): tuple[dataSize, stringCount: int] =
  ## Parse the header.

  if not line.scanf("Datasize: $s$i $sStrings: $i", result.dataSize, result.stringCount):
    raise newException(LoadingError, "Wrong header in code.")

#---------------------------------------------------------------------------------------------------

import re

proc parseString(line: string; linenum: int): string =
  ## Parse a string.

  if not line.startsWith('"'):
    raise newException(LoadingError, "Line $1: incorrect string.".format(linenum))
  # Can't use "unescape" as it is confused by "\\n" and "\n".
  result = line.replacef(re"([^\\])(\\n)", "$1\n").replace(r"\\", r"\").replace("\"", "")

#---------------------------------------------------------------------------------------------------

proc parseValue(line: string; linenum: int; pos: var int; msg: string): int32 =
  ## Parse an int32 value.

  var value: int

  pos += line.skipWhitespace(pos)
  let parsed = line.parseInt(value, pos)
  if parsed == 0:
    raise newException(LoadingError, "Line $1: ".format(linenum) & msg)
  pos += parsed
  result = int32(value)

#---------------------------------------------------------------------------------------------------

proc parseOpcode(line: string; linenum: int; pos: var int): OpCode =
  ## Parse an opcode.

  var opstring: string

  pos += line.skipWhitespace(pos)
  let parsed = line.parseIdent(opstring, pos)
  if parsed == 0:
    raise newException(LoadingError, "Line $1: opcode expected".format(linenum))
  pos += parsed

  result = parseEnum[OpCode](opstring, opInvalid)
  if result == opInvalid:
    raise newException(LoadingError, "Line $1: invalid opcode encountered".format(linenum))

#---------------------------------------------------------------------------------------------------

proc parseMemoryIndex(line: string; linenum: int; pos: var int): int32 =
  ## Parse a memory index (int32 value between brackets).

  var memIndex: int

  pos += line.skipWhitespace(pos)
  let str = line.captureBetween('[', ']', pos)
  if str.parseInt(memIndex) == 0 or memIndex < 0:
    raise newException(LoadingError, "Line $1: invalid memory index".format(lineNum))
  pos += str.len + 2
  result = int32(memIndex)

#---------------------------------------------------------------------------------------------------

proc parseOffset(line: string; linenum: int; pos: var int): int32 =
  ## Parse an offset (int32 value between parentheses).

  var offset: int

  pos += line.skipWhitespace(pos)
  let str = line.captureBetween('(', ')', pos)
  if str.parseInt(offset) == 0:
    raise newException(LoadingError, "Line $1: invalid offset".format(linenum))
  pos += str.len + 2
  result = int32(offset)

#---------------------------------------------------------------------------------------------------

proc load(vm: var VM; code: string) =
  ## Load an assembly code into VM memory.

  # Analyze header.
  let lines = code.splitlines()
  let (dataSize, stringCount) = parseHeader(lines[0])
  vm.data.setLen(dataSize)
  vm.strings.setLen(stringCount)

  # Load strings.
  for idx in 1..stringCount:
    vm.strings[idx - 1] = lines[idx].parseString(idx + 1)

  # Load code.
  var pc: Address = 0
  for idx in (stringCount + 1)..lines.high:
    var pos = 0
    let line = lines[idx]
    if line.len == 0: continue

    # Process address.
    let address = line.parseValue(idx + 1, pos, "address expected")
    if address != pc:
      raise newException(LoadingError, "Line $1: wrong address".format(idx + 1))

    # Process opcode.
    let opcode = line.parseOpcode(idx + 1, pos)
    vm.memory.add(byte(opcode))

    # Process operand.
    case opcode

    of opFetch, opStore:
      # Find memory index.
      let memIndex = line.parseMemoryIndex(idx + 1, pos)
      vm.memory.add(cast[BytesValue](Value(memIndex)))
      inc pc, 5

    of opJmp, opJz:
      # Find offset.
      let offset = line.parseOffset(idx + 1, pos)
      vm.memory.add(cast[BytesValue](Value(offset)))
      # Find and check branch address.
      let branchAddress = line.parseValue(idx + 1, pos, "branch address expected")
      if branchAddress != pc + offset + 1:
        raise newException(LoadingError, "Line $1: wrong branch address".format(idx + 1))
      inc pc, 5

    of opPush:
      # Find value.
      let value = line.parseValue(idx + 1, pos, "value expected")
      vm.memory.add(cast[BytesValue](Value(value)))
      inc pc, 5

    else:
      inc pc

#———————————————————————————————————————————————————————————————————————————————————————————————————

let code = if paramCount() == 0: stdin.readAll() else: paramStr(1).readFile()
var vm: VM

vm.load(code)
vm.run()

All tests passed.

ObjectIcon

# -*- ObjectIcon -*-
#
# The Rosetta Code virtual machine in Object Icon.
#
# See https://rosettacode.org/wiki/Compiler/virtual_machine_interpreter
#

import io

procedure main(args)
  local f_inp, f_out
  local vm

  if 3 <= *args then {
    write("Usage: ", &progname, " [INPUT_FILE [OUTPUT_FILE]]")
    exit(1)
  }

  if 1 <= *args then {
    f_inp := FileStream(args[1], FileOpt.RDONLY) | stop (&why)
  } else {
    f_inp := FileStream.stdin
  }
  f_inp := BufferStream(f_inp)

  if 2 <= *args then {
    f_out := FileStream(args[2], ior (FileOpt.WRONLY,
                                      FileOpt.TRUNC, 
                                      FileOpt.CREAT)) | stop (&why)
  } else {
    f_out := FileStream.stdout
  }

  vm := VirtualMachine()
  vm.read_assembly_code(f_inp)
  vm.run(f_out)
end

procedure int2bytes (n)
  local bytes

  # The VM is little-endian.

  bytes := "****"
  bytes[1] := char (iand(n, 16rFF))
  bytes[2] := char(iand(ishift(n, -8), 16rFF))
  bytes[3] := char(iand(ishift(n, -16), 16rFF))
  bytes[4] := char(iand(ishift(n, -24), 16rFF))
  return bytes
end

procedure bytes2int(bytes, i)
  local n0, n1, n2, n3, n

  # The VM is little-endian.

  n0 := ord(bytes[i])
  n1 := ishift(ord(bytes[i + 1]), 8)
  n2 := ishift(ord(bytes[i + 2]), 16)
  n3 := ishift(ord(bytes[i + 3]), 24)
  n := ior (n0, ior (n1, ior (n2, n3)))

  # Do not forget to extend the sign bit.
  return (if n3 <= 16r7F then n else ior(n, icom(16rFFFFFFFF)))
end

class OpcodeCollection()

  public static const opcode_names
  public static const opcode_values

  public static const op_halt
  public static const op_add
  public static const op_sub
  public static const op_mul
  public static const op_div
  public static const op_mod
  public static const op_lt
  public static const op_gt
  public static const op_le
  public static const op_ge
  public static const op_eq
  public static const op_ne
  public static const op_and
  public static const op_or
  public static const op_neg
  public static const op_not
  public static const op_prtc
  public static const op_prti
  public static const op_prts
  public static const op_fetch
  public static const op_store
  public static const op_push
  public static const op_jmp
  public static const op_jz

  private static init()
    local i

    opcode_names :=
        ["halt", "add", "sub", "mul", "div",
         "mod", "lt", "gt", "le", "ge",
         "eq", "ne", "and", "or", "neg",
         "not", "prtc", "prti", "prts", "fetch",
         "store", "push", "jmp", "jz"]

    opcode_values := table()
    every i := 1 to *opcode_names do
      opcode_values[opcode_names[i]] := char(i)

    op_halt := opcode_values["halt"]
    op_add := opcode_values["add"]
    op_sub := opcode_values["sub"]
    op_mul := opcode_values["mul"]
    op_div := opcode_values["div"]
    op_mod := opcode_values["mod"]
    op_lt := opcode_values["lt"]
    op_gt := opcode_values["gt"]
    op_le := opcode_values["le"]
    op_ge := opcode_values["ge"]
    op_eq := opcode_values["eq"]
    op_ne := opcode_values["ne"]
    op_and := opcode_values["and"]
    op_or := opcode_values["or"]
    op_neg := opcode_values["neg"]
    op_not := opcode_values["not"]
    op_prtc := opcode_values["prtc"]
    op_prti := opcode_values["prti"]
    op_prts := opcode_values["prts"]
    op_fetch := opcode_values["fetch"]
    op_store := opcode_values["store"]
    op_push := opcode_values["push"]
    op_jmp := opcode_values["jmp"]
    op_jz := opcode_values["jz"]

    return
  end

end

class VirtualMachine(OpcodeCollection)

  public code
  public global_data
  public strings
  public stack
  public pc

  private static const whitespace_chars

  private static init()
    whitespace_chars := ' \t\n\r\f\v'
    return
  end

  public read_assembly_code(f)
    local data_size, number_of_strings
    local line, ch
    local i
    local address
    local opcode

    # Read the header line.
    line := f.read() | bad_vm()
    line ? {
      tab(many(whitespace_chars))
      tab(match("Datasize")) | bad_vm()
      tab(many(whitespace_chars))
      tab(any(':')) | bad_vm()
      tab(many(whitespace_chars))
      data_size :=
        integer(tab(many(&digits))) | bad_vm()
      tab(many(whitespace_chars))
      tab(match("Strings")) | bad_vm()
      tab(many(whitespace_chars))
      tab(any(':')) | bad_vm()
      tab(many(whitespace_chars))
      number_of_strings :=
        integer(tab(many(&digits))) | bad_vm()
    }

    # Read the strings.
    strings := list(number_of_strings)
    every i := 1 to number_of_strings do {
      strings[i] := ""
      line := f.read() | bad_vm()
      line ? {
        tab(many(whitespace_chars))
        tab(any('"')) | bad_vm()
        while ch := tab(any(~'"')) do {
          if ch == '\\' then {
            ch := tab(any('n\\')) | bad_vm()
            strings[i] ||:=
              (if (ch == "n") then "\n" else "\\")
          } else {
            strings[i] ||:= ch
          }
        }
      }
    }

    # Read the code.
    code := ""
    while line := f.read() do {
      line ? {
        tab(many(whitespace_chars))
        address := integer(tab(many(&digits))) | bad_vm()
        tab(many(whitespace_chars))
        opcode := tab(many(~whitespace_chars)) | bad_vm()
        code ||:= opcode_values[opcode]
        case opcode of {
          "push": {
            tab(many(whitespace_chars))
            code ||:=
                int2bytes(integer(tab(many(&digits)))) |
                int2bytes(integer(tab(any('-')) ||
                                  tab(many(&digits)))) |
                bad_vm()
          }
          "fetch" | "store": {
            tab(many(whitespace_chars))
            tab(any('[')) | bad_vm()
            tab(many(whitespace_chars))
            code ||:=
              int2bytes(integer(tab(many(&digits)))) |
              bad_vm()
            tab(many(whitespace_chars))
            tab(any(']')) | bad_vm()
          }
          "jmp" | "jz": {
            tab(many(whitespace_chars))
            tab(any('(')) | bad_vm()
            tab(many(whitespace_chars))
            code ||:=
              int2bytes(integer(tab(many(&digits)))) |
              int2bytes(integer(tab(any('-')) ||
                                tab(many(&digits)))) |
              bad_vm()
            tab(many(whitespace_chars))
            tab(any(')')) | bad_vm()
            tab(many(whitespace_chars))
            tab(many(&digits)) | bad_vm()
          }
          default: {
            # Do nothing
          }
        }
      }
    }

    # Create a global data area.
    global_data := list(data_size, &null)

    initialize()

    return
  end

  public run(f_out)
    initialize()
    continue(f_out)
    return
  end

  public continue(f_out)
    while code[pc] ~== op_halt do
      step(f_out)
  end

  public step(f_out)
    local opcode

    opcode := code[pc]
    pc +:= 1
    case opcode of {
      op_add:   binop("+")
      op_sub:   binop("-")
      op_mul:   binop("*")
      op_div:   binop("/")
      op_mod:   binop("%")
      op_lt:    comparison("<")
      op_gt:    comparison(">")
      op_le:    comparison("<=")
      op_ge:    comparison(">=")
      op_eq:    comparison("=")
      op_ne:    comparison("~=")
      op_and:   logical_and()
      op_or:    logical_or()
      op_neg:   negate()
      op_not:   logical_not()
      op_prtc:  printc(f_out)
      op_prti:  printi(f_out)
      op_prts:  prints(f_out)
      op_fetch: fetch_global()
      op_store: store_global()
      op_push:  push_argument()
      op_jmp:   jump()
      op_jz:    jump_if_zero()
      default:  bad_opcode()
    }
  end

  private negate()
    stack[1] := -stack[1]
    return
  end

  private binop(func)
    stack[2] := func(stack[2], stack[1])
    pop(stack)
    return
  end

  private comparison(func)
    stack[2] := (if func(stack[2], stack[1]) then 1 else 0)
    pop(stack)
    return
  end

  private logical_and()
    stack[2] := (if stack[2] ~= 0 & stack[1] ~= 0 then 1 else 0)
    pop(stack)
    return
  end

  private logical_or()
    stack[2] := (if stack[2] ~= 0 | stack[1] ~= 0 then 1 else 0)
    pop(stack)
    return
  end

  private logical_not()
    stack[1] := (if stack[1] ~= 0 then 0 else 1)
    return
  end

  private printc(f_out)
    /f_out := FileStream.stdout
    f_out.writes(char(pop(stack)))
    return
  end

  private printi(f_out)
    /f_out := FileStream.stdout
    f_out.writes(pop(stack))
    return
  end

  private prints(f_out)
    /f_out := FileStream.stdout
    f_out.writes(strings[pop(stack) + 1])
    return
  end

  private fetch_global()
    push(stack, global_data[get_argument() + 1])
    pc +:= 4
    return
  end

  private store_global()
    global_data[get_argument() + 1] := pop(stack)
    pc +:= 4
    return
  end

  private push_argument()
    push(stack, get_argument())
    pc +:= 4
    return
  end

  private jump()
    pc +:= get_argument()
    return
  end

  private jump_if_zero()
    if pop(stack) = 0 then
      pc +:= get_argument()
    else
      pc +:= 4
    return
  end

  private get_argument()
    return bytes2int(code, pc)
  end

  public initialize()
    # The program counter starts at 1, for convenient indexing into
    # the code[] array. Icon indexing starts at 1 (for a *very* good
    # reason, but that’s a topic for another day).
    pc := 1
    stack := []
    return
  end

  private bad_vm()
    write(FileStream.stderr, "Bad VM.")
    exit(1)
  end

  private bad_opcode()
    write(FileStream.stderr, "Bad opcode.")
    exit(1)
  end
end
Output:

$ oit vm-oi.icn && ./vm-oi compiler-tests/count.vm

count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

Perl

Tested with perl v5.26.1

#!/usr/bin/perl

# http://www.rosettacode.org/wiki/Compiler/virtual_machine_interpreter
use strict; # vm.pl - run rosetta code
use warnings;
use integer;

my ($binary, $pc, @stack, @data) = ('', 0);

<> =~ /Strings: (\d+)/ or die "bad header";
my @strings = map <> =~ tr/\n""//dr =~ s/\\(.)/$1 eq 'n' ? "\n" : $1/ger, 1..$1;

sub value { unpack 'l', substr $binary, ($pc += 4) - 4, 4 }

my @ops = (
  [ halt  => sub { exit } ],
  [ add   => sub { $stack[-2] += pop @stack } ],
  [ sub   => sub { $stack[-2] -= pop @stack } ],
  [ mul   => sub { $stack[-2] *= pop @stack } ],
  [ div   => sub { $stack[-2] /= pop @stack } ],
  [ mod   => sub { $stack[-2] %= pop @stack } ],
  [ not   => sub { $stack[-1] = $stack[-1] ? 0 : 1 } ],
  [ neg   => sub { $stack[-1] = - $stack[-1] } ],
  [ and   => sub { $stack[-2] &&= $stack[-1]; pop @stack } ],
  [ or    => sub { $stack[-2] ||= $stack[-1]; pop @stack } ],
  [ lt    => sub { $stack[-1] = $stack[-2] <  pop @stack ? 1 : 0 } ],
  [ gt    => sub { $stack[-1] = $stack[-2] >  pop @stack ? 1 : 0 } ],
  [ le    => sub { $stack[-1] = $stack[-2] <= pop @stack ? 1 : 0 } ],
  [ ge    => sub { $stack[-1] = $stack[-2] >= pop @stack ? 1 : 0 } ],
  [ ne    => sub { $stack[-1] = $stack[-2] != pop @stack ? 1 : 0 } ],
  [ eq    => sub { $stack[-1] = $stack[-2] == pop @stack ? 1 : 0 } ],
  [ prts  => sub { print $strings[pop @stack] } ],
  [ prti  => sub { print pop @stack } ],
  [ prtc  => sub { print chr pop @stack } ],
  [ store => sub { $data[value()] = pop @stack } ],
  [ fetch => sub { push @stack, $data[value()] // 0 } ],
  [ push  => sub { push @stack, value() } ],
  [ jmp   => sub { $pc += value() - 4 } ],
  [ jz    => sub { $pc += pop @stack ? 4 : value() - 4 } ],
  );
my %op2n = map { $ops[$_][0], $_ } 0..$#ops;            # map name to op number

while(<>)
  {
  /^ *\d+ +(\w+)/ or die "bad line $_";                 # format error
  $binary .= chr( $op2n{$1} // die "$1 not defined" ) . # op code
    (/\((-?\d+)\)|(\d+)]?$/ and pack 'l', $+);          # 4 byte value
  }

$ops[vec($binary, $pc++, 8)][1]->() while 1;            # run it

Passes all tests.

Phix

Reusing cgen.e from the Code Generator task

--
-- demo\rosetta\Compiler\vm.exw
-- ============================
--
--  Since we have generated executable machine code, the virtual machine, such as it is, is just 
--  the higher level implementations of printc/i/s, see setbuiltins() in cgen.e
--  Otherwise the only difference between this and cgen.exw is call(code_mem) instead of decode().
--
--  A quick test (calculating fib(44) 10^6 times) suggests ~500 times faster than interp.exw - 
--  which is to be expected given that a single add instruction (1 clock) here is implemented as 
--  at least three (and quite possibly five!) resursive calls to interp() in the other.

format PE32
--format ELF32
--  Note: cgen generates 32-bit machine code, which cannot be executed directly from a 64-bit interpreter.
--        You can however, via the magic of either the above format directives, use a 64-bit version of
--        Phix to compile this (just add a -c command line option) to a 32-bit executable, which can.
--        It would not be particularly difficult to emit 32 or 64 bit code, but some source code files 
--        would, fairly obviously, then be very nearly twice as long, and a fair bit harder to read.

without js -- (machine code!)
include cgen.e

procedure main(sequence cl)
    open_files(cl)
    toks = lex()
    object t = parse()
    code_gen(t)
    fixup()
    if machine_bits()=32 then
        -- ^ as per note above
        call(code_mem)
    end if
    free({var_mem,code_mem})
    close_files()
end procedure

--main(command_line())
main({0,0,"count.c"})
Output:
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

Prolog

Works with: GNU Prolog version 1.5.0


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% The Rosetta Code Virtual Machine, for GNU Prolog.
%%%
%%% The following code uses GNU Prolog's extensions for global
%%% variables.
%%%
%%% Usage: vm [INPUTFILE [OUTPUTFILE]]
%%% The notation "-" means to use standard input or standard output.
%%% Leaving out an argument is equivalent to specifying "-".
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

make_and_run_machine(Input, Output) :-
  make_machine(Input),
  run_machine(Output).

run_machine(Output) :-
  repeat,
  next_instruction(Opcode, Arg),
  (Opcode == ('halt')
  -> true
  ; (run_instruction(Output, Opcode, Arg),
     fail                       % Backtracks to the 'repeat'.
    )).

run_instruction(Output, Opcode, Arg) :-
  (
    (Opcode == ('add'),
     pop_value(Y),
     pop_value(X),
     is(Z, X + Y),
     push_value(Z))
  ; (Opcode == ('sub'),
     pop_value(Y),
     pop_value(X),
     is(Z, X - Y),
     push_value(Z))
  ; (Opcode == ('mul'),
     pop_value(Y),
     pop_value(X),
     is(Z, X * Y),
     push_value(Z))
  ; (Opcode == ('div'),
     pop_value(Y),
     pop_value(X),
     is(Z, X // Y),
     push_value(Z))
  ; (Opcode == ('mod'),
     pop_value(Y),
     pop_value(X),
     is(Z, X rem Y),
     push_value(Z))
  ; (Opcode == ('lt'),
     pop_value(Y),
     pop_value(X),
     (X < Y -> Z = 1; Z = 0),
     push_value(Z))
  ; (Opcode == ('le'),
     pop_value(Y),
     pop_value(X),
     (X =< Y -> Z = 1; Z = 0),
     push_value(Z))
  ; (Opcode == ('gt'),
     pop_value(Y),
     pop_value(X),
     (X > Y -> Z = 1; Z = 0),
     push_value(Z))
  ; (Opcode == ('ge'),
     pop_value(Y),
     pop_value(X),
     (X >= Y -> Z = 1; Z = 0),
     push_value(Z))
  ; (Opcode == ('eq'),
     pop_value(Y),
     pop_value(X),
     (X =:= Y -> Z = 1; Z = 0),
     push_value(Z))
  ; (Opcode == ('ne'),
     pop_value(Y),
     pop_value(X),
     (X =\= Y -> Z = 1; Z = 0),
     push_value(Z))
  ; (Opcode == ('and'),
     pop_value(Y),
     pop_value(X),
     ((X =\= 0, Y =\= 0) -> Z = 1; Z = 0),
     push_value(Z))
  ; (Opcode == ('or'),
     pop_value(Y),
     pop_value(X),
     ((X =\= 0; Y =\= 0) -> Z = 1; Z = 0),
     push_value(Z))
  ; (Opcode == ('neg'),
     pop_value(X),
     is(Z, -X),
     push_value(Z))
  ; (Opcode == ('not'),
     pop_value(X),
     (X =:= 0 -> Z = 1; Z = 0),
     push_value(Z))
  ; (Opcode == ('prtc'),
     pop_value(X),
     char_code(C, X),
     write(Output, C))
  ; (Opcode == ('prti'),
     pop_value(X),
     write(Output, X))
  ; (Opcode == ('prts'),
     pop_value(K),
     g_read(the_strings(K), S),
     write(Output, S))
  ; (Opcode == ('fetch'),
     g_read(the_data(Arg), X),
     push_value(X),
     skip_argument)
  ; (Opcode == ('store'),
     pop_value(X),
     g_assign(the_data(Arg), X),
     skip_argument)
  ; (Opcode == ('push'),
     push_value(Arg),
     skip_argument)
  ; (Opcode == ('jmp'),
     relative_jump(Arg))
  ; (Opcode == ('jz'),
     pop_value(X),
     (X =:= 0
     -> relative_jump(Arg)
     ;  skip_argument))
  ).

relative_jump(Offset) :-
  g_read(the_program_counter, PC),
  is(PC1, PC + Offset),
  g_assign(the_program_counter, PC1).

skip_argument :-
  g_read(the_program_counter, PC),
  is(PC1, PC + 4),
  g_assign(the_program_counter, PC1).

next_instruction(Opcode, Arg) :-
  g_read(the_program_counter, PC),
  is(PC1, PC + 1),
  g_assign(the_program_counter, PC1),
  g_read(the_code(PC), {Opcode, Arg}).

push_value(X) :-
  g_read(the_stack_pointer, SP),
  is(SP1, SP + 1),
  g_assign(the_stack_pointer, SP1),
  g_assign(the_stack(SP), X).

pop_value(X) :-
  g_read(the_stack_pointer, SP),
  is(SP1, SP - 1),
  g_assign(the_stack_pointer, SP1),
  g_read(the_stack(SP1), X).

make_machine(Input) :-
  get_and_parse_the_header(Input, Datasize, Strings_Count),
  (Strings_Count =:= 0
  -> true
  ;  get_and_parse_the_strings(Input, Strings_Count)),
  get_and_parse_the_instructions(Input),
  (Datasize =:= 0
  -> true
  ;  g_assign(the_data, g_array(Datasize))),
  g_assign(the_stack, g_array(2048)),
  g_assign(the_stack_pointer, 0),
  g_assign(the_program_counter, 0).

get_and_parse_the_header(Stream, Datasize, Strings_Count) :-
  get_line(Stream, Line, ('\n')),
  parse_header(Line, Datasize, Strings_Count).

get_and_parse_the_strings(Stream, Strings_Count) :-
  % Make 'the_strings' an array of the string literals.
  get_and_parse_the_strings(Stream, Strings_Count, Lst),
  g_assign(the_strings, g_array(Lst)).
get_and_parse_the_strings(Stream, I, Lst) :-
  % Note: this implementation is non-tail recursive.
  (I == 0
  -> Lst = []
  ;  (get_line(Stream, Line, ('\n')),
      parse_string_literal(Line, S),
      is(I1, I - 1),
      get_and_parse_the_strings(Stream, I1, Lst1),
      Lst = [S | Lst1])).

get_and_parse_the_instructions(Stream) :-
  get_and_parse_the_instructions(Stream, Lst),
  keysort(Lst, Lst1),
  last(Lst1, Addr_Max-_),
  is(Code_Size, Addr_Max + 5),
  g_assign(the_code, g_array(Code_Size, {('halt'), 0})),
  maplist(fill_instruction, Lst1).
get_and_parse_the_instructions(Stream, Lst) :-
  get_and_parse_the_instructions(Stream, [], Lst).
get_and_parse_the_instructions(Stream, Lst0, Lst) :-
  % This implementation is tail recursive. We consider the order of
  % the resulting list to be arbitrary.
  (get_line(Stream, Line, Terminal),
   drop_spaces(Line, S),
   (S = []
   -> (Terminal = end_of_file
      -> Lst = Lst0
      ;  get_and_parse_the_instructions(Stream, Lst0, Lst))
   ;  (parse_instruction(S, Address, Opcode, Arg),
       Instr = Address-{Opcode, Arg},
       (Terminal = end_of_file
       -> reverse([Instr | Lst0], Lst)
       ;  get_and_parse_the_instructions(Stream, [Instr | Lst0],
                                         Lst))))).

fill_instruction(Addr-Instr) :-
  g_assign(the_code(Addr), Instr).

parse_header(Line, Datasize, Strings_Count) :-
  drop_nondigits(Line, Lst1),
  split_digits(Lst1, Datasize_Digits, Rest1),
  drop_nondigits(Rest1, Lst2),
  split_digits(Lst2, Strings_Digits, _Rest2),
  number_chars(Datasize, Datasize_Digits),
  number_chars(Strings_Count, Strings_Digits).

parse_string_literal(Line, S) :-
  drop_spaces(Line, Lst1),
  Lst1 = ['"' | Lst2],
  rework_escape_sequences(Lst2, Lst3),
  atom_chars(S, Lst3).

rework_escape_sequences(Lst0, Lst) :-
  (Lst0 = [('"') | _]
  -> Lst = []
  ;  (Lst0 = [('\\'), ('n') | Tail1]
     -> (rework_escape_sequences(Tail1, Lst1),
         Lst = [('\n') | Lst1])
     ;  (Lst0 = [('\\'), ('\\') | Tail1]
        -> (rework_escape_sequences(Tail1, Lst1),
            Lst = [('\\') | Lst1])
        ;  (Lst0 = [C | Tail1],
            rework_escape_sequences(Tail1, Lst1),
            Lst = [C | Lst1])))).

parse_instruction(Line, Address, Opcode, Arg) :-
  drop_spaces(Line, Lst1),
  split_digits(Lst1, Address_Digits, Rest1),
  number_chars(Address, Address_Digits),
  drop_spaces(Rest1, Lst2),
  split_nonspaces(Lst2, Opcode_Chars, Rest2),
  atom_chars(Opcode, Opcode_Chars),
  drop_spaces(Rest2, Lst3),
  (Lst3 = []
  -> Arg = 0
  ;  (Lst3 = [C | Rest3],
      (is_digit(C)
      -> (split_digits(Lst3, Arg_Chars, _),
          number_chars(Arg, Arg_Chars))
      ; (C = ('(')
        -> (split_before_char((')'), Rest3, Arg_Chars, _),
            number_chars(Arg, Arg_Chars))
        ; (C = ('['),
           split_before_char((']'), Rest3, Arg_Chars, _),
           number_chars(Arg, Arg_Chars)))))).

is_space(C) :-
  (C = (' '); C = ('\t'); C = ('\n');
   C = ('\v'); C = ('\f'); C = ('\r')).

is_digit(C) :-
  (C = ('0'); C = ('1'); C = ('2'); C = ('3'); C = ('4');
   C = ('5'); C = ('6'); C = ('7'); C = ('8'); C = ('9')).

drop_spaces([], Lst) :-
  Lst = [].
drop_spaces([C | Tail], Lst) :-
  (is_space(C)
  -> drop_spaces(Tail, Lst)
  ;  Lst = [C | Tail]).

drop_nondigits([], Lst) :-
  Lst = [].
drop_nondigits([C | Tail], Lst) :-
  (is_digit(C)
  -> Lst = [C | Tail]
  ;  drop_nondigits(Tail, Lst)).

split_nonspaces([], Word, Rest) :-
  (Word = [], Rest = []).
split_nonspaces([C | Tail], Word, Rest) :-
  (is_space(C)
  -> (Word = [], Rest = [C | Tail])
  ;  (split_nonspaces(Tail, Word1, Rest),
      Word = [C | Word1])).

split_digits([], Digits, Rest) :-
  (Digits = [], Rest = []).
split_digits([C | Tail], Digits, Rest) :-
  (is_digit(C)
  -> (split_digits(Tail, Digits1, Rest),
      Digits = [C | Digits1])
  ;  (Digits = [], Rest = [C | Tail])).

split_before_char(_, [], Before, After) :-
  (Before = [], After = []).
split_before_char(C, [C1 | Rest], Before, After) :-
  (C = C1
  -> (Before = [], After = [C1 | Rest])
  ;  (split_before_char(C, Rest, Before1, After),
      Before = [C1 | Before1])).

get_line(Stream, Line, Terminal) :-
  % Reads a line of input as a list of characters. The character that
  % terminates the line is returned separately; it may be either '\n'
  % or end_of_file.
  get_line_chars(Stream, [], Line, Terminal).

get_line_chars(Stream, Chars0, Chars, Terminal) :-
  % Helper predicate for get_line.
  get_char(Stream, C),
  ((C = end_of_file; C = ('\n'))
  -> (reverse(Chars0, Chars), Terminal = C)
  ;  get_line_chars(Stream, [C | Chars0], Chars, Terminal)).

main(Args) :-
  (Args = []
  -> current_input(Input),
     current_output(Output),
     make_and_run_machine(Input, Output)
  ; (Args = [Inp_Name]
    -> (Inp_Name = ('-')
       -> main([])
       ;  (open(Inp_Name, 'read', Input),
           current_output(Output),
           make_and_run_machine(Input, Output),
           close(Input)))
    ; (Args = [Inp_Name, Out_Name | _],
       (Inp_Name = ('-')
       -> (Out_Name = ('-')
          -> main([])
          ;  (current_input(Input),
              open(Out_Name, 'write', Output),
              make_and_run_machine(Input, Output),
              close(Output)))
       ;  (Out_Name = ('-')
          -> main([Inp_Name])
          ;  (open(Inp_Name, 'read', Input),
              open(Out_Name, 'write', Output),
              make_and_run_machine(Input, Output),
              close(Input),
              close(Output))))))).

main :-
  argument_list(Args),
  main(Args).

:- initialization(main).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Instructions for GNU Emacs--
%%% local variables:
%%% mode: prolog
%%% prolog-indent-width: 2
%%% end:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


Output:
$ gplc --no-top-level --fast-math vm.pl && ./vm compiler-tests/count.vm
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

Python

Tested with Python 2.7 and 3.x

from __future__ import print_function
import sys, struct

FETCH, STORE, PUSH, ADD, SUB, MUL, DIV, MOD, LT, GT, LE, GE, EQ, NE, AND, OR, NEG, NOT, \
JMP, JZ, PRTC, PRTS, PRTI, HALT = range(24)

code_map = {
    "fetch": FETCH,
    "store": STORE,
    "push":  PUSH,
    "add":   ADD,
    "sub":   SUB,
    "mul":   MUL,
    "div":   DIV,
    "mod":   MOD,
    "lt":    LT,
    "gt":    GT,
    "le":    LE,
    "ge":    GE,
    "eq":    EQ,
    "ne":    NE,
    "and":   AND,
    "or":    OR,
    "not":   NOT,
    "neg":   NEG,
    "jmp":   JMP,
    "jz":    JZ,
    "prtc":  PRTC,
    "prts":  PRTS,
    "prti":  PRTI,
    "halt":  HALT
}

input_file  = None
code        = bytearray()
string_pool = []
word_size   = 4

#*** show error and exit
def error(msg):
    print("%s" % (msg))
    exit(1)

def int_to_bytes(val):
    return struct.pack("<i", val)

def bytes_to_int(bstr):
    return struct.unpack("<i", bstr)

#***
def emit_byte(x):
    code.append(x)

#***
def emit_word(x):
    s = int_to_bytes(x)
    for x in s:
        code.append(x)

#***
def run_vm(data_size):
    stack = [0 for i in range(data_size + 1)]
    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()
        # use C like division semantics
        elif op == DIV:   stack[-2] = int(float(stack[-2]) / stack[-1]); stack.pop()
        elif op == MOD:   stack[-2] = int(float(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():
                pc += word_size
            else:
                pc += bytes_to_int(code[pc:pc+word_size])[0]
        elif op == PRTC:  print("%c" % (stack[-1]), end=''); stack.pop()
        elif op == PRTS:  print("%s" % (string_pool[stack[-1]]), end=''); stack.pop()
        elif op == PRTI:  print("%d" % (stack[-1]), end=''); stack.pop()
        elif op == HALT:  break

def str_trans(srce):
    dest = ""
    i = 0
    while i < len(srce):
        if srce[i] == '\\' and i + 1 < len(srce):
            if srce[i + 1] == 'n':
                dest += '\n'
                i += 2
            elif srce[i + 1] == '\\':
                dest += '\\'
                i += 2
        else:
            dest += srce[i]
            i += 1

    return dest

#***
def load_code():
    global string_pool

    line = input_file.readline()
    if len(line) == 0:
        error("empty line")

    line_list = line.split()
    data_size = int(line_list[1])
    n_strings = int(line_list[3])

    for i in range(n_strings):
        string_pool.append(str_trans(input_file.readline().strip('"\n')))

    while True:
        line = input_file.readline()
        if len(line) == 0:
            break
        line_list = line.split()
        offset = int(line_list[0])
        instr  = line_list[1]
        opcode = code_map.get(instr)
        if opcode == None:
            error("Unknown instruction %s at %d" % (instr, offset))
        emit_byte(opcode)
        if opcode in [JMP, JZ]:
            p = int(line_list[3])
            emit_word(p - (offset + 1))
        elif opcode == PUSH:
            value = int(line_list[2])
            emit_word(value)
        elif opcode in [FETCH, STORE]:
            value = int(line_list[2].strip('[]'))
            emit_word(value)

    return data_size

#*** main driver
input_file = sys.stdin
if len(sys.argv) > 1:
    try:
        input_file = open(sys.argv[1], "r", 4096)
    except IOError as e:
        error(0, 0, "Can't open %s" % sys.argv[1])

data_size = load_code()
run_vm(data_size)

Racket

Translation of: Common Lisp

This example is for Typed Racket and is practically a word for word translation of the Common Lisp. This close similarity was done on purpose, to ease comparison of the two languages.

(The Common Lisp performs much better, if compiled with SBCL, although neither program is written for speed, and one expects SBCL to outperform most other compilers.)


#lang typed/racket
;;;
;;; The Rosetta Code Virtual Machine, in Typed Racket.
;;;
;;; Migrated from the Common Lisp.
;;;

;;; Yes, I could compute how much memory is needed, or I could assume
;;; that the instructions are in address order. However, for *this*
;;; implementation I am going to use a large fixed-size memory and use
;;; the address fields of instructions to place the instructions.
(: executable-memory-size Positive-Fixnum)
(define executable-memory-size 65536)

;;; Similarly, I am going to have fixed size data and stack memory.
(: data-memory-size Positive-Fixnum)
(define data-memory-size 2048)
(: stack-memory-size Positive-Fixnum)
(define stack-memory-size 2048)

;;; And so I am going to have specialized types for the different
;;; kinds of memory the platform contains. Also for its "word" and
;;; register types.
(define-type Word Nonnegative-Fixnum)
(define-type Register (Boxof Word))
(define-type Executable-Memory (Mutable-Vectorof Byte))
(define-type Data-Memory (Mutable-Vectorof Word))
(define-type Stack-Memory (Mutable-Vectorof Word))

(define re-blank-line #px"^\\s*$")
(define re-parse-instr-1 #px"^\\s*(\\d+)\\s*(.*\\S)")
(define re-parse-instr-2 #px"(?i:^(\\S+)\\s*(.*))")
(define re-parse-instr-3 #px"^[[(]?([0-9-]+)")
(define re-header
  #px"(?i:^\\s*Datasize\\s*:\\s*(\\d+)\\s*Strings\\s*:\\s*(\\d+))")
(define re-leading-spaces #px"^\\s*")

(define opcode-names
  '("halt"
    "add"
    "sub"
    "mul"
    "div"
    "mod"
    "lt"
    "gt"
    "le"
    "ge"
    "eq"
    "ne"
    "and"
    "or"
    "neg"
    "not"
    "prtc"
    "prti"
    "prts"
    "fetch"
    "store"
    "push"
    "jmp"
    "jz"))

(: blank-line? (String -> Boolean))
(define (blank-line? s)
  (not (not (regexp-match re-blank-line s))))

(: opcode-from-name (String -> Byte))
(define (opcode-from-name s)
  (let ((i (index-of opcode-names s)))
    (assert i)
    (cast i Byte)))

(: create-executable-memory (-> Executable-Memory))
(define (create-executable-memory)
  (make-vector executable-memory-size (opcode-from-name "halt")))

(: create-data-memory (-> Data-Memory))
(define (create-data-memory)
  (make-vector data-memory-size 0))

(: create-stack-memory (-> Stack-Memory))
(define (create-stack-memory)
  (make-vector stack-memory-size 0))

(: create-register (-> Register))
(define (create-register)
  (box 0))

(struct machine
  ((sp : Register)   ; Stack pointer.
   (ip : Register)   ; Instruction pointer (that is, program counter).
   (code : Executable-Memory)
   (data : Data-Memory)
   (stack : Stack-Memory)
   (strings : (Immutable-Vectorof String))
   (output : Output-Port))
  #:type-name Machine
  #:constructor-name %make-machine)

(: make-machine ((Immutable-Vectorof String) Output-Port -> Machine))
(define (make-machine strings outf)
  (%make-machine (create-register)
                 (create-register)
                 (create-executable-memory)
                 (create-data-memory)
                 (create-stack-memory)
                 strings
                 outf))

(define-type Instruction-Data (List Word Byte (U False Word)))

(: insert-instruction (Executable-Memory Instruction-Data -> Void))
(define (insert-instruction memory instr)
  (void
   (match instr
     ((list address opcode arg)
      (let ((instr-size (if arg 5 1)))
        (unless (<= (+ address instr-size) executable-memory-size)
          (raise-user-error
           "the VM's executable memory size is exceeded"))
        (vector-set! memory address opcode)
        (when arg
          ;; Big-endian order.
          (vector-set! memory (+ address 1)
                       (bitwise-and (arithmetic-shift arg -24) #xFF))
          (vector-set! memory (+ address 2)
                       (bitwise-and (arithmetic-shift arg -16) #xFF))
          (vector-set! memory (+ address 3)
                       (bitwise-and (arithmetic-shift arg -8) #xFF))
          (vector-set! memory (+ address 4)
                       (bitwise-and arg #xFF))))))))

(: load-executable-memory (Executable-Memory
                           (Listof Instruction-Data) ->
                           Void))
(define (load-executable-memory memory instr-lst)
  (let loop ((p instr-lst))
    (if (null? p)
        (void)
        (let ((instr (car p)))
          (insert-instruction memory (car p))
          (loop (cdr p))))))

(: number->word (Number -> Word))
(define (number->word n)
  (cast (bitwise-and (cast n Integer) #xFFFFFFFF) Word))

(: string->word (String -> Word))
(define (string->word s)
  (let ((n (string->number s)))
    (assert (number? n))
    (number->word n)))

(: parse-instruction (String -> (U False Instruction-Data)))
(define (parse-instruction s)
  (and (not (blank-line? s))
       (let* ((strings (cast (regexp-match re-parse-instr-1 s)
                             (Listof String)))
              (address (cast (string->number (second strings))
                             Word))
              (split (cast (regexp-match re-parse-instr-2
                                         (third strings))
                           (Listof String)))
              (opcode-name (string-downcase (second split)))
              (opcode (opcode-from-name opcode-name))
              (arguments (third split))
              (has-arg? (match opcode-name
                          ((or "fetch" "store" "push" "jmp" "jz") #t)
                          (_ #f))))
         (if has-arg?
             (let* ((argstr-lst
                     (cast (regexp-match re-parse-instr-3 arguments)
                           (Listof String)))
                    (argstr (second argstr-lst))
                    (arg (string->word argstr)))
               `(,address ,opcode ,arg))
             `(,address ,opcode #f)))))

(: read-instructions (Input-Port -> (Listof Instruction-Data)))
(define (read-instructions inpf)
  (let loop ((line (read-line inpf))
             (lst (cast '() (Listof Instruction-Data))))
    (if (eof-object? line)
        (reverse lst)
        (let ((instr (parse-instruction line)))
          (loop (read-line inpf)
                (if instr
                    (cons instr lst)
                    lst))))))

(: read-datasize-and-strings-count (Input-Port -> (Values Word Word)))
(define (read-datasize-and-strings-count inpf)
  (let ((line (read-line inpf)))
    (unless (string? line)
      (raise-user-error "empty input"))
    ;; This is a permissive implementation.
    (let* ((strings (cast (regexp-match re-header line)
                          (Listof String)))
           (datasize (string->word (second strings)))
           (strings-count (string->word (third strings))))
      (values datasize strings-count))))

(: parse-string-literal (String -> String))
(define (parse-string-literal s)
  ;; This is a permissive implementation, but only in that it skips
  ;; any leading space. It does not check carefully for outright
  ;; mistakes.
  (let* ((s (regexp-replace re-leading-spaces s ""))
         (quote-mark (string-ref s 0)))
    (let loop ((i 1)
               (lst (cast '() (Listof Char))))
      (if (char=? (string-ref s i) quote-mark)
          (list->string (reverse lst))
          (let ((c (string-ref s i)))
            (if (char=? c #\\)
                (let ((c0 (match (string-ref s (+ i 1))
                            (#\n #\newline)
                            (c1 c1))))
                  (loop (+ i 2) (cons c0 lst)))
                (loop (+ i 1) (cons c lst))))))))

(: read-string-literals (Input-Port Word -> (Listof String)))
(define (read-string-literals inpf strings-count)
  (for/list ((i (in-range strings-count)))
    (let ((line (read-line inpf)))
      (begin (assert (string? line))
             (parse-string-literal line)))))

(: open-inpf (String -> Input-Port))
(define (open-inpf inpf-filename)
  (if (string=? inpf-filename "-")
      (current-input-port)
      (open-input-file inpf-filename)))

(: open-outf (String -> Output-Port))
(define (open-outf outf-filename)
  (if (string=? outf-filename "-")
      (current-output-port)
      (open-output-file outf-filename #:exists 'truncate)))

(: word-signbit? (Word -> Boolean))
(define (word-signbit? x)
  ;; True if and only if the sign bit is set.
  (not (zero? (bitwise-and x #x80000000))))

(: word-add (Word Word -> Word))
(define (word-add x y)
  ;; Addition with overflow freely allowed.
  (cast (bitwise-and (+ x y) #xFFFFFFFF) Word))

(: word-neg (Word -> Word))
(define (word-neg x)
  ;; The two's complement.
  (word-add (cast (bitwise-xor x #xFFFFFFFF) Word) 1))

(: word-sub (Word Word -> Word))
(define (word-sub x y)
  ;; Subtraction with overflow freely allowed.
  (word-add x (word-neg y)))

(: word-mul (Word Word -> Word))
(define (word-mul x y)
  ;; Signed multiplication.
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-xy (cast (bitwise-and (* abs-x abs-y) #xFFFFFFFF)
                           Word)))
        (if x<0
            (if y<0 abs-xy (word-neg abs-xy))
            (if y<0 (word-neg abs-xy) abs-xy))))))

(: word-div (Word Word -> Word))
(define (word-div x y)
  ;; The quotient after signed integer division with truncation
  ;; towards zero.
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-x/y (cast (bitwise-and (quotient abs-x abs-y)
                                         #xFFFFFFFF)
                            Word)))
        (if x<0
            (if y<0 abs-x/y (word-neg abs-x/y))
            (if y<0 (word-neg abs-x/y) abs-x/y))))))

(: word-mod (Word Word -> Word))
(define (word-mod x y)
  ;; The remainder after signed integer division with truncation
  ;; towards zero.
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-x/y (cast (bitwise-and (remainder abs-x abs-y)
                                         #xFFFFFFFF)
                            Word)))
        (if x<0
            (if y<0 abs-x/y (word-neg abs-x/y))
            (if y<0 (word-neg abs-x/y) abs-x/y))))))

(: b2i (Boolean -> (U Zero One)))
(define (b2i b)
  (if b 1 0))

(: word-lt (Word Word -> Word))
(define (word-lt x y)
  ;; Signed comparison: is x less than y?
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (b2i (if x<0
             (if y<0 (< x y) #t)
             (if y<0 #f (< x y))))))

(: word-le (Word Word -> Word))
(define (word-le x y)
  ;; Signed comparison: is x less than or equal to y?
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (b2i (if x<0
             (if y<0 (<= x y) #t)
             (if y<0 #f (<= x y))))))

(: word-gt (Word Word -> Word))
(define (word-gt x y)
  ;; Signed comparison: is x greater than y?
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (b2i (if x<0
             (if y<0 (> x y) #f)
             (if y<0 #t (> x y))))))

(: word-ge (Word Word -> Word))
(define (word-ge x y)
  ;; Signed comparison: is x greater than or equal to y?
  (let ((x<0 (word-signbit? x))
        (y<0 (word-signbit? y)))
    (b2i (if x<0
             (if y<0 (>= x y) #f)
             (if y<0 #t (>= x y))))))

(: word-eq (Word Word -> Word))
(define (word-eq x y)
  ;; Is x equal to y?
  (b2i (= x y)))

(: word-ne (Word Word -> Word))
(define (word-ne x y)
  ;; Is x not equal to y?
  (b2i (not (= x y))))

(: word-cmp (Word -> Word))
(define (word-cmp x)
  ;; The logical complement.
  (b2i (zero? x)))

(: word-and (Word Word -> Word))
(define (word-and x y)
  ;; The logical conjunction.
  (b2i (and (not (zero? x)) (not (zero? y)))))

(: word-or (Word Word -> Word))
(define (word-or x y)
  ;; The logical disjunction.
  (b2i (or (not (zero? x)) (not (zero? y)))))

(: unop (Stack-Memory Register (Word -> Word) -> Void))
(define (unop stack sp operation)
  ;; Perform a unary operation on the stack.
  (let ((i (unbox sp)))
    (unless (<= 1 i)
      (raise-user-error "stack underflow"))
    (let ((x (vector-ref stack (- i 1))))
      ;; Note how, in contrast to Common Lisp, "operation" is not in a
      ;; namespace separate from that of "ordinary" values, such as
      ;; numbers and strings. (Which way is "better" is a matter of
      ;; taste, and probably depends mostly on what "functional"
      ;; language one learnt first. Mine was Caml Light, so I prefer
      ;; the Scheme way. :) )
      (vector-set! stack (- i 1) (operation x)))))

(: binop (Stack-Memory Register (Word Word -> Word) -> Void))
(define (binop stack sp operation)
  ;; Perform a binary operation on the stack.
  (let ((i (unbox sp)))
    (unless (<= 2 i)
      (raise-user-error "stack underflow"))
    (let ((x (vector-ref stack (- i 2)))
          (y (vector-ref stack (- i 1))))
      (vector-set! stack (- i 2) (operation x y)))
    (set-box! sp (cast (- i 1) Word))))

(: jri (Executable-Memory Register -> Void))
(define (jri code ip)
  ;; Jump relative immediate.
  (let ((j (unbox ip)))
    (unless (<= (+ j 4) executable-memory-size)
      (raise-user-error "address past end of executable memory"))
    ;; Big-endian order.
    (let* ((offset (vector-ref code (+ j 3)))
           (offset (bitwise-ior
                    (arithmetic-shift (vector-ref code (+ j 2)) 8)
                    offset))
           (offset (bitwise-ior
                    (arithmetic-shift (vector-ref code (+ j 1)) 16)
                    offset))
           (offset (bitwise-ior
                    (arithmetic-shift (vector-ref code j) 24)
                    offset)))
      (set-box! ip (word-add j (cast offset Word))))))

(: jriz (Stack-Memory Register Executable-Memory Register -> Void))
(define (jriz stack sp code ip)
  ;; Jump relative immediate, if zero.
  (let ((i (unbox sp)))
    (unless (<= 1 i)
      (raise-user-error "stack underflow"))
    (let ((x (vector-ref stack (- i 1))))
      (set-box! sp (- i 1))
      (if (zero? x)
          (jri code ip)
          (let ((j (unbox ip)))
            (set-box! ip (cast (+ j 4) Word)))))))

(: get-immediate-value (Executable-Memory Register -> Word))
(define (get-immediate-value code ip)
  (let ((j (unbox ip)))
    (unless (<= (+ j 4) executable-memory-size)
      (raise-user-error "address past end of executable memory"))
    ;; Big-endian order.
    (let* ((x (vector-ref code (+ j 3)))
           (x (bitwise-ior
               (arithmetic-shift (vector-ref code (+ j 2)) 8)
               x))
           (x (bitwise-ior
               (arithmetic-shift (vector-ref code (+ j 1)) 16)
               x))
           (x (bitwise-ior
               (arithmetic-shift (vector-ref code j) 24)
               x)))
      (set-box! ip (cast (+ j 4) Word))
      (cast x Word))))

(: pushi (Stack-Memory Register Executable-Memory Register -> Void))
(define (pushi stack sp code ip)
  ;; Push-immediate a value from executable memory onto the stack.
  (let ((i (unbox sp)))
    (unless (< i stack-memory-size)
      (raise-user-error "stack overflow"))
    (vector-set! stack i (get-immediate-value code ip))
    (set-box! sp (cast (+ i 1) Word))))

(: fetch (Stack-Memory
          Register Executable-Memory Register
          Data-Memory -> Void))
(define (fetch stack sp code ip data)
  ;; Fetch data to the stack, using the storage location given in
  ;; executable memory.
  (let ((i (unbox sp)))
    (unless (< i stack-memory-size)
      (raise-user-error "stack overflow"))
    (let* ((k (get-immediate-value code ip))
           (x (vector-ref data k)))
      (vector-set! stack i x)
      (set-box! sp (cast (+ i 1) Word)))))

(: pop-one (Stack-Memory Register -> Word))
(define (pop-one stack sp)
  (let ((i (unbox sp)))
    (unless (<= 1 i)
      (raise-user-error "stack underflow"))
    (let* ((x (vector-ref stack (- i 1))))
      (set-box! sp (- i 1))
      x)))

(: store (Stack-Memory
          Register Executable-Memory Register
          Data-Memory -> Void))
(define (store stack sp code ip data)
  ;; Store data from the stack, using the storage location given in
  ;; executable memory.
  (let ((i (unbox sp)))
    (unless (<= 1 i)
      (raise-user-error "stack underflow"))
    (let ((k (get-immediate-value code ip))
          (x (pop-one stack sp)))
      (vector-set! data k x))))

(: prti (Stack-Memory Register Output-Port -> Void))
(define (prti stack sp outf)
  ;; Print the top value of the stack, as a signed decimal value.
  (let* ((n (pop-one stack sp))
         (n<0 (word-signbit? n)))
    (if n<0
        (begin (display "-" outf)
               (display (word-neg n) outf))
        (display n outf))))

(: prtc (Stack-Memory Register Output-Port -> Void))
(define (prtc stack sp outf)
  ;; Print the top value of the stack, as a character.
  (let ((c (pop-one stack sp)))
    (display (integer->char c) outf)))

(: prts (Stack-Memory
         Register (Immutable-Vectorof String) Output-Port -> Void))
(define (prts stack sp strings outf)
  ;; Print the string specified by the top of the stack.
  (let* ((k (pop-one stack sp))
         (s (vector-ref strings k)))
    (display s outf)))

;;
;; I have written macros in the standard R6RS fashion, with a lambda
;; and syntax-case, so the examples may be widely illustrative. Racket
;; supports this style, despite (purposely) not adhering to any Scheme
;; standard.
;;
;; Some Schemes that do not provide syntax-case (CHICKEN, for
;; instance) provide alternatives that may be quite different.
;;
;; R5RS and R7RS require only syntax-rules, which cannot do what we
;; are doing here. (What we are doing is similar to using ## in a
;; modern C macro, except that the pieces are not merely raw text, and
;; they must be properly typed at every stage.)
;;
(define-syntax define-machine-binop
  (lambda (stx)
    (syntax-case stx ()
      ((_ op)
       (let* ((op^ (syntax->datum #'op))
              (machine-op (string-append "machine-" op^))
              (machine-op (string->symbol machine-op))
              (machine-op (datum->syntax stx machine-op))
              (word-op (string-append "word-" op^))
              (word-op (string->symbol word-op))
              (word-op (datum->syntax stx word-op)))
         #`(begin
             (: #,machine-op (Machine -> Void))
             (define (#,machine-op mach)
               (binop (machine-stack mach)
                      (machine-sp mach)
                      #,word-op))))))))

(define-syntax define-machine-unop
  (lambda (stx)
    (syntax-case stx ()
      ((_ op)
       (let* ((op^ (syntax->datum #'op))
              (machine-op (string-append "machine-" op^))
              (machine-op (string->symbol machine-op))
              (machine-op (datum->syntax stx machine-op))
              (word-op (string-append "word-" op^))
              (word-op (string->symbol word-op))
              (word-op (datum->syntax stx word-op)))
         #`(begin
             (: #,machine-op (Machine -> Void))
             (define (#,machine-op mach)
               (unop (machine-stack mach)
                     (machine-sp mach)
                     #,word-op))))))))

(define-machine-binop "add")
(define-machine-binop "sub")
(define-machine-binop "mul")
(define-machine-binop "div")
(define-machine-binop "mod")
(define-machine-binop "lt")
(define-machine-binop "gt")
(define-machine-binop "le")
(define-machine-binop "ge")
(define-machine-binop "eq")
(define-machine-binop "ne")
(define-machine-binop "and")
(define-machine-binop "or")

(define-machine-unop "neg")

(: machine-not (Machine -> Void))
(define (machine-not mach)
  (unop (machine-stack mach)
        (machine-sp mach)
        word-cmp))

(: machine-prtc (Machine -> Void))
(define (machine-prtc mach)
  (prtc (machine-stack mach)
        (machine-sp mach)
        (machine-output mach)))

(: machine-prti (Machine -> Void))
(define (machine-prti mach)
  (prti (machine-stack mach)
        (machine-sp mach)
        (machine-output mach)))

(: machine-prts (Machine -> Void))
(define (machine-prts mach)
  (prts (machine-stack mach)
        (machine-sp mach)
        (machine-strings mach)
        (machine-output mach)))

(: machine-fetch (Machine -> Void))
(define (machine-fetch mach)
  (fetch (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)
         (machine-data mach)))

(: machine-store (Machine -> Void))
(define (machine-store mach)
  (store (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)
         (machine-data mach)))

(: machine-push (Machine -> Void))
(define (machine-push mach)
  (pushi (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)))

(: machine-jmp (Machine -> Void))
(define (machine-jmp mach)
  (jri (machine-code mach)
       (machine-ip mach)))

(: machine-jz (Machine -> Void))
(define (machine-jz mach)
  (jriz (machine-stack mach)
        (machine-sp mach)
        (machine-code mach)
        (machine-ip mach)))

(: get-opcode (Machine -> Byte))
(define (get-opcode mach)
  (let ((code (machine-code mach))
        (ip (machine-ip mach)))
    (let ((j (unbox ip)))
      (unless (< j executable-memory-size)
        (raise-user-error "address past end of executable memory"))
      (let ((opcode (vector-ref code j)))
        (set-box! ip (cast (+ j 1) Word))
        opcode))))

(: run-instruction (Machine Byte -> Void))
(define (run-instruction mach opcode)
  (let ((op-mod-4 (bitwise-and opcode #x3))
        (op-div-4 (arithmetic-shift opcode -2)))
    (match op-div-4
      (0 (match op-mod-4
           (1 (machine-add mach))
           (2 (machine-sub mach))
           (3 (machine-mul mach))))
      (1 (match op-mod-4
           (0 (machine-div mach))
           (1 (machine-mod mach))
           (2 (machine-lt mach))
           (3 (machine-gt mach))))
      (2 (match op-mod-4
           (0 (machine-le mach))
           (1 (machine-ge mach))
           (2 (machine-eq mach))
           (3 (machine-ne mach))))
      (3 (match op-mod-4
           (0 (machine-and mach))
           (1 (machine-or mach))
           (2 (machine-neg mach))
           (3 (machine-not mach))))
      (4 (match op-mod-4
           (0 (machine-prtc mach))
           (1 (machine-prti mach))
           (2 (machine-prts mach))
           (3 (machine-fetch mach))))
      (5 (match op-mod-4
           (0 (machine-store mach))
           (1 (machine-push mach))
           (2 (machine-jmp mach))
           (3 (machine-jz mach)))))))

(: run-vm (Machine -> Void))
(define (run-vm mach)
  (let ((opcode-for-halt (cast (opcode-from-name "halt") Byte))
        (opcode-for-add (cast (opcode-from-name "add") Byte))
        (opcode-for-jz (cast (opcode-from-name "jz") Byte)))
    (let loop ((opcode (get-opcode mach)))
      (unless (= opcode opcode-for-halt)
        (begin
          (when (or (< opcode opcode-for-add)
                    (< opcode-for-jz opcode))
            (raise-user-error "unsupported opcode"))
          (run-instruction mach opcode)
          (loop (get-opcode mach)))))))

(define (usage-error)
  (display "Usage: vm [INPUTFILE [OUTPUTFILE]]" (current-error-port))
  (newline (current-error-port))
  (display "If either INPUTFILE or OUTPUTFILE is \"-\", the respective"
           (current-error-port))
  (display " standard I/O is used." (current-error-port))
  (newline (current-error-port))
  (exit 1))

(: get-filenames (-> (Values String String)))
(define (get-filenames)
  (match (current-command-line-arguments)
    ((vector) (values "-" "-"))
    ((vector inpf-filename)
     (values (cast inpf-filename String) "-"))
    ((vector inpf-filename outf-filename)
     (values (cast inpf-filename String)
             (cast outf-filename String)))
    (_ (usage-error)
       (values "" ""))))

(let-values (((inpf-filename outf-filename) (get-filenames)))
  (let* ((inpf (open-inpf inpf-filename))
         (outf (open-outf outf-filename)))
    (let-values (((datasize strings-count)
                  (read-datasize-and-strings-count inpf)))
      (let* ((strings
              (vector->immutable-vector
               (list->vector
                (read-string-literals inpf strings-count))))
             (instructions (read-instructions inpf))

             (mach (make-machine strings outf)))

        (unless (<= datasize data-memory-size)
          (raise-user-error
           "the VM's data memory size is exceeded"))
        
        (load-executable-memory (machine-code mach) instructions)
        (run-vm mach)

        (unless (string=? inpf-filename "-")
          (close-input-port inpf))
        (unless (string=? outf-filename "-")
          (close-output-port outf))

        (exit 0)))))


Output:
$ racket vm.rkt compiler-tests/count.vm
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

Raku

(formerly Perl 6) Non-standard size of instructions (not byte-coded, 'Datasize' is 3 not 1) required adjusting the jump offsets.

NOTE: I don't think you are allowed to change the jump offsets. They come from another program from another company from another planet from another galaxy.

WIP: discovered 'P5pack' module, this may allow for completing the task properly, using correct offsets

Translation of: Perl
my @CODE = q:to/END/.lines;
Datasize: 3 Strings: 2
"count is: "
"\n"
    0 push  1
    5 store [0]
   10 fetch [0]
   15 push  10
   20 lt
   21 jz     (68) 65    # jump value adjusted
   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    (-87) 10   # jump value adjusted
   65 halt
END

my (@stack, @strings, @data, $memory);
my $pc = 0;

(@CODE.shift) ~~ /'Datasize:' \s+ (\d+) \s+ 'Strings:' \s+ (\d+)/ or die "bad header";
my $w = $0; # 'wordsize' of op-codes and 'width' of data values
@strings.push: (my $s = @CODE.shift) eq '"\n"' ?? "\n" !! $s.subst(/'"'/, '', :g) for 1..$1;

sub value { substr($memory, ($pc += $w) - $w, $w).trim }

my %ops = (
  'no-op' => sub { },
  'add'   => sub { @stack[*-2]  +=   @stack.pop },
  'sub'   => sub { @stack[*-2]  -=   @stack.pop },
  'mul'   => sub { @stack[*-2]  *=   @stack.pop },
  'div'   => sub { @stack[*-2]  /=   @stack.pop },
  'mod'   => sub { @stack[*-2]  %=   @stack.pop },
  'neg'   => sub { @stack[*-1]   = - @stack[*-1] },
  'and'   => sub { @stack[*-2] &&=   @stack[*-1]; @stack.pop },
  'or'    => sub { @stack[*-2] ||=   @stack[*-1]; @stack.pop },
  'not'   => sub { @stack[*-1]   =   @stack[*-1]               ?? 0 !! 1 },
  'lt'    => sub { @stack[*-1]   =   @stack[*-2] <  @stack.pop ?? 1 !! 0 },
  'gt'    => sub { @stack[*-1]   =   @stack[*-2] >  @stack.pop ?? 1 !! 0 },
  'le'    => sub { @stack[*-1]   =   @stack[*-2] <= @stack.pop ?? 1 !! 0 },
  'ge'    => sub { @stack[*-1]   =   @stack[*-2] >= @stack.pop ?? 1 !! 0 },
  'ne'    => sub { @stack[*-1]   =   @stack[*-2] != @stack.pop ?? 1 !! 0 },
  'eq'    => sub { @stack[*-1]   =   @stack[*-2] == @stack.pop ?? 1 !! 0 },
  'store' => sub { @data[&value] =   @stack.pop },
  'fetch' => sub { @stack.push:      @data[&value] // 0 },
  'push'  => sub { @stack.push:      value() },
  'jmp'   => sub { $pc += value() - $w },
  'jz'    => sub { $pc += @stack.pop ?? $w !! value() - $w },
  'prts'  => sub { print @strings[@stack.pop] },
  'prti'  => sub { print @stack.pop },
  'prtc'  => sub { print chr @stack.pop },
  'halt'  => sub { exit }
);

my %op2n = %ops.keys.sort Z=> 0..*;
my %n2op = %op2n.invert;
%n2op{''} = 'no-op';

for @CODE -> $_ {
    next unless /\w/;
    /^ \s* \d+ \s+ (\w+)/ or die "bad line $_";
    $memory ~= %op2n{$0}.fmt("%{$w}d");
    /'(' ('-'?\d+) ')' | (\d+) ']'? $/;
    $memory ~= $0 ?? $0.fmt("%{$w}d") !! ' ' x $w;
}

loop {
    my $opcode = substr($memory, $pc, $w).trim;
    $pc += $w;
    %ops{%n2op{ $opcode }}();
}
Output:
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

RATFOR

Works with: ratfor77 version public domain 1.0
Works with: gfortran version 11.3.0
Works with: f2c version 20100827


######################################################################
#
# The Rosetta Code code virtual machine in Ratfor 77.
#
# The implementation assumes your FORTRAN compiler supports 1-byte
# INTEGER*1 and 4-byte INTEGER*4. Integer storage will be
# native-endian, achieved via EQUIVALENCE. (GNU Fortran and f2c both
# should work.)
#
#
# How to deal with FORTRAN 77 input is a problem. I use formatted
# input, treating each line as an array of type CHARACTER--regrettably
# of no more than some predetermined, finite length. It is a very
# simple method and presents no significant difficulties, aside from
# the restriction on line length of the input.
#
#
# On a POSIX platform, the program can be compiled with f2c and run
# somewhat as follows:
#
#    ratfor77 vm-in-ratfor.r > vm-in-ratfor.f
#    f2c -C -Nc40 vm-in-ratfor.f
#    cc vm-in-ratfor.c -lf2c
#    ./a.out < compiler-tests/primes.vm
#
# With gfortran, a little differently:
#
#    ratfor77 vm-in-ratfor.r > vm-in-ratfor.f
#    gfortran -fcheck=all -std=legacy vm-in-ratfor.f
#    ./a.out < compiler-tests/primes.vm
#
#
# I/O is strictly from default input and to default output, which, on
# POSIX systems, usually correspond respectively to standard input and
# standard output. (I did not wish to have to deal with unit numbers;
# these are now standardized in ISO_FORTRAN_ENV, but that is not
# available in FORTRAN 77.)
#
#---------------------------------------------------------------------

# Some parameters you may wish to modify.

define(LINESZ, 256)           # Size of an input line.
define(OUTLSZ, 1024)          # Size of an output line.
define(STRNSZ, 4096)          # Size of the string pool.
define(STCKSZ, 4096)          # Size of stacks.
define(MAXVAR, 256)           # Maximum number of variables.
define(MAXSTR, 256)           # Maximum number of strings.
define(CODESZ, 16384)         # Maximum size of a compiled program.

define(STRSZ, 2)           # Size of an entry in the VM strings array.
define(STRI,  1)           # Index of the string within strngs.
define(STRN,  2)           # Length of the string.

#---------------------------------------------------------------------

define(NEWLIN, 10)            # The Unix newline character (ASCII LF).
define(DQUOTE, 34)            # The double quote character.
define(BACKSL, 92)            # The backslash character.

#---------------------------------------------------------------------

define(OPHALT,  1)
define(OPADD,   2)
define(OPSUB,   3)
define(OPMUL,   4)
define(OPDIV,   5)
define(OPMOD,   6)
define(OPLT,    7)
define(OPGT,    8)
define(OPLE,    9)
define(OPGE,   10)
define(OPEQ,   11)
define(OPNE,   12)
define(OPAND,  13)
define(OPOR,   14)
define(OPNEG,  15)
define(OPNOT,  16)
define(OPPRTC, 17)
define(OPPRTI, 18)
define(OPPRTS, 19)
define(OPFTCH, 20)
define(OPSTOR, 21)
define(OPPUSH, 22)
define(OPJMP,  23)
define(OPJZ,   24)

#---------------------------------------------------------------------

function issp (c)

  # Is a character a space character?

  implicit none

  character c
  logical issp

  integer ic

  ic = ichar (c)
  issp = (ic == 32 || (9 <= ic && ic <= 13))
end

function isalph (c)

  # Is c character code for a letter?

  implicit none

  integer c
  logical isalph

  #
  # The following is correct for ASCII and Unicode, but not for
  # EBCDIC.
  #
  isalph = (ichar ('a') <= c && c <= ichar ('z')) _
             || (ichar ('A') <= c && c <= ichar ('Z'))
end

function isdgt (c)

  # Is c character code for a digit?

  implicit none

  integer c
  logical isdgt

  isdgt = (ichar ('0') <= c && c <= ichar ('9'))
end

function skipsp (str, i, imax)

  # Skip past spaces in a string.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipsp

  logical issp

  logical done

  skipsp = i
  done = .false.
  while (!done)
    {
      if (imax <= skipsp)
        done = .true.
      else if (!issp (str(skipsp)))
        done = .true.
      else
        skipsp = skipsp + 1
    }
end

function skipns (str, i, imax)

  # Skip past non-spaces in a string.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipns

  logical issp

  logical done

  skipns = i
  done = .false.
  while (!done)
    {
      if (imax <= skipns)
        done = .true.
      else if (issp (str(skipns)))
        done = .true.
      else
        skipns = skipns + 1
    }
end

function trimrt (str, n)

  # Find the length of a string, if one ignores trailing spaces.

  implicit none

  character str(*)
  integer n
  integer trimrt

  logical issp

  logical done

  trimrt = n
  done = .false.
  while (!done)
    {
      if (trimrt == 0)
        done = .true.
      else if (!issp (str(trimrt)))
        done = .true.
      else
        trimrt = trimrt - 1
    }
end

function skipal (str, i, imax)

  # Skip past alphabetic characters in a string.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipal

  logical isalph

  logical done

  skipal = i
  done = .false.
  while (!done)
    {
      if (imax <= skipal)
        done = .true.
      else if (!isalph (ichar (str(skipal))))
        done = .true.
      else
        skipal = skipal + 1
    }
end

function skipdg (str, i, imax)

  # Skip past digits in a string.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipdg

  logical isdgt

  logical done

  skipdg = i
  done = .false.
  while (!done)
    {
      if (imax <= skipdg)
        done = .true.
      else if (!isdgt (ichar (str(skipdg))))
        done = .true.
      else
        skipdg = skipdg + 1
    }
end

function skipnd (str, i, imax)

  # Skip past nondigits in a string.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipnd

  logical isdgt

  logical done

  skipnd = i
  done = .false.
  while (!done)
    {
      if (imax <= skipnd)
        done = .true.
      else if (isdgt (ichar (str(skipnd))))
        done = .true.
      else
        skipnd = skipnd + 1
    }
end

function skipd1 (str, i, imax)

  # Skip past digits and '-' in a string.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipd1

  logical isdgt

  logical done

  skipd1 = i
  done = .false.
  while (!done)
    {
      if (imax <= skipd1)
        done = .true.
      else if (!isdgt (ichar (str(skipd1))) && str(skipd1) != '-')
        done = .true.
      else
        skipd1 = skipd1 + 1
    }
end

function skipn1 (str, i, imax)

  # Skip past nondigits in a string, except '-'.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipn1

  logical isdgt

  logical done

  skipn1 = i
  done = .false.
  while (!done)
    {
      if (imax <= skipn1)
        done = .true.
      else if (isdgt (ichar (str(skipn1))) || str(skipn1) == '-')
        done = .true.
      else
        skipn1 = skipn1 + 1
    }
end

function tolowr (c)

  implicit none

  character c
  character tolowr

  integer ic

  # The following is correct for ASCII, and will work with Unicode
  # code points, but is incorrect for EBCDIC.

  ic = ichar (c)
  if (ichar ('A') <= ic && ic <= ichar ('Z'))
    ic = ic - ichar('A') + ichar('a')
  tolowr = char (ic)
end

#---------------------------------------------------------------------

subroutine addstq (strngs, istrng, src, i0, n0, i, n)

  # Add a quoted string to the string pool.

  implicit none

  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character src(*)              # Source string.
  integer i0, n0                # Index and length in source string.
  integer i, n                  # Index and length in string pool.

  integer j
  logical done

1000 format ('attempt to treat an unquoted string as a quoted string')

  if (src(i0) != char (DQUOTE) || src(i0 + n0 - 1) != char (DQUOTE))
    {
      write (*, 1000)
      stop
    }

  i = istrng

  n = 0
  j = i0 + 1
  done = .false.
  while (j != i0 + n0 - 1)
    if (i == STRNSZ)
      {
        write (*, '(''string pool exhausted'')')
        stop
      }
    else if (src(j) == char (BACKSL))
      {
        if (j == i0 + n0 - 1)
          {
            write (*, '(''incorrectly formed quoted string'')')
            stop
          }
        if (src(j + 1) == 'n')
          strngs(istrng) = char (NEWLIN)
        else if (src(j + 1) == char (BACKSL))
          strngs(istrng) = src(j + 1)
        else
          {
            write (*, '(''unrecognized escape sequence'')')
            stop
          }
        istrng = istrng + 1
        n = n + 1
        j = j + 2
      }
    else
      {
        strngs(istrng) = src(j)
        istrng = istrng + 1
        n = n + 1
        j = j + 1
      }
end

#---------------------------------------------------------------------

subroutine push (stack, sp, i)

  implicit none

  integer stack(STCKSZ)
  integer sp                    # Stack pointer.
  integer i                     # Value to push.

  if (sp == STCKSZ)
    {
      write (*, '(''stack overflow in push'')')
      stop
    }
  stack(sp) = i
  sp = sp + 1
end

function pop (stack, sp)

  implicit none

  integer stack(STCKSZ)
  integer sp                    # Stack pointer.
  integer pop

  if (sp == 1)
    {
      write (*, '(''stack underflow in pop'')')
      stop
    }
  sp = sp - 1
  pop = stack(sp)
end

function nstack (sp)

  implicit none

  integer sp                    # Stack pointer.
  integer nstack

  nstack = sp - 1               # Current cardinality of the stack.
end

#---------------------------------------------------------------------

subroutine flushl (outbuf, noutbf)

  # Flush a line from the output buffer.

  implicit none

  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.

  character*20 fmt
  integer i

  if (noutbf == 0)
    write (*, '()')
  else
    {
      write (fmt, 1000) noutbf
1000  format ('(', I10, 'A)')
      write (*, fmt) (outbuf(i), i = 1, noutbf)
      noutbf = 0
    }
end

subroutine wrtchr (outbuf, noutbf, ch)

  # Write a character to output.

  implicit none

  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.
  character ch                  # The character to output.

  # This routine silently truncates anything that goes past the buffer
  # boundary.

  if (ch == char (NEWLIN))
    call flushl (outbuf, noutbf)
  else if (noutbf < OUTLSZ)
    {
      noutbf = noutbf + 1
      outbuf(noutbf) = ch
    }
end

subroutine wrtstr (outbuf, noutbf, str, i, n)

  # Write a substring to output.

  implicit none

  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.
  character str(*)              # The string from which to output.
  integer i, n                  # Index and length of the substring.

  integer j

  for (j = 0; j < n; j = j + 1)
    call wrtchr (outbuf, noutbf, str(i + j))
end

subroutine wrtint (outbuf, noutbf, ival, colcnt)

  # Write an integer to output.

  implicit none

  character outbuf(OUTLSZ)    # Output line buffer.
  integer noutbf              # Number of characters in outbuf.
  integer ival                # The non-negative integer to print.
  integer colcnt              # Column count, or zero for free format.

  integer skipsp

  character*40 buf
  integer i, j

  write (buf, '(I40)') ival
  i = skipsp (buf, 1, 41)
  if (0 < colcnt)
    for (j = 1; j < colcnt - (40 - i); j = j + 1)
      call wrtchr (outbuf, noutbf, ' ')
  while (i <= 40)
    {
      call wrtchr (outbuf, noutbf, buf(i:i))
      i = i + 1
    }
end

#---------------------------------------------------------------------

function strnat (str, i, n)

  # Convert a string to a non-negative integer.

  implicit none

  character str(*)
  integer i, n
  integer strnat

  integer j

  strnat = 0
  for (j = 0; j < n; j = j + 1)
    strnat = (10 * strnat) + (ichar (str(i + j)) - ichar ('0'))
end

function strint (str, i, n)

  # Convert a string to an integer

  implicit none

  character str(*)
  integer i, n
  integer strint

  integer strnat

  if (str(i) == '-')
    strint = -strnat (str, i + 1, n - 1)
  else
    strint = strnat (str, i, n)
end

#---------------------------------------------------------------------

subroutine put1 (code, i, opcode)

  # Store a 1-byte operation.

  implicit none

  integer*1 code(0 : CODESZ - 1) # Byte code.
  integer i                      # Address to put the code at.
  integer*1 opcode

  if (CODESZ - i < 1)
    {
      write (*, '(''address beyond the size of memory'')')
      stop
    }
  code(i) = opcode
end

subroutine put5 (code, i, opcode, ival)

  # Store a 5-byte operation.

  implicit none

  integer*1 code(0 : CODESZ - 1) # Byte code.
  integer i                      # Address to put the code at.
  integer*1 opcode               #
  integer ival                   # Immediate integer value.

  integer*4 ival32
  integer*1 ival8(4)
  equivalence (ival32, ival8)

  if (CODESZ - i < 5)
    {
      write (*, '(''address beyond the size of memory'')')
      stop
    }
  code(i) = opcode

  # Native-endian storage.
  ival32 = ival
  code(i + 1) = ival8(1)
  code(i + 2) = ival8(2)
  code(i + 3) = ival8(3)
  code(i + 4) = ival8(4)
end

function getimm (code, i)

  # Get an immediate value from the code, at address i.

  implicit none

  integer*1 code(0 : CODESZ - 1) # Byte code.
  integer i                    # Address at which the integer resides.
  integer getimm               # Immediate integer value.

  integer*4 ival32
  integer*1 ival8(4)
  equivalence (ival32, ival8)

  if (i < 0 || CODESZ <= i + 3)
    {
      write (*, '(''code address out of range'')')
      stop
    }

  # Native-endian storage.
  ival8(1) = code(i)
  ival8(2) = code(i + 1)
  ival8(3) = code(i + 2)
  ival8(4) = code(i + 3)
  getimm = ival32
end

#---------------------------------------------------------------------

subroutine rdhead (datsiz, strsiz)

  # Read the header line.

  implicit none

  integer datsiz
  integer strsiz

  integer skipnd
  integer skipdg
  integer strnat

  character line(LINESZ)
  character*20 fmt
  integer i1, j1, i2, j2

  # Read a line of text as an array of characters.
  write (fmt, '(''('', I10, ''A)'')') LINESZ
  read (*, fmt) line

  i1 = skipnd (line, 1, LINESZ + 1)
  j1 = skipdg (line, i1, LINESZ + 1)
  i2 = skipnd (line, j1, LINESZ + 1)
  j2 = skipdg (line, i2, LINESZ + 1)
  if (i1 == j1 || i2 == j2)
    {
      write (*, '(''bad header line'')')
      stop
    }
  datsiz = strnat (line, i1, j1 - i1)
  strsiz = strnat (line, i2, j2 - i2)
end

subroutine rdstrs (strs, strsiz, strngs, istrng)

  implicit none

  integer strs(1:STRSZ, 0 : MAXSTR - 1)
  integer strsiz
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.

  integer trimrt
  integer skipsp

  character line(LINESZ)
  character*20 fmt
  integer j
  integer i, n
  integer i0, n0

  # Read lines of text as an array of characters.
  write (fmt, '(''('', I10, ''A)'')') LINESZ

  for (j = 0; j < strsiz; j = j + 1)
    {
      read (*, fmt) line
      n0 = trimrt (line, LINESZ)
      i0 = skipsp (line, 1, n0 + 1)
      if (i0 == n0 + 1)
        {
          write (*, '(''blank line where a string should be'')')
          stop
        }
      call addstq (strngs, istrng, line, i0, n0 - i0 + 1, i, n)
      strs(STRI, j) = i
      strs(STRN, j) = n
    }
end

function stropc (str, i, n)

  # Convert substring to an opcode.

  implicit none

  character str(*)
  integer i, n
  integer*1 stropc

  stropc = -1
  if (n == 2)
    {
      if (str(i) == 'l')
        {
          if (str(i + 1) == 't')
            stropc = OPLT
          else if (str(i + 1) == 'e')
            stropc = OPLE
        }
      else if (str(i) == 'g')
        {
          if (str(i + 1) == 't')
            stropc = OPGT
          else if (str(i + 1) == 'e')
            stropc = OPGE
        }
      else if (str(i) == 'e' && str(i + 1) == 'q')
        stropc = OPEQ
      else if (str(i) == 'n' && str(i + 1) == 'e')
        stropc = OPNE
      else if (str(i) == 'o' && str(i + 1) == 'r')
        stropc = OPOR
      else if (str(i) == 'j' && str(i + 1) == 'z')
        stropc = OPJZ
    }
  else if (n == 3)
    {
      if (str(i) == 'a')
        {
          if (str(i + 1) == 'd' && str(i + 2) == 'd')
            stropc = OPADD
          else if (str(i + 1) == 'n' && str(i + 2) == 'd')
            stropc = OPAND
        }
      else if (str(i) == 'm')
        {
          if (str(i + 1) == 'o' && str(i + 2) == 'd')
            stropc = OPMOD
          else if (str(i + 1) == 'u' && str(i + 2) == 'l')
            stropc = OPMUL
        }
      else if (str(i) == 'n')
        {
          if (str(i + 1) == 'e' && str(i + 2) == 'g')
            stropc = OPNEG
          else if (str(i + 1) == 'o' && str(i + 2) == 't')
            stropc = OPNOT
        }
      else if (str(i) == 's' && str(i + 1) == 'u' _
                 && str(i + 2) == 'b')
        stropc = OPSUB
      else if (str(i) == 'd' && str(i + 1) == 'i' _
                 && str(i + 2) == 'v')
        stropc = OPDIV
      else if (str(i) == 'j' && str(i + 1) == 'm' _
                 && str(i + 2) == 'p')
        stropc = OPJMP
    }
  else if (n == 4)
    {
      if (str(i) == 'p')
        {
          if (str(i + 1) == 'r' && str(i + 2) == 't')
            {
              if (str(i + 3) == 'c')
                stropc = OPPRTC
              else if (str(i + 3) == 'i')
                stropc = OPPRTI
              else if (str(i + 3) == 's')
                stropc = OPPRTS
            }
          if (str(i + 1) == 'u' && str(i + 2) == 's' _
                && str(i + 3) == 'h')
            stropc = OPPUSH
        }
      else if (str(i) == 'h' && str(i + 1) == 'a' _
                 && str(i + 2) == 'l' && str(i + 3) == 't')
        stropc = OPHALT
    }
  else if (n == 5)
    {
      if (str(i) == 'f' && str(i + 1) == 'e' && str(i + 2) == 't' _
            && str(i + 3) == 'c' && str(i + 4) == 'h')
        stropc = OPFTCH
      if (str(i) == 's' && str(i + 1) == 't' && str(i + 2) == 'o' _
            && str(i + 3) == 'r' && str(i + 4) == 'e')
        stropc = OPSTOR
    }
  if (stropc == -1)
    {
      write (*, '(''unrecognized opcode name'')')
      stop
    }
end

subroutine rdops (code)

  # Read the opcodes and their immediate values.

  implicit none

  integer*1 code(0 : CODESZ - 1) # The byte code.

  integer trimrt
  integer skipsp
  integer skipal
  integer skipdg
  integer skipd1
  integer skipn1
  integer strnat
  integer strint
  integer*1 stropc
  character tolowr

  character line(LINESZ)
  character*20 fmt
  integer stat
  integer n
  integer j
  integer iaddr, jaddr          # Address index and size.
  integer iopnm, jopnm          # Opcode name index and size.
  integer iarg, jarg
  integer addr
  integer arg
  integer*1 opcode

  # Read lines of text as an array of characters.
  write (fmt, '(''('', I10, ''A)'')') LINESZ

  read (*, fmt, iostat = stat) line
  while (stat == 0)
    {
      n = trimrt (line, LINESZ)

      for (j = 1; j <= n; j = j + 1)
        line(j) = tolowr (line(j))

      iaddr = skipsp (line, 1, n + 1)
      jaddr = skipdg (line, iaddr, n + 1)
      addr = strnat (line, iaddr, jaddr - iaddr)

      iopnm = skipsp (line, jaddr, n + 1)
      jopnm = skipal (line, iopnm, n + 1)
      opcode = stropc (line, iopnm, jopnm - iopnm) 

      if (opcode == OPPUSH || opcode == OPFTCH || opcode == OPSTOR _
            || opcode == OPJMP || opcode == OPJZ)
        {
          iarg = skipn1 (line, jopnm, n + 1)
          jarg = skipd1 (line, iarg, n + 1)
          arg = strint (line, iarg, jarg - iarg)
          call put5 (code, addr, opcode, arg)
        }
      else
        call put1 (code, addr, opcode)

      read (*, fmt, iostat = stat) line
    }
end

subroutine rdcode (strs, strngs, istrng, code)

  # Read and parse the "assembly" code.

  implicit none

  integer strs(1:STRSZ, 0 : MAXSTR - 1)
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer*1 code(0 : CODESZ - 1) # The byte code.

  integer datsiz
  integer strsiz

  call rdhead (datsiz, strsiz)
  if (MAXVAR < datsiz)
    {
      write (*, '(''too many variables'')')
      stop
    }
  if (MAXSTR < strsiz)
    {
      write (*, '(''too many strings'')')
      stop
    }

  call rdstrs (strs, strsiz, strngs, istrng)
  call rdops (code)
end

#---------------------------------------------------------------------

subroutine stkbin (sp)

  implicit none

  integer sp

  if (sp < 3)
    {
      write (*, '(''stack underflow in binary operation'')')
      stop
    }
end

subroutine stkun (sp)

  implicit none

  integer sp

  if (sp < 2)
    {
      write (*, '(''stack underflow in unary operation'')')
      stop
    }
end

function logl2i (b)

  implicit none

  logical b
  integer logl2i

  if (b)
    logl2i = 1
  else
    logl2i = 0
end

subroutine rncode (strs, strngs, code, outbuf, noutbf)

  # Run the code.

  implicit none

  integer strs(1:STRSZ, 0 : MAXSTR - 1)
  character strngs(STRNSZ)       # String pool.
  integer*1 code(0 : CODESZ - 1) # The byte code.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.

  integer logl2i
  integer getimm
  integer pop

  integer stack(STCKSZ)
  integer data(0 : MAXVAR - 1)
  integer sp                    # Stack pointer.

  integer pc                    # Program counter.
  integer ip                    # Instruction pointer.
  equivalence (pc, ip)          # LOL, use either name. :)

  integer i, n
  integer*1 opcode
  logical done

  sp = 1
  ip = 0

  done = .false.
  while (!done)
    {
      if (ip < 0 || CODESZ <= ip)
        {
          write (*, '(''code address out of range'')')
          stop
        }
      opcode = code(ip)
      ip = ip + 1
      if (opcode == OPADD)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = stack (sp - 1) + stack(sp)
        }
      else if (opcode == OPSUB)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = stack (sp - 1) - stack(sp)
        }
      else if (opcode == OPMUL)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = stack (sp - 1) * stack(sp)
        }
      else if (opcode == OPDIV)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = stack (sp - 1) / stack(sp)
        }
      else if (opcode == OPMOD)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = mod (stack (sp - 1), stack(sp))
        }
      else if (opcode == OPLT)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) < stack(sp))
        }
      else if (opcode == OPGT)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) > stack(sp))
        }
      else if (opcode == OPLE)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) <= stack(sp))
        }
      else if (opcode == OPGE)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) >= stack(sp))
        }
      else if (opcode == OPEQ)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) == stack(sp))
        }
      else if (opcode == OPNE)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = logl2i (stack (sp - 1) != stack(sp))
        }
      else if (opcode == OPAND)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = _
            logl2i (stack (sp - 1) != 0 && stack(sp) != 0)
        }
      else if (opcode == OPOR)
        {
          call stkbin (sp)
          sp = sp - 1
          stack(sp - 1) = _
            logl2i (stack (sp - 1) != 0 || stack(sp) != 0)
        }
      else if (opcode == OPNEG)
        {
          call stkun (sp)
          stack(sp - 1) = -stack(sp - 1)
        }
      else if (opcode == OPNOT)
        {
          call stkun (sp)
          stack(sp - 1) = logl2i (stack(sp - 1) == 0)
        }
      else if (opcode == OPPRTC)
        {
          call wrtchr (outbuf, noutbf, char (pop (stack, sp)))
        }
      else if (opcode == OPPRTI)
        {
          call wrtint (outbuf, noutbf, pop (stack, sp), 0)
        }
      else if (opcode == OPPRTS)
        {
          i = pop (stack, sp)
          if (i < 0 || MAXSTR <= i)
            {
              write (*, '(''string address out of range'')')
              stop
            }
          n = strs(STRN, i)
          i = strs(STRI, i)
          call wrtstr (outbuf, noutbf, strngs, i, n)
        }
      else if (opcode == OPFTCH)
        {
          i = getimm (code, ip)
          ip = ip + 4
          if (i < 0 || MAXVAR <= i)
            {
              write (*, '(''data address out of range'')')
              stop
            }
          call push (stack, sp, data(i))
        }
      else if (opcode == OPSTOR)
        {
          i = getimm (code, ip)
          ip = ip + 4
          if (i < 0 || MAXVAR <= i)
            {
              write (*, '(''data address out of range'')')
              stop
            }
          data(i) = pop (stack, sp)
        }
      else if (opcode == OPPUSH)
        {
          call push (stack, sp, getimm (code, ip))
          ip = ip + 4
        }
      else if (opcode == OPJMP)
        {
          ip = ip + getimm (code, ip)
        }
      else if (opcode == OPJZ)
        {
          if (pop (stack, sp) == 0)
            ip = ip + getimm (code, ip)
          else
            ip = ip + 4
        }
      else
        {
          # Halt on OPHALT or any unrecognized code.
          done = .true.
        }
    }
end

#---------------------------------------------------------------------

program vm

  implicit none

  integer strs(1:STRSZ, 0 : MAXSTR - 1)
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer*1 code(0 : CODESZ - 1) # The byte code.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.

  integer j

  istrng = 1
  noutbf = 0

  for (j = 0; j < CODESZ; j = j + 1)
    code(j) = OPHALT

  call rdcode (strs, strngs, istrng, code)
  call rncode (strs, strngs, code, outbuf, noutbf)

  if (noutbf != 0)
    call flushl (outbuf, noutbf)
end

######################################################################


Output:
$ ratfor77 vm-in-ratfor.r > vm-in-ratfor.f && gfortran -O2 -fcheck=all -std=legacy vm-in-ratfor.f && ./a.out < compiler-tests/primes.vm
3 is prime
5 is prime
7 is prime
11 is prime
13 is prime
17 is prime
19 is prime
23 is prime
29 is prime
31 is prime
37 is prime
41 is prime
43 is prime
47 is prime
53 is prime
59 is prime
61 is prime
67 is prime
71 is prime
73 is prime
79 is prime
83 is prime
89 is prime
97 is prime
101 is prime
Total primes found: 26

Scala

The complete implementation for the compiler tasks can be found in a GitHub repository at github.com/edadma/rosettacodeCompiler which includes full unit testing for the samples given in Compiler/Sample programs.

The following code implements a virtual machine for the output of the code generator.

package xyz.hyperreal.rosettacodeCompiler

import java.io.{BufferedReader, FileReader, Reader, StringReader}

import scala.collection.mutable
import scala.collection.mutable.ArrayBuffer

object VirtualMachine {

  private object Opcodes {
    val FETCH: Byte = 0
    val STORE: Byte = 1
    val PUSH: Byte  = 2
    val JMP: Byte   = 3
    val JZ: Byte    = 4
    val ADD: Byte   = 5
    val SUB: Byte   = 6
    val MUL: Byte   = 7
    val DIV: Byte   = 8
    val MOD: Byte   = 9
    val LT: Byte    = 10
    val GT: Byte    = 11
    val LE: Byte    = 12
    val GE: Byte    = 13
    val EQ: Byte    = 14
    val NE: Byte    = 15
    val AND: Byte   = 16
    val OR: Byte    = 17
    val NEG: Byte   = 18
    val NOT: Byte   = 19
    val PRTC: Byte  = 20
    val PRTI: Byte  = 21
    val PRTS: Byte  = 22
    val HALT: Byte  = 23
  }

  import Opcodes._

  private val HEADER_REGEX = "Datasize: ([0-9]+) Strings: ([0-9]+)" r
  private val STRING_REGEX = "\"([^\"]*)\"" r
  private val PUSH_REGEX   = " *[0-9]+ push +([0-9]+|'(?:[^'\\n]|\\\\n|\\\\\\\\)')" r
  private val PRTS_REGEX   = " *[0-9]+ prts" r
  private val PRTI_REGEX   = " *[0-9]+ prti" r
  private val PRTC_REGEX   = " *[0-9]+ prtc" r
  private val HALT_REGEX   = " *[0-9]+ halt" r
  private val STORE_REGEX  = " *[0-9]+ store +\\[([0-9]+)\\]" r
  private val FETCH_REGEX  = " *[0-9]+ fetch +\\[([0-9]+)\\]" r
  private val LT_REGEX     = " *[0-9]+ lt" r
  private val GT_REGEX     = " *[0-9]+ gt" r
  private val LE_REGEX     = " *[0-9]+ le" r
  private val GE_REGEX     = " *[0-9]+ ge" r
  private val NE_REGEX     = " *[0-9]+ ne" r
  private val EQ_REGEX     = " *[0-9]+ eq" r
  private val JZ_REGEX     = " *[0-9]+ jz +\\((-?[0-9]+)\\) [0-9]+" r
  private val ADD_REGEX    = " *[0-9]+ add" r
  private val SUB_REGEX    = " *[0-9]+ sub" r
  private val MUL_REGEX    = " *[0-9]+ mul" r
  private val DIV_REGEX    = " *[0-9]+ div" r
  private val MOD_REGEX    = " *[0-9]+ mod" r
  private val AND_REGEX    = " *[0-9]+ and" r
  private val OR_REGEX     = " *[0-9]+ or" r
  private val NOT_REGEX    = " *[0-9]+ not" r
  private val NEG_REGEX    = " *[0-9]+ neg" r
  private val JMP_REGEX    = " *[0-9]+ jmp +\\((-?[0-9]+)\\) [0-9]+" r

  def fromStdin = fromReader(Console.in)

  def fromFile(file: String) = fromReader(new FileReader(file))

  def fromString(src: String) = fromReader(new StringReader(src))

  def fromReader(r: Reader) = {
    val in = new BufferedReader(r)
    val vm =
      in.readLine match {
        case HEADER_REGEX(datasize, stringsize) =>
          val strings =
            for (_ <- 1 to stringsize.toInt)
              yield
                in.readLine match {
                  case STRING_REGEX(s) => unescape(s)
                  case null            => sys.error("expected string constant but encountered end of input")
                  case s               => sys.error(s"expected string constant: $s")
                }
          var line: String = null
          val code         = new ArrayBuffer[Byte]

          def addShort(a: Int) = {
            code += (a >> 8).toByte
            code += a.toByte
          }

          def addInstIntOperand(opcode: Byte, operand: Int) = {
            code += opcode
            addShort(operand >> 16)
            addShort(operand)
          }

          def addInst(opcode: Byte, operand: String) = addInstIntOperand(opcode, operand.toInt)

          while ({ line = in.readLine; line ne null }) line match {
            case PUSH_REGEX(n) if n startsWith "'" =>
              addInstIntOperand(PUSH, unescape(n.substring(1, n.length - 1)).head)
            case PUSH_REGEX(n)    => addInst(PUSH, n)
            case PRTS_REGEX()     => code += PRTS
            case PRTI_REGEX()     => code += PRTI
            case PRTC_REGEX()     => code += PRTC
            case HALT_REGEX()     => code += HALT
            case STORE_REGEX(idx) => addInst(STORE, idx)
            case FETCH_REGEX(idx) => addInst(FETCH, idx)
            case LT_REGEX()       => code += LT
            case GT_REGEX()       => code += GT
            case LE_REGEX()       => code += LE
            case GE_REGEX()       => code += GE
            case NE_REGEX()       => code += NE
            case EQ_REGEX()       => code += EQ
            case JZ_REGEX(disp)   => addInst(JZ, disp)
            case ADD_REGEX()      => code += ADD
            case SUB_REGEX()      => code += SUB
            case MUL_REGEX()      => code += MUL
            case DIV_REGEX()      => code += DIV
            case MOD_REGEX()      => code += MOD
            case AND_REGEX()      => code += AND
            case OR_REGEX()       => code += OR
            case NOT_REGEX()      => code += NOT
            case NEG_REGEX()      => code += NEG
            case JMP_REGEX(disp)  => addInst(JMP, disp)
          }

          new VirtualMachine(code, datasize.toInt, strings)
        case _ => sys.error("expected header")
      }

    in.close
    vm
  }

}

class VirtualMachine(code: IndexedSeq[Byte], datasize: Int, strings: IndexedSeq[String]) {

  import VirtualMachine.Opcodes._

  var pc      = 0
  val stack   = new mutable.ArrayStack[Int]
  val data    = new Array[Int](datasize)
  var running = false

  def getByte = {
    val byte = code(pc) & 0xFF

    pc += 1
    byte
  }

  def getShort = getByte << 8 | getByte

  def getInt = getShort << 16 | getShort

  def pushBoolean(b: Boolean) = stack push (if (b) 1 else 0)

  def popBoolean = if (stack.pop != 0) true else false

  def operator(f: (Int, Int) => Int) = {
    val y = stack.pop

    stack.push(f(stack.pop, y))
  }

  def relation(r: (Int, Int) => Boolean) = {
    val y = stack.pop

    pushBoolean(r(stack.pop, y))
  }

  def connective(c: (Boolean, Boolean) => Boolean) = pushBoolean(c(popBoolean, popBoolean))

  def execute: Unit =
    getByte match {
      case FETCH => stack push data(getInt)
      case STORE => data(getInt) = stack.pop
      case PUSH  => stack push getInt
      case JMP   => pc = pc + getInt
      case JZ    => if (stack.pop == 0) pc = pc + getInt else pc += 4
      case ADD   => operator(_ + _)
      case SUB   => operator(_ - _)
      case MUL   => operator(_ * _)
      case DIV   => operator(_ / _)
      case MOD   => operator(_ % _)
      case LT    => relation(_ < _)
      case GT    => relation(_ > _)
      case LE    => relation(_ <= _)
      case GE    => relation(_ >= _)
      case EQ    => relation(_ == _)
      case NE    => relation(_ != _)
      case AND   => connective(_ && _)
      case OR    => connective(_ || _)
      case NEG   => stack push -stack.pop
      case NOT   => pushBoolean(!popBoolean)
      case PRTC  => print(stack.pop.toChar)
      case PRTI  => print(stack.pop)
      case PRTS  => print(strings(stack.pop))
      case HALT  => running = false
    }

  def run = {
    pc = 0
    stack.clear
    running = true

    for (i <- data.indices) data(i) = 0

    while (running) execute
  }

}

The above code depends on the function unescape() to perform string escape sequence translation. That function is defined in the following separate source file.

package xyz.hyperreal

import java.io.ByteArrayOutputStream

package object rosettacodeCompiler {

  val escapes = "\\\\b|\\\\f|\\\\t|\\\\r|\\\\n|\\\\\\\\|\\\\\"" r

  def unescape(s: String) =
    escapes.replaceAllIn(s, _.matched match {
      case "\\b"  => "\b"
      case "\\f"  => "\f"
      case "\\t"  => "\t"
      case "\\r"  => "\r"
      case "\\n"  => "\n"
      case "\\\\" => "\\"
      case "\\\"" => "\""
    })

  def capture(thunk: => Unit) = {
    val buf = new ByteArrayOutputStream

    Console.withOut(buf)(thunk)
    buf.toString
  }

}

Scheme

The interpreter uses recursion, representing the stack as a list; the stack pointer is the reference to the top of the list. This is a more natural solution in Scheme than a fixed stack array, and removes the danger of stack overflow. Operations on or returning booleans have been adapted to use integers, 0 for false and anything else for true.

All of the "Compiler/Sample programs" are correctly interpreted.

(import (scheme base)
        (scheme char)
        (scheme file)
        (scheme process-context)
        (scheme write)
        (only (srfi 13) string-contains string-delete string-filter 
              string-replace string-tokenize))

(define *word-size* 4)

;; Mappings from operation symbols to internal procedures.
;; We define operations appropriate to virtual machine:
;; e.g. division must return an int, not a rational
;; boolean values are treated as numbers: 0 is false, other is true
(define *unary-ops* 
  (list (cons 'neg (lambda (a) (- a)))
        (cons 'not (lambda (a) (if (zero? a) 1 0)))))
(define *binary-ops* 
  (let ((number-comp (lambda (op) (lambda (a b) (if (op a b) 1 0)))))
    (list (cons 'add +)
          (cons 'sub -)
          (cons 'mul *)
          (cons 'div (lambda (a b) (truncate (/ a b)))) ; int division
          (cons 'mod modulo)
          (cons 'lt (number-comp <))
          (cons 'gt (number-comp >))
          (cons 'le (number-comp <=))
          (cons 'ge (number-comp >=))
          (cons 'eq (lambda (a b) (if (= a b) 1 0)))
          (cons 'ne (lambda (a b) (if (= a b) 0 1)))
          (cons 'and (lambda (a b) ; make "and" work on numbers
                       (if (and (not (zero? a)) (not (zero? b))) 1 0)))
          (cons 'or (lambda (a b) ; make "or" work on numbers
                      (if (or (not (zero? a)) (not (zero? b))) 1 0))))))

;; read information from file, returning vectors for data and strings
;; and a list of the code instructions
(define (read-code filename)
  (define (setup-definitions str)
    (values ; return vectors for (data strings) of required size
      (make-vector (string->number (list-ref str 1)) #f)
      (make-vector (string->number (list-ref str 3)) #f)))
  (define (read-strings strings) ; read constant strings into data structure
    (define (replace-newlines chars) ; replace newlines, obeying \\n
      (cond ((< (length chars) 2) ; finished list
             chars)
            ((and (>= (length chars) 3) ; preserve \\n
                  (char=? #\\ (car chars))
                  (char=? #\\ (cadr chars))
                  (char=? #\n (cadr (cdr chars))))
             (cons (car chars)
                   (cons (cadr chars)
                         (cons (cadr (cdr chars))
                               (replace-newlines (cdr (cdr (cdr chars))))))))
            ((and (char=? #\\ (car chars)) ; replace \n with newline
                  (char=? #\n (cadr chars)))
             (cons #\newline (replace-newlines (cdr (cdr chars)))))
            (else ; keep char and look further
              (cons (car chars) (replace-newlines (cdr chars))))))
    (define (tidy-string str) ; remove quotes, map newlines to actual newlines
      (list->string 
        (replace-newlines 
          (string->list
            (string-delete #\" str))))) ; " (needed to satisfy rosettacode's scheme syntax highlighter)
    ;
    (do ((i 0 (+ i 1)))
      ((= i (vector-length strings)) )
      (vector-set! strings i (tidy-string (read-line)))))
  (define (read-code)
    (define (cleanup-code opn) ; tidy instructions, parsing numbers
      (let ((addr (string->number (car opn)))
            (instr (string->symbol (cadr opn))))
        (cond ((= 2 (length opn))
               (list addr instr))
              ((= 3 (length opn))
               (list addr 
                     instr 
                     (string->number 
                       (string-filter char-numeric? (list-ref opn 2)))))
              (else ; assume length 4, jump instructions
                (list addr instr (string->number (list-ref opn 3)))))))
    ;
    (let loop ((result '()))
      (let ((line (read-line)))
        (if (eof-object? line)
          (reverse (map cleanup-code result))
          (loop (cons (string-tokenize line) result))))))
  ;
  (with-input-from-file 
    filename
    (lambda ()
      (let-values (((data strings)
                    (setup-definitions (string-tokenize (read-line)))))
                  (read-strings strings)
                  (values data 
                          strings 
                          (read-code))))))

;; run the virtual machine
(define (run-program data strings code)
  (define (get-instruction n) 
    (if (assq n code)
      (cdr (assq n code))
      (error "Could not find instruction")))
  ;
  (let loop ((stack '())
             (pc 0))
    (let ((op (get-instruction pc)))
      (case (car op)
        ((fetch)
         (loop (cons (vector-ref data (cadr op)) stack)
               (+ pc 1 *word-size*)))
        ((store)
         (vector-set! data (cadr op) (car stack))
         (loop (cdr stack)
               (+ pc 1 *word-size*)))
        ((push)
         (loop (cons (cadr op) stack)
               (+ pc 1 *word-size*)))
        ((add sub mul div mod lt gt le eq ne and or)
         (let ((instr (assq (car op) *binary-ops*)))
           (if instr
             (loop (cons ((cdr instr) (cadr stack) ; replace top two with result
                                      (car stack))
                         (cdr (cdr stack)))
                   (+ pc 1))
             (error "Unknown binary operation"))))
        ((neg not)
         (let ((instr (assq (car op) *unary-ops*)))
           (if instr
             (loop (cons ((cdr instr) (car stack)) ; replace top with result
                         (cdr stack))
                   (+ pc 1))
             (error "Unknown unary operation"))))
        ((jmp)
         (loop stack
               (cadr op)))
        ((jz)
         (loop (cdr stack)
               (if (zero? (car stack))
                 (cadr op)
                 (+ pc 1 *word-size*))))
        ((prtc)
         (display (integer->char (car stack)))
         (loop (cdr stack)
               (+ pc 1)))
        ((prti)
         (display (car stack))
         (loop (cdr stack)
               (+ pc 1)))
        ((prts)
         (display (vector-ref strings (car stack)))
         (loop (cdr stack)
               (+ pc 1)))
        ((halt)
         #t)))))

;; create and run virtual machine from filename passed on command line
(if (= 2 (length (command-line)))
  (let-values (((data strings code) (read-code (cadr (command-line)))))
              (run-program data strings code))
  (display "Error: pass a .asm filename\n"))

Wren

Translation of: Go
Library: Wren-dynamic
Library: Wren-crypto
Library: Wren-fmt
Library: Wren-ioutil
import "./dynamic" for Enum
import "./crypto" for Bytes
import "./fmt" for Conv
import "./ioutil" for FileUtil

var codes = [
    "fetch",
    "store",
    "push",
    "add",
    "sub",
    "mul",
    "div",
    "mod",
    "lt",
    "gt",
    "le",
    "ge",
    "eq",
    "ne",
    "and",
    "or",
    "neg",
    "not",
    "jmp",
    "jz",
    "prtc",
    "prts",
    "prti",
    "halt"
]

var Code = Enum.create("Code", codes)

var codeMap = {
    "fetch": Code.fetch,
    "store": Code.store,
    "push":  Code.push,
    "add":   Code.add,
    "sub":   Code.sub,
    "mul":   Code.mul,
    "div":   Code.div,
    "mod":   Code.mod,
    "lt":    Code.lt,
    "gt":    Code.gt,
    "le":    Code.le,
    "ge":    Code.ge,
    "eq":    Code.eq,
    "ne":    Code.ne,
    "and":   Code.and,
    "or":    Code.or,
    "neg":   Code.neg,
    "not":   Code.not,
    "jmp":   Code.jmp,
    "jz":    Code.jz,
    "prtc":  Code.prtc,
    "prts":  Code.prts,
    "prti":  Code.prti,
    "halt":  Code.halt
}

var object     = []
var stringPool = []

var reportError = Fn.new { |msg| Fiber.abort("error : %(msg)") }

var emitByte = Fn.new { |c| object.add(c) }

var emitWord = Fn.new { |n|
    var bs = Bytes.fromIntLE(n)
    for (b in bs) emitByte.call(b)
}

// Converts the 4 bytes starting at object[pc] to an unsigned 32 bit integer
// and thence to a signed 32 bit integer
var toInt32LE = Fn.new { |pc|
    var x = Bytes.toIntLE(object[pc...pc+4])
    if (x >= 2.pow(31)) x = x - 2.pow(32)
    return x
}

/* Virtual Machine interpreter */

var runVM = Fn.new { |dataSize|
    var stack = List.filled(dataSize + 1, 0)
    var pc = 0
    while (true) {
        var op = object[pc]
        pc = pc + 1
        if (op == Code.fetch) {
            var x = toInt32LE.call(pc)
            stack.add(stack[x])
            pc = pc + 4
        } else if (op == Code.store) {
            var x = toInt32LE.call(pc)
            var ln = stack.count
            stack[x] = stack[ln-1]
            stack = stack[0...ln-1]
            pc = pc + 4
        } else if (op == Code.push) {
            var x = toInt32LE.call(pc)
            stack.add(x)
            pc = pc + 4
        } else if (op == Code.add) {
            var ln = stack.count
            stack[ln-2] = stack[ln-2] + stack[ln-1]
            stack = stack[0...ln-1]
        } else if (op == Code.sub) {
            var ln = stack.count
            stack[ln-2] = stack[ln-2] - stack[ln-1]
            stack = stack[0...ln-1]
        } else if (op == Code.mul) {
            var ln = stack.count
            stack[ln-2] = stack[ln-2] * stack[ln-1]
            stack = stack[0...ln-1]
        } else if (op == Code.div) {
            var ln = stack.count
            stack[ln-2] = (stack[ln-2] / stack[ln-1]).truncate
            stack = stack[0...ln-1]
        } else if (op == Code.mod) {
            var ln = stack.count
            stack[ln-2] = stack[ln-2] % stack[ln-1]
            stack = stack[0...ln-1]
        } else if (op == Code.lt) {
            var ln = stack.count
            stack[ln-2] = Conv.btoi(stack[ln-2] < stack[ln-1])
            stack = stack[0...ln-1]
        } else if (op == Code.gt) {
            var ln = stack.count
            stack[ln-2] = Conv.btoi(stack[ln-2] > stack[ln-1])
            stack = stack[0...ln-1]
        } else if (op == Code.le) {
            var ln = stack.count
            stack[ln-2] = Conv.btoi(stack[ln-2] <= stack[ln-1])
            stack = stack[0...ln-1]
        } else if (op == Code.ge) {
            var ln = stack.count
            stack[ln-2] = Conv.btoi(stack[ln-2] >= stack[ln-1])
            stack = stack[0...ln-1]
        } else if (op == Code.eq) {
            var ln = stack.count
            stack[ln-2] = Conv.btoi(stack[ln-2] == stack[ln-1])
            stack = stack[0...ln-1]
        } else if (op == Code.ne) {
            var ln = stack.count
            stack[ln-2] = Conv.btoi(stack[ln-2] != stack[ln-1])
            stack = stack[0...ln-1]
        } else if (op == Code.and) {
            var ln = stack.count
            stack[ln-2] = Conv.btoi(Conv.itob(stack[ln-2]) && Conv.itob(stack[ln-1]))
            stack = stack[0...ln-1]
        } else if (op == Code.or) {
            var ln = stack.count
            stack[ln-2] = Conv.btoi(Conv.itob(stack[ln-2]) || Conv.itob(stack[ln-1]))
            stack = stack[0...ln-1]
        } else if (op == Code.neg) {
            var ln = stack.count
            stack[ln-1] = -stack[ln-1]
        } else if (op == Code.not) {
            var ln = stack.count
            stack[ln-1] = Conv.btoi(!Conv.itob(stack[ln-1]))
        } else if (op == Code.jmp) {
            var x = toInt32LE.call(pc)       
            pc = pc + x
        } else if (op == Code.jz) {
            var ln = stack.count
            var v = stack[ln-1]
            stack = stack[0...ln-1]
            if (v != 0) {
                pc = pc + 4
            } else {
                var x = toInt32LE.call(pc)
                pc = pc + x
            }
        } else if (op == Code.prtc) {
            var ln = stack.count
            System.write(String.fromByte(stack[ln-1]))
            stack = stack[0...ln-1]
        } else if (op == Code.prts) {
            var ln = stack.count
            System.write(stringPool[stack[ln-1]])
            stack = stack[0...ln-1]
        } else if (op == Code.prti) {
            var ln = stack.count
            System.write(stack[ln-1])
            stack = stack[0...ln-1]
        } else if (op == Code.halt) {
            return
        } else {
            reportError.call("Unknown opcode %(op)")
        }
    }
}

var translate = Fn.new { |s|
    var d = ""
    var i = 0
    while (i < s.count) {
        if (s[i] == "\\" && (i+1) < s.count) {
            if (s[i+1] == "n") {
                d = d + "\n"
                i = i + 1
            } else if (s[i+1] == "\\") {
                d = d + "\\"
                i = i + 1
            }
        } else {
            d = d + s[i]
        }
        i = i + 1
    }
    return d
}

var lines = []
var lineCount = 0
var lineNum = 0

var loadCode = Fn.new {
    var dataSize
    var firstLine = true
    while (lineNum < lineCount) {
        var line = lines[lineNum].trimEnd(" \t")
        lineNum = lineNum + 1
        if (line.count == 0) {
            if (firstLine) {
                reportError.call("empty line")
            } else {
                break
            }
        }
        var lineList = line.split(" ").where { |s| s != "" }.toList
        if (firstLine) {
            dataSize = Num.fromString(lineList[1])
            var nStrings = Num.fromString(lineList[3])
            for (i in 0...nStrings) {
                var s = lines[lineNum].trim("\"\n")
                lineNum = lineNum + 1
                stringPool.add(translate.call(s))
            }
            firstLine = false
            continue
        }
        var offset = Num.fromString(lineList[0])
        var instr = lineList[1]
        var opCode = codeMap[instr]
        if (!opCode) {
            reportError.call("Unknown instruction %(instr) at %(opCode)")
        }
        emitByte.call(opCode)
        if (opCode == Code.jmp || opCode == Code.jz) {
            var p = Num.fromString(lineList[3])
            emitWord.call(p - offset - 1)
        } else if (opCode == Code.push) {
            var value = Num.fromString(lineList[2])
            emitWord.call(value)
        } else if (opCode == Code.fetch || opCode == Code.store) {
            var value = Num.fromString(lineList[2].trim("[]"))
            emitWord.call(value)
        }
    }
    return dataSize
}

lines = FileUtil.readLines("codegen.txt")
lineCount = lines.count
runVM.call(loadCode.call())
Output:
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9

Zig

const std = @import("std");

pub const VirtualMachineError = error{OutOfMemory};

pub const VirtualMachine = struct {
    allocator: std.mem.Allocator,
    stack: [stack_size]i32,
    program: std.ArrayList(u8),
    sp: usize, // stack pointer
    pc: usize, // program counter
    string_pool: std.ArrayList([]const u8), // all the strings in the program
    globals: std.ArrayList(i32), // all the variables in the program, they are global
    output: std.ArrayList(u8), // Instead of outputting to stdout, we do it here for better testing.

    const Self = @This();
    const stack_size = 32; // Can be arbitrarily increased/decreased as long as we have enough.
    const word_size = @sizeOf(i32);

    pub fn init(
        allocator: std.mem.Allocator,
        program: std.ArrayList(u8),
        string_pool: std.ArrayList([]const u8),
        globals: std.ArrayList(i32),
    ) Self {
        return VirtualMachine{
            .allocator = allocator,
            .stack = [_]i32{std.math.maxInt(i32)} ** stack_size,
            .program = program,
            .sp = 0,
            .pc = 0,
            .string_pool = string_pool,
            .globals = globals,
            .output = std.ArrayList(u8).init(allocator),
        };
    }

    pub fn interp(self: *Self) VirtualMachineError!void {
        while (true) : (self.pc += 1) {
            switch (@intToEnum(Op, self.program.items[self.pc])) {
                .push => self.push(self.unpackInt()),
                .store => self.globals.items[@intCast(usize, self.unpackInt())] = self.pop(),
                .fetch => self.push(self.globals.items[@intCast(usize, self.unpackInt())]),
                .jmp => self.pc = @intCast(usize, self.unpackInt() - 1),
                .jz => {
                    if (self.pop() == 0) {
                        // -1 because `while` increases it with every iteration.
                        // This doesn't allow to jump to location 0 because we use `usize` for `pc`,
                        // just arbitrary implementation limitation.
                        self.pc = @intCast(usize, self.unpackInt() - 1);
                    } else {
                        self.pc += word_size;
                    }
                },
                .prts => try self.out("{s}", .{self.string_pool.items[@intCast(usize, self.pop())]}),
                .prti => try self.out("{d}", .{self.pop()}),
                .prtc => try self.out("{c}", .{@intCast(u8, self.pop())}),
                .lt => self.binOp(lt),
                .le => self.binOp(le),
                .gt => self.binOp(gt),
                .ge => self.binOp(ge),
                .eq => self.binOp(eq),
                .ne => self.binOp(ne),
                .add => self.binOp(add),
                .mul => self.binOp(mul),
                .sub => self.binOp(sub),
                .div => self.binOp(div),
                .mod => self.binOp(mod),
                .@"and" => self.binOp(@"and"),
                .@"or" => self.binOp(@"or"),
                .not => self.push(@boolToInt(self.pop() == 0)),
                .neg => self.push(-self.pop()),
                .halt => break,
            }
        }
    }

    fn push(self: *Self, n: i32) void {
        self.sp += 1;
        self.stack[self.sp] = n;
    }

    fn pop(self: *Self) i32 {
        std.debug.assert(self.sp != 0);
        self.sp -= 1;
        return self.stack[self.sp + 1];
    }

    fn unpackInt(self: *Self) i32 {
        const arg_ptr = @ptrCast(*[4]u8, self.program.items[self.pc + 1 .. self.pc + 1 + word_size]);
        self.pc += word_size;
        var arg_array = arg_ptr.*;
        const arg = @ptrCast(*i32, @alignCast(@alignOf(i32), &arg_array));
        return arg.*;
    }

    pub fn out(self: *Self, comptime format: []const u8, args: anytype) VirtualMachineError!void {
        try self.output.writer().print(format, args);
    }

    fn binOp(self: *Self, func: fn (a: i32, b: i32) i32) void {
        const a = self.pop();
        const b = self.pop();
        // Note that arguments are in reversed order because this is how we interact with
        // push/pop operations of the stack.
        const result = func(b, a);
        self.push(result);
    }

    fn lt(a: i32, b: i32) i32 {
        return @boolToInt(a < b);
    }
    fn le(a: i32, b: i32) i32 {
        return @boolToInt(a <= b);
    }
    fn gt(a: i32, b: i32) i32 {
        return @boolToInt(a > b);
    }
    fn ge(a: i32, b: i32) i32 {
        return @boolToInt(a >= b);
    }
    fn eq(a: i32, b: i32) i32 {
        return @boolToInt(a == b);
    }
    fn ne(a: i32, b: i32) i32 {
        return @boolToInt(a != b);
    }
    fn add(a: i32, b: i32) i32 {
        return a + b;
    }
    fn sub(a: i32, b: i32) i32 {
        return a - b;
    }
    fn mul(a: i32, b: i32) i32 {
        return a * b;
    }
    fn div(a: i32, b: i32) i32 {
        return @divTrunc(a, b);
    }
    fn mod(a: i32, b: i32) i32 {
        return @mod(a, b);
    }
    fn @"or"(a: i32, b: i32) i32 {
        return @boolToInt((a != 0) or (b != 0));
    }
    fn @"and"(a: i32, b: i32) i32 {
        return @boolToInt((a != 0) and (b != 0));
    }
};

pub fn main() !void {
    var arena = std.heap.ArenaAllocator.init(std.heap.page_allocator);
    defer arena.deinit();
    const allocator = arena.allocator();

    var arg_it = std.process.args();
    _ = try arg_it.next(allocator) orelse unreachable; // program name
    const file_name = arg_it.next(allocator);
    // We accept both files and standard input.
    var file_handle = blk: {
        if (file_name) |file_name_delimited| {
            const fname: []const u8 = try file_name_delimited;
            break :blk try std.fs.cwd().openFile(fname, .{});
        } else {
            break :blk std.io.getStdIn();
        }
    };
    defer file_handle.close();
    const input_content = try file_handle.readToEndAlloc(allocator, std.math.maxInt(usize));

    var string_pool = std.ArrayList([]const u8).init(allocator);
    var globals = std.ArrayList(i32).init(allocator);
    const bytecode = try loadBytecode(allocator, input_content, &string_pool, &globals);
    var vm = VirtualMachine.init(allocator, bytecode, string_pool, globals);
    try vm.interp();
    const result: []const u8 = vm.output.items;
    _ = try std.io.getStdOut().write(result);
}

pub const Op = enum(u8) {
    fetch,
    store,
    push,
    add,
    sub,
    mul,
    div,
    mod,
    lt,
    gt,
    le,
    ge,
    eq,
    ne,
    @"and",
    @"or",
    neg,
    not,
    jmp,
    jz,
    prtc,
    prts,
    prti,
    halt,

    const from_string = std.ComptimeStringMap(Op, .{
        .{ "fetch", .fetch },
        .{ "store", .store },
        .{ "push", .push },
        .{ "add", .add },
        .{ "sub", .sub },
        .{ "mul", .mul },
        .{ "div", .div },
        .{ "mod", .mod },
        .{ "lt", .lt },
        .{ "gt", .gt },
        .{ "le", .le },
        .{ "ge", .ge },
        .{ "eq", .eq },
        .{ "ne", .ne },
        .{ "and", .@"and" },
        .{ "or", .@"or" },
        .{ "neg", .neg },
        .{ "not", .not },
        .{ "jmp", .jmp },
        .{ "jz", .jz },
        .{ "prtc", .prtc },
        .{ "prts", .prts },
        .{ "prti", .prti },
        .{ "halt", .halt },
    });

    pub fn fromString(str: []const u8) Op {
        return from_string.get(str).?;
    }
};

// 100 lines of code to load serialized bytecode, eh
fn loadBytecode(
    allocator: std.mem.Allocator,
    str: []const u8,
    string_pool: *std.ArrayList([]const u8),
    globals: *std.ArrayList(i32),
) !std.ArrayList(u8) {
    var result = std.ArrayList(u8).init(allocator);
    var line_it = std.mem.split(u8, str, "\n");
    while (line_it.next()) |line| {
        if (std.mem.indexOf(u8, line, "halt")) |_| {
            var tok_it = std.mem.tokenize(u8, line, " ");
            const size = try std.fmt.parseInt(usize, tok_it.next().?, 10);
            try result.resize(size + 1);
            break;
        }
    }

    line_it.index = 0;
    const first_line = line_it.next().?;
    const strings_index = std.mem.indexOf(u8, first_line, " Strings: ").?;
    const globals_size = try std.fmt.parseInt(usize, first_line["Datasize: ".len..strings_index], 10);
    const string_pool_size = try std.fmt.parseInt(usize, first_line[strings_index + " Strings: ".len ..], 10);
    try globals.resize(globals_size);
    try string_pool.ensureTotalCapacity(string_pool_size);
    var string_cnt: usize = 0;
    while (string_cnt < string_pool_size) : (string_cnt += 1) {
        const line = line_it.next().?;
        var program_string = try std.ArrayList(u8).initCapacity(allocator, line.len);
        var escaped = false;
        // Skip double quotes
        for (line[1 .. line.len - 1]) |ch| {
            if (escaped) {
                escaped = false;
                switch (ch) {
                    '\\' => try program_string.append('\\'),
                    'n' => try program_string.append('\n'),
                    else => {
                        std.debug.print("unknown escape sequence: {c}\n", .{ch});
                        std.os.exit(1);
                    },
                }
            } else {
                switch (ch) {
                    '\\' => escaped = true,
                    else => try program_string.append(ch),
                }
            }
        }
        try string_pool.append(program_string.items);
    }
    while (line_it.next()) |line| {
        if (line.len == 0) break;

        var tok_it = std.mem.tokenize(u8, line, " ");
        const address = try std.fmt.parseInt(usize, tok_it.next().?, 10);
        const op = Op.fromString(tok_it.next().?);
        result.items[address] = @enumToInt(op);
        switch (op) {
            .fetch, .store => {
                const index_bracketed = tok_it.rest();
                const index = try std.fmt.parseInt(i32, index_bracketed[1 .. index_bracketed.len - 1], 10);
                insertInt(&result, address + 1, index);
            },
            .push => {
                insertInt(&result, address + 1, try std.fmt.parseInt(i32, tok_it.rest(), 10));
            },
            .jmp, .jz => {
                _ = tok_it.next();
                insertInt(&result, address + 1, try std.fmt.parseInt(i32, tok_it.rest(), 10));
            },
            else => {},
        }
    }
    return result;
}

fn insertInt(array: *std.ArrayList(u8), address: usize, n: i32) void {
    const word_size = @sizeOf(i32);
    var i: usize = 0;
    var n_var = n;
    var n_bytes = @ptrCast(*[4]u8, &n_var);
    while (i < word_size) : (i += 1) {
        array.items[@intCast(usize, address + i)] = n_bytes[@intCast(usize, i)];
    }
}

zkl

Translation of: Python

File rvm.zkl:

// This is a little endian machine
const WORD_SIZE=4;
const{ var _n=-1; var[proxy]N=fcn{ _n+=1 } }  // enumerator
const FETCH=N, STORE=N, PUSH=N, ADD=N, SUB=N, MUL=N, DIV=N, MOD=N, 
   LT=N, GT=N, LE=N, GE=N, EQ=N, NE=N, AND=N, OR=N, NEG=N, NOT=N,
   JMP=N, JZ=N, PRTC=N, PRTS=N, PRTI=N, HALT=N;
 
var [const] 
   bops=Dictionary(ADD,'+, SUB,'-, MUL,'*, DIV,'/, MOD,'%, 
		   LT,'<, GT,'>, LE,'<=, GE,'>=, NE,'!=, EQ,'==, NE,'!=),
   strings=List();  // filled in by the loader
;

   // do a binary op
fcn bop(stack,op){ a,b:=stack.pop(),stack.pop(); stack.append(bops[op](b,a)) }

fcn run_vm(code,stackSz){
   stack,pc := List.createLong(stackSz,0), 0;
   while(True){
      op:=code[pc]; pc+=1;
      switch(op){
         case(FETCH){
	    stack.append(stack[code.toLittleEndian(pc,WORD_SIZE,False)]);
            pc+=WORD_SIZE;
	 }
	 case(STORE){
	    stack[code.toLittleEndian(pc,WORD_SIZE)]=stack.pop();
	    pc+=WORD_SIZE;
	 }
         case(PUSH){
	    stack.append(code.toLittleEndian(pc,WORD_SIZE,False));  // signed
	    pc+=WORD_SIZE; 
	 }
	 case(ADD,SUB,MUL,DIV,MOD,LT,GT,LE,GE,EQ,NE) { bop(stack,op) }
	 case(AND){ stack[-2] = stack[-2] and stack[-1]; stack.pop() }
	 case(OR) { stack[-2] = stack[-2] or  stack[-1]; stack.pop() }
	 case(NEG){ stack[-1] = -stack[-1]    }
	 case(NOT){ stack[-1] = not stack[-1] }
	 case(JMP){ pc+=code.toLittleEndian(pc,WORD_SIZE,False); }  // signed
	 case(JZ) {
	    if(stack.pop()) pc+=WORD_SIZE;
	    else            pc+=code.toLittleEndian(pc,WORD_SIZE,False);
	 }
	 case(PRTC){ }	// not implemented
	 case(PRTS){ print(strings[stack.pop()]) }
	 case(PRTI){ print(stack.pop()) }
	 case(HALT){ break }
	 else{ throw(Exception.AssertionError(
		"Bad op code (%d) @%d".fmt(op,pc-1))) }
      }
   }
} 

code:=File(vm.nthArg(0)).read();	// binary code file
    // the string table is prepended to the code: 
    //    66,1 byte len,text, no trailing '\0' needed
while(code[0]==66){	// read the string table
   sz:=code[1];
   strings.append(code[2,sz].text);
   code.del(0,sz+2);
}
run_vm(code,1000);

The binary code file code.bin:

Output:
$ zkl hexDump code.bin 
   0: 42 0a 63 6f 75 6e 74 20 | 69 73 3a 20 42 01 0a 02   B.count is: B...
  16: 01 00 00 00 01 00 00 00 | 00 00 00 00 00 00 02 0a   ................
  32: 00 00 00 08 13 2b 00 00 | 00 02 00 00 00 00 15 00   .....+..........
  48: 00 00 00 00 16 02 01 00 | 00 00 15 00 00 00 00 00   ................
  64: 02 01 00 00 00 03 01 00 | 00 00 00 12 cd ff ff ff   ................
  80: 17
Output:
$ zkl rvm code.bin 
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9