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


import Data.Time.Clock
import Data.List

type Time = Integer
type Sorter a = [a] -> [a]

-- Simple timing function (in microseconds)
timed :: IO a -> IO (a, Time)
timed prog = do
  t0 <- getCurrentTime
  x <- prog
  t1 <- x `seq` getCurrentTime
  return (x, ceiling $ 1000000 * diffUTCTime t1 t0)

-- testing sorting algorithm on a given set
test :: [a] -> Sorter a -> IO [(Int, Time)]
test set srt = mapM (timed . run) ns
  where
    ns = take 15 $ iterate (\x -> (x * 5) `div` 3) 10
    run n = pure $ length $ srt (take n set)

-- sample sets
constant = repeat 1

presorted = [1..]

random = (`mod` 100) <$> iterate step 42
  where
    step x = (x * a + c) `mod` m
    (a, c, m) = (1103515245, 12345, 2^31-1)


NB. extracts from other rosetta code projects
ts=: 6!:2, 7!:2@]
radix =: 3 : 0
256 radix y
:
a=. #{. z =. x #.^:_1 y
e=. (-a) {."0 b =. i.x
x#.1{::(<:@[;([: ; (b, {"1) <@}./. e,]))&>/^:a [ z;~a-1
NB. , ([: ; (b, {:"1) <@(}:"[email protected]:}.)/. e,])^:(#{.z) y,.z
)
bubble=:  (([ (<. , >.) {[email protected]]) , }[email protected]])/^:_
insertion=:((>: # ]) , [ , < #])/
sel=: 1 : 'x # ['
quick=: 3 : 0
 if.  1 >: #y do.  y
 else.
  e=. y{~?#y
  (quick y <sel e),(y =sel e),quick y >sel e
 end.
)
gaps      =: [: }: 1 (1+3*])^:(> {:)^:a:~ #
insert    =: (I.~ {. ]) , [ , ] }.~ I.~
gapinss   =: #@] {. ,@|:@(] insert//.~ #@] $ [email protected][)
shell =: [: ; gapinss &.>/@(< ,~ ]&.>@gaps)
builtin =: /:~

NB. characterization of the sorting algorithms.

sorts =: bubble`insertion`shell`quick`radix`builtin
generators =: #&1`([email protected])`(?.~) NB. data generators

round =: [: <. 1r2&+

ll =: (<_1 0)&{  NB. verb to extract lower left which holds ln data length
lc =: (<_1 1)&{  NB. verb to fetch lower center which holds most recent time

NB. maximum_time characterize ln_start_size
NB. characterize returns a rank 4 matrix with successive indexes for
NB. algorithm, input arrangement, max number of tests in group, length time space
characterize =: 4 : 0
  max_time =. x
  start =. 1 3{.<:y
  for_sort. sorts do.
    for_generator. generators do.                                           NB. limit time  and  paging prevention
      t =: }. (, (, [: ts '[email protected] ([email protected])' , ":@[email protected]^)@>:@ll) ^: ((lc < max_time"_) *. ll < 17"_) ^:_ start
      if. generator -: {.generators do.
        g =. ,:t
      else.
        g =. g,t
      end.
    end.
    if. sort -: {.sorts do.
      s =. ,:g
    else.
      s =. s,g
    end.
  end.
)

NB. character cell graphics

NB. From j phrases 10E. Approximation
d3=: 1&,[email protected][ %.~ ]	NB. a and b such that y is approx. a + b*x

NB. domain and range 0 to 14.
D=:14

plot =: 1 : '(=/ [email protected](u&.(*&(D%<:y))))i.y' NB. function plot size
points =: 4 : '1(<"1|:|.round y*D%~<:x)}0$~2#x'  NB. size points x,:y

show =: [: |. [: '0'&~:@{:} ' ' ,: ":

plt =: 3 : 0
30 plt y NB. default size 30
:
n =. >:i.-# experiments =. <@(#~"1 (0&<)@{.)"2 y
pts =. n +./ .*x&[email protected]>experiments
coef =. d3/@>experiments
(_*pts) + n +./ .*1 0 2|:coef&(p."1) plot x
)


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())
}


function swap(a, i, j){
    var t = a[i]
    a[i] = a[j]
    a[j] = t
}

// Heap Sort

function heap_sort(a){
    var n = a.length

    function heapify(i){
        var t = a[i]
        while (true){
            var l = 2 * i + 1, r = l + 1
            var m = r < n ? (a[l] > a[r] ? l : r) : (l < n ? l : i)
            if (m != i && a[m] > t){
                a[i] = a[m]
                i = m
            }
            else{
                break
            }
        }
        a[i] = t;
    }

    for (let i = Math.floor(n / 2) - 1; i >= 0; i--){
        heapify(i)
    }

    for (let i = n - 1; i >= 1; i--){
        swap(a, 0, i)
        n--
        heapify(0)
    }
}

// Merge Sort

function merge_sort(a){
    var b = new Array(a.length)

    function rec(l, r){
        if (l < r){
            var m = Math.floor((l + r) / 2)
            rec(l, m)
            rec(m + 1, r)

            var i = l, j = m + 1, k = 0;

            while (i <= m && j <= r) b[k++] = (a[i] > a[j] ? a[j++] : a[i++])
            while (j <= r) b[k++] = a[j++]
            while (i <= m) b[k++] = a[i++]

            for (k = l; k <= r; k++){
                a[k] = b[k - l]
            }
        }
    }

    rec(0, a.length-1)
}

// Quick Sort

function quick_sort(a){
    function rec(l, r){
        if (l < r){
            var p = a[l + Math.floor((r - l + 1)*Math.random())]

            var i = l, j = l, k = r
            while (j <= k){
                if (a[j] < p){
                    swap(a, i++, j++)
                }
                else if (a[j] > p){
                    swap(a, j, k--)
                }
                else{
                    j++
                }
            }

            rec(l, i - 1)
            rec(k + 1, r)
        }
    }

    rec(0, a.length - 1)
}

// Shell Sort

function shell_sort(a){
    var n = a.length
    var gaps = [100894, 44842, 19930, 8858, 3937, 1750, 701, 301, 132, 57, 23, 10, 4, 1]

    for (let x of gaps){
        for (let i = x; i < n; i++){
            var t = a[i], j;
            for (j = i; j >= x && a[j - x] > t; j -= x){
                a[j] = a[j - x];
            }
            a[j] = t;
        }
    }
}

// Comb Sort (+ Insertion sort optimization)

function comb_sort(a){
    var n = a.length

    for (let x = n; x >= 10; x = Math.floor(x / 1.3)){
        for (let i = 0; i + x < n; i++){
            if (a[i] > a[i + x]){
                swap(a, i, i + x)
            }
        }
    }

    for (let i = 1; i < n; i++){
        var t = a[i], j;
        for (j = i; j > 0 && a[j - 1] > t; j--){
            a[j] = a[j - 1]
        }
        a[j] = t;
    }
}

// Test

function test(f, g, e){
    var res = ""

    for (let n of e){
        var a = new Array(n)

        var s = 0
        for (let k = 0; k < 10; k++){
            for (let i = 0; i < n; i++){
                a[i] = g(i)
            }

            var start = Date.now()
            f(a)

            s += Date.now() - start
        }

        res += Math.round(s / 10) + "\t"
    }

    return res
}

// Main

var e = [5000, 10000, 100000, 500000, 1000000, 2000000]

var sOut = "Test times in ms\n\nElements\t" + e.join("\t") + "\n\n"

sOut += "*All ones*\n"
sOut += "heap_sort\t" + test(heap_sort, (x => 1), e) + "\n"
sOut += "quick_sort\t" + test(quick_sort, (x => 1), e) + "\n"
sOut += "merge_sort\t" + test(merge_sort, (x => 1), e) + "\n"
sOut += "shell_sort\t" + test(shell_sort, (x => 1), e) + "\n"
sOut += "comb_sort\t" + test(comb_sort, (x => 1), e) + "\n\n"

sOut += "*Sorted*\n"
sOut += "heap_sort\t" + test(heap_sort, (x => x), e) + "\n"
sOut += "quick_sort\t" + test(quick_sort, (x => x), e) + "\n"
sOut += "merge_sort\t" + test(merge_sort, (x => x), e) + "\n"
sOut += "shell_sort\t" + test(shell_sort, (x => x), e) + "\n"
sOut += "comb_sort\t" + test(comb_sort, (x => x), e) + "\n\n"

sOut += "*Random*\n"
sOut += "heap_sort\t" + test(heap_sort, (x => Math.random()), e) + "\n"
sOut += "quick_sort\t" + test(quick_sort, (x => Math.random()), e) + "\n"
sOut += "merge_sort\t" + test(merge_sort, (x => Math.random()), e) + "\n"
sOut += "shell_sort\t" + test(shell_sort, (x => Math.random()), e) + "\n"
sOut += "comb_sort\t" + test(comb_sort, (x => Math.random()), e) + "\n"

console.log(sOut)


# -*- 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


function comparesorts(tosort)
    a = shuffle(["i", "m", "q"])
    iavg = mavg = qavg = 0.0
    for c in a
        if c == "i"
            iavg = sum(i -> @elapsed(sort(tosort, alg=InsertionSort)), 1:100) / 100.0
        elseif c == "m"
            mavg = sum(i -> @elapsed(sort(tosort, alg=MergeSort)), 1:100) / 100.0
        elseif c == "q"
            qavg = sum(i -> @elapsed(sort(tosort, alg=QuickSort)), 1:100) / 100.0
        end
    end
    iavg, mavg, qavg
end

allones = fill(1, 40000)
sequential = collect(1:40000)
randomized = collect(shuffle(1:40000))

comparesorts(allones)
comparesorts(allones)
iavg, mavg, qavg = comparesorts(allones)
println("Average sort times for 40000 ones:")
println("\tinsertion sort:\t$iavg\n\tmerge sort:\t$mavg\n\tquick sort\t$qavg")

comparesorts(sequential)
comparesorts(sequential)
iavg, mavg, qavg = comparesorts(sequential)
println("Average sort times for 40000 presorted:")
println("\tinsertion sort:\t$iavg\n\tmerge sort:\t$mavg\n\tquick sort\t$qavg")

comparesorts(randomized)
comparesorts(randomized)
iavg, mavg, qavg = comparesorts(randomized)
println("Average sort times for 40000 randomized:")
println("\tinsertion sort:\t$iavg\n\tmerge sort:\t$mavg\n\tquick sort\t$qavg")


// Version 1.2.31

import java.util.Random
import kotlin.system.measureNanoTime

typealias Sorter = (IntArray) -> Unit

val rand = Random()

fun onesSeq(n: Int) = IntArray(n) { 1 }

fun ascendingSeq(n: Int) = shuffledSeq(n).sorted().toIntArray()

fun shuffledSeq(n: Int) = IntArray(n) { 1 + rand.nextInt(10 * n) }

fun bubbleSort(a: IntArray) {
    var n = a.size
    do {
        var n2 = 0
        for (i in 1 until n) {
            if (a[i - 1] > a[i]) {
                val tmp = a[i]
                a[i] = a[i - 1]
                a[i - 1] = tmp
                n2 = i
            }
        }
        n = n2
    } while (n != 0)
}

fun insertionSort(a: IntArray) {
    for (index in 1 until a.size) {
        val value = a[index]
        var subIndex = index - 1
        while (subIndex >= 0 && a[subIndex] > value) {
            a[subIndex + 1] = a[subIndex]
            subIndex--
        }
        a[subIndex + 1] = value
    }
}

fun quickSort(a: IntArray) {
    fun sorter(first: Int, last: Int) {
        if (last - first < 1) return
        val pivot = a[first + (last - first) / 2]
        var left = first
        var right = last
        while (left <= right) {
            while (a[left] < pivot) left++
            while (a[right] > pivot) right--
            if (left <= right) {
                val tmp = a[left]
                a[left] = a[right]
                a[right] = tmp
                left++
                right--
            }
        }
        if (first < right) sorter(first, right)
        if (left < last) sorter(left, last)
    }
    sorter(0, a.lastIndex)
}

fun radixSort(a: IntArray) {
    val tmp = IntArray(a.size)
    for (shift in 31 downTo 0) {
        tmp.fill(0)
        var j = 0
        for (i in 0 until a.size) {
            val move = (a[i] shl shift) >= 0
            val toBeMoved = if (shift == 0) !move else move
            if (toBeMoved)
                tmp[j++] = a[i]
            else {
                a[i - j] = a[i]
            }
        }
        for (i in j until tmp.size) tmp[i] = a[i - j]
        for (i in 0 until a.size) a[i] = tmp[i]
    }
}

val gaps = listOf(701, 301, 132, 57, 23, 10, 4, 1)  // Marcin Ciura's gap sequence

fun shellSort(a: IntArray) {
    for (gap in gaps) {
        for (i in gap until a.size) {
            val temp = a[i]
            var j = i
            while (j >= gap && a[j - gap] > temp) {
                a[j] = a[j - gap]
                j -= gap
            }
            a[j] = temp
        }
    }
}

fun main(args: Array<String>) {
    val runs = 10
    val lengths = listOf(1, 10, 100, 1_000, 10_000, 100_000)
    val sorts = listOf<Sorter>(
        ::bubbleSort, ::insertionSort, ::quickSort, ::radixSort, ::shellSort
    )

    /* allow JVM to compile sort functions before timings start */
    for (sort in sorts) sort(intArrayOf(1))

    val sortTitles = listOf("Bubble", "Insert", "Quick ", "Radix ", "Shell ")
    val seqTitles = listOf("All Ones", "Ascending", "Shuffled")
    val totals = List(seqTitles.size) { List(sorts.size) { LongArray(lengths.size) } }
    for ((k, n) in lengths.withIndex()) {
        val seqs = listOf(onesSeq(n), ascendingSeq(n), shuffledSeq(n))
        repeat(runs) {
            for (i in 0 until seqs.size) {
                for (j in 0 until sorts.size) {
                    val seq = seqs[i].copyOf()
                    totals[i][j][k] += measureNanoTime { sorts[j](seq) }
                }
            }
        }
    }
    println("All timings in micro-seconds\n")
    print("Sequence length")
    for (len in lengths) print("%8d   ".format(len))
    println("\n")
    for (i in 0 until seqTitles.size) {
        println("  ${seqTitles[i]}:")
        for (j in 0 until sorts.size) {
            print("    ${sortTitles[j]}     ")
            for (k in 0 until lengths.size) {
                val time = totals[i][j][k] / runs / 1_000
                print("%8d   ".format(time))
            }
            println()
        }
        println("\n")
    }
}


(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=: [email protected](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.
}}


ClearAll[BubbleSort,ShellSort]
BubbleSort[in_List]:=Module[{x=in,l=Length[in],swapped},swapped=True;
 While[swapped,swapped=False;
 Do[If[x[[i]]>x[[i+1]],x[[{i,i+1}]]//=Reverse;
 swapped=True;],{i,l-1}];];
x]
ShellSort[lst_]:=Module[{list=lst,incr,temp,i,j},incr=Round[Length[list]/2];
 While[incr>0,For[i=incr+1,i<=Length[list],i++,temp=list[[i]];j=i;
 While[(j>=(incr+1))&&(list[[j-incr]]>temp),list[[j]]=list[[j-incr]];j=j-incr;];
 list[[j]]=temp;];
 If[incr==2,incr=1,incr=Round[incr/2.2]]];list
]

times=Table[
 arr=ConstantArray[1,n];
 t1={{n,AbsoluteTiming[BubbleSort[arr];][[1]]},{n,AbsoluteTiming[ShellSort[arr];][[1]]}};
 arr=Sort[RandomInteger[{10^6},n]];
 t2={{n,AbsoluteTiming[BubbleSort[arr];][[1]]},{n,AbsoluteTiming[ShellSort[arr];][[1]]}};
 arr=RandomInteger[{10^6},n];
 t3={{n,AbsoluteTiming[BubbleSort[arr];][[1]]},{n,AbsoluteTiming[ShellSort[arr];][[1]]}};
 {t1,t2,t3}
,
 {n,2^Range[13]}
];

ListLogLogPlot[[email protected][[All,1]],PlotLegends->{"Bubble","Shell"},PlotLabel->"Ones"]
ListLogLogPlot[[email protected][[All,2]],PlotLegends->{"Bubble","Shell"},PlotLabel->"Ascending integers"]
ListLogLogPlot[[email protected][[All,3]],PlotLegends->{"Bubble","Shell"},PlotLabel->"Shuffled"]


-- demo\rosetta\Compare_sorting_algorithms.exw
constant XQS = 01  -- (set to 1 to exclude quick_sort and shell_sort from ones)

include pGUI.e

Ihandle dlg, tabs, plot
Ihandles plots

function quick_sort2(sequence x)
    integer n = length(x)
    if n<2 then
        return x    -- already sorted (trivial case)
    end if
    integer mid = floor((n+1)/2),
            midn = 1
    object  midval = x[mid]
    sequence left = {}, right = {}
    x[mid] = x[1]
    for i=2 to n do
        object xi = x[i]
        integer c = compare(xi,midval)
        if c<0 then
            left = append(left,xi)
        elsif c>0 then
            right = append(right,xi)
        else
            midn += 1
        end if
    end for

    return quick_sort2(left) & repeat(midval,midn) & quick_sort2(right)
end function

function quick_sort(sequence s)
    sequence qstack = repeat(0,floor((length(s)/5)+10))   -- create a stack
    integer first = 1,
            last = length(s),
            stackptr = 0
    while true do
        while first<last do
            object pivot = s[floor(last+first)/2],
                   si, sj
            integer I = first,
                    J = last
            while true do
                while true do
                    si = s[I]
                    if si>=pivot then exit end if
                    I += 1
                end while
                while true do
                    sj = s[J]
                    if sj<=pivot then exit end if
                    J -= 1
                end while
                if I>J then exit end if
                if I<J then
                    if si=sj then
                        {I,J} = {J+1,I-1}
                        exit
                    end if
                    s[I] = sj
                    s[J] = si
                end if
                I += 1
                J -= 1
                if I>J then exit end if
            end while
            if I<last then
                qstack[stackptr+1] = I
                qstack[stackptr+2] = last
                stackptr += 2
            end if
            last = J
        end while
        if stackptr=0 then exit end if
        stackptr -= 2
        first = qstack[stackptr+1]
        last = qstack[stackptr+2]
    end while
    return s
end function

function radixSortn(sequence s, integer n)
    sequence buckets = repeat({},10)
    sequence res = {}
    for i=1 to length(s) do
        integer digit = remainder(floor(s[i]/power(10,n-1)),10)+1
        buckets[digit] = append(buckets[digit],s[i])
    end for
    for i=1 to length(buckets) do
        integer len = length(buckets[i])
        if len!=0 then
            if len=1 or n=1 then
                res &= buckets[i]
            else
                res &= radixSortn(buckets[i],n-1)
            end if
        end if
    end for
    return res
end function

function split_by_sign(sequence s)
    sequence buckets = {{},{}}
    for i=1 to length(s) do
        integer si = s[i]
        if si<0 then
            buckets[1] = append(buckets[1],-si)
        else
            buckets[2] = append(buckets[2],si)
        end if
    end for
    return buckets
end function

function radix_sort(sequence s)
-- NB this is an integer-only sort
    integer mins = min(s),
            passes = floor(log10(max(max(s),abs(mins))))+1
    if mins<0 then
        sequence buckets = split_by_sign(s)
        buckets[1] = reverse(sq_uminus(radixSortn(buckets[1],passes)))
        buckets[2] = radixSortn(buckets[2],passes)
        s = buckets[1]&buckets[2]
    else
        s = radixSortn(s,passes)
    end if
    return s
end function

function shell_sort(sequence s)
    integer gap = floor(length(s)/2)
    while gap>0 do
        for i=gap to length(s) do
            object temp = s[i]
            integer j = i-gap
            while j>=1 and temp<=s[j] do
                s[j+gap] = s[j]
                j -= gap
            end while
            s[j+gap] = temp
        end for
        gap = floor(gap/2)
    end while
    return s
end function

function shell_sort2(sequence x)
    integer last = length(x),
            gap = floor(last/10)+1
    while TRUE do
        integer first = gap+1
        for i=first to last do
            object xi = x[i]
            integer j = i-gap
            while TRUE do
                object xj = x[j]
                if xi>=xj then
                    j += gap
                    exit
                end if
                x[j+gap] = xj
                if j<=gap then
                    exit
                end if
                j -= gap
            end while
            x[j] = xi
        end for
        if gap=1 then
            return x
        else
            gap = floor(gap/3.5)+1
        end if
    end while
end function

function siftDown(sequence arr, integer s, integer last)
    integer root = s
    while root*2<=last do
        integer child = root*2
        if child<last and arr[child]<arr[child+1] then
            child += 1
        end if
        if arr[root]>=arr[child] then exit end if
        object tmp = arr[root]
        arr[root] = arr[child]
        arr[child] = tmp
        root = child
    end while
    return arr
end function

function heapify(sequence arr, integer count)
    integer s = floor(count/2)
    while s>0 do
        arr = siftDown(arr,s,count)
        s -= 1
    end while
    return arr
end function

function heap_sort(sequence arr)
    integer last = length(arr)
    arr = heapify(arr,last)
    while last>1 do
        object tmp = arr[1]
        arr[1] = arr[last]
        arr[last] = tmp
        last -= 1
        arr = siftDown(arr,1,last)
    end while
    return arr
end function

include builtins/sort.e

enum ONES = 1, SORTED = 2, RANDOM = 3, REVERSE = 4

constant tabtitles = {"ones","sorted","random","reverse"}
integer tabidx = 3

integer STEP

function tr(sequence name, integer rid=routine_id(name))
    return {name,rid}
end function

constant tests = {tr("quick_sort"),
                  tr("quick_sort2"),
                  tr("radix_sort"),
                  tr("shell_sort"),
                  tr("shell_sort2"),
                  tr("heap_sort"),
                  tr("sort"),           -- builtin
                 }

sequence results = repeat(repeat({}, length(tests)),length(tabtitles))

sequence dsdx = repeat(repeat(0,length(tests)),length(tabtitles))

integer ds_index

function idle_action_cb()
    atom best = -1, -- fastest last
         besti = 0, -- 1..length(tests)
         bestt = 0, -- 1..length(tabtitles)
         len
    --
    -- Search for something to do, active/visible tab first.
    -- Any result set of length 0 -> just do one.
    -- Of all result sets<8, pick the lowest [$].
    --
    sequence todo = {tabidx}
    for t=1 to length(tabtitles) do
        if t!=tabidx then todo &= t end if
    end for

    for t=1 to length(tabtitles) do
        integer ti = todo[t]
        for i=1 to length(results[ti]) do
            len = length(results[ti][i])
            if len=0 then
                best = 0
                besti = i
                bestt = ti
                exit
            elsif len<8 then
                if (best=-1) or (best>results[ti][i][$]) then
                    best = results[ti][i][$]
                    besti = i
                    bestt = ti
                end if
            end if
        end for
        if (t=1) and (besti!=0) then exit end if
    end for
    if best>10 then
        -- cop out if it is getting too slow
        besti = 0
    end if
    if besti!=0 then
        STEP = iff(not XQS and bestt=ONES?1000:100000)
        len = (length(results[bestt][besti])+1)*STEP
        sequence test = iff(bestt=ONES?repeat(1,len):
                        iff(bestt=SORTED?tagset(len):
                        iff(bestt=RANDOM?shuffle(tagset(len)):
                        iff(bestt=REVERSE?reverse(tagset(len)):9/0))))
        ds_index = dsdx[bestt][besti]
        atom t0 = time()
        sequence check = call_func(tests[besti][2],{test})
        t0 = time()-t0
--      if check!=sort(test) then ?9/0 end if
        plot = plots[bestt]
        IupPlotInsert(plot, ds_index, -1, len, t0)
        results[bestt][besti] = append(results[bestt][besti],t0)
        IupSetAttribute(plot,"REDRAW",NULL)
        sequence progress = {bestt}
        for i=1 to length(results[bestt]) do
            progress &= length(results[bestt][i])
        end for
        IupSetStrAttribute(dlg,"TITLE","Compare sorting algorithms %s",{sprint(progress)})
        return IUP_CONTINUE
    end if
    IupSetAttribute(dlg,"TITLE","Compare sorting algorithms (all done, idle)")
    return IUP_IGNORE   -- all done, remove callback
end function
constant cb_idle_action = Icallback("idle_action_cb")

function tabchange_cb(Ihandle /*self*/, Ihandle /*new_tab*/)
    tabidx = IupGetInt(tabs,"VALUEPOS")+1
    plot = plots[tabidx]
    return IUP_DEFAULT;
end function

procedure main()
    IupOpen()

    plots = {}
    for i=1 to length(tabtitles) do
        if XQS then
--          results[ONES][1] = repeat(0,8)
            results[ONES][4] = repeat(0,8)
        end if
        plot = IupPlot()
        IupSetAttribute(plot,"MENUITEMPROPERTIES","YES")
        IupSetAttribute(plot,"TABTITLE",tabtitles[i])
        IupSetAttribute(plot,"GRID","YES")
        IupSetAttribute(plot,"MARGINLEFT","50")
        IupSetAttribute(plot,"MARGINBOTTOM","40")
        IupSetAttribute(plot,"LEGEND","YES")
        IupSetAttribute(plot,"LEGENDPOS","TOPLEFT")
--      IupSetAttribute(plot,"AXS_YSCALE","LOG10")
--      IupSetAttribute(plot,"AXS_XSCALE","LOG10")
        for j=1 to length(tests) do
            IupPlotBegin(plot)
            dsdx[i][j] = IupPlotEnd(plot)
            IupSetAttribute(plot,"DS_NAME",tests[j][1])
        end for
        plots = append(plots,plot)
    end for
    tabs = IupTabs(plots)
    IupSetCallback(tabs, "TABCHANGE_CB", Icallback("tabchange_cb"))
    dlg = IupDialog(tabs, "RASTERSIZE=800x480")
    IupSetAttribute(dlg, "TITLE", "Compare sorting algorithms")
    IupShow(dlg)
    IupSetInt(tabs, "VALUEPOS", tabidx-1)
    IupSetGlobalFunction("IDLE_ACTION", cb_idle_action)
    if platform()!=JS then
        IupMainLoop()
        IupClose()
    end if
end procedure

main()


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)


def builtinsort(x):
    x.sort()

def partition(seq, pivot):
   low, middle, up = [], [], []
   for x in seq:
       if x < pivot:
           low.append(x)
       elif x == pivot:
           middle.append(x)
       else:
           up.append(x)
   return low, middle, up
import random
def qsortranpart(seq):
   size = len(seq)
   if size < 2: return seq
   low, middle, up = partition(seq, random.choice(seq))
   return qsortranpart(low) + middle + qsortranpart(up)