A virtual machine implements a computer in software.

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

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

Input format:

Given the following program:

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

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



 Output from gen, input to VM



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

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

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

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

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

Registers:

sp:

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

pc:

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

Data:

   data
   string pool

Instructions:

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

fetch [index]

where index is an index into the data array.

store [index]

where index is an index into the data array.

push n

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

jmp (n) addr

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

jz (n) addr

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

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

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

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

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

neg
not

Print the word at stack top as a character.

prtc

Print the word at stack top as an integer.

prti

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

prts

Unconditional stop.

halt

 A simple example virtual machine

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

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

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

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