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

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

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

  character(1, kind = ck), parameter :: 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

end module helper_procedures

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 :: helper_procedures

  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 ast_reader

  !
  ! The AST will be read into an array. Perhaps that will improve
  ! locality, compared to storing the AST as many linked heap nodes.
  !
  ! In any case, implementing the AST this way is an interesting
  ! problem.
  !

  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, only: nk, ck, ick, rik
  use, non_intrinsic :: helper_procedures, only: next_power_of_two
  use, non_intrinsic :: helper_procedures, only: new_storage_size
  use, non_intrinsic :: string_buffers
  use, non_intrinsic :: reading_one_line_from_a_stream

  implicit none
  private

  public :: string_table_t
  public :: ast_node_t
  public :: ast_t
  public :: read_ast

  integer, parameter, public :: node_Nil = 0
  integer, parameter, public :: node_Identifier = 1
  integer, parameter, public :: node_String = 2
  integer, parameter, public :: node_Integer = 3
  integer, parameter, public :: node_Sequence = 4
  integer, parameter, public :: node_If = 5
  integer, parameter, public :: node_Prtc = 6
  integer, parameter, public :: node_Prts = 7
  integer, parameter, public :: node_Prti = 8
  integer, parameter, public :: node_While = 9
  integer, parameter, public :: node_Assign = 10
  integer, parameter, public :: node_Negate = 11
  integer, parameter, public :: node_Not = 12
  integer, parameter, public :: node_Multiply = 13
  integer, parameter, public :: node_Divide = 14
  integer, parameter, public :: node_Mod = 15
  integer, parameter, public :: node_Add = 16
  integer, parameter, public :: node_Subtract = 17
  integer, parameter, public :: node_Less = 18
  integer, parameter, public :: node_LessEqual = 19
  integer, parameter, public :: node_Greater = 20
  integer, parameter, public :: node_GreaterEqual = 21
  integer, parameter, public :: node_Equal = 22
  integer, parameter, public :: node_NotEqual = 23
  integer, parameter, public :: node_And = 24
  integer, parameter, public :: node_Or = 25

  type :: string_table_element_t
     character(:, kind = ck), allocatable :: str
  end type string_table_element_t

  type :: string_table_t
     integer(kind = nk), private :: len = 0_nk
     type(string_table_element_t), allocatable, private :: strings(:)
   contains
     procedure, pass, private :: ensure_storage => string_table_t_ensure_storage
     procedure, pass :: look_up_index => string_table_t_look_up_index
     procedure, pass :: look_up_string => string_table_t_look_up_string
     procedure, pass :: length => string_table_t_length
     generic :: look_up => look_up_index
     generic :: look_up => look_up_string
  end type string_table_t

  type :: ast_node_t
     integer :: node_variety

     ! Runtime integer, symbol index, or string index.
     integer(kind = rik) :: int

     ! The left branch begins at the next node. The right branch
     ! begins at the address of the left branch, plus the following.
     integer(kind = nk) :: right_branch_offset
  end type ast_node_t

  type :: ast_t
     integer(kind = nk), private :: len = 0_nk
     type(ast_node_t), allocatable, public :: nodes(:)
   contains
     procedure, pass, private :: ensure_storage => ast_t_ensure_storage
  end type ast_t

contains

  subroutine string_table_t_ensure_storage (table, length_needed)
    class(string_table_t), intent(inout) :: table
    integer(kind = nk), intent(in) :: length_needed

    integer(kind = nk) :: len_needed
    integer(kind = nk) :: new_size
    type(string_table_t) :: new_table

    len_needed = max (length_needed, 1_nk)

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

  elemental function string_table_t_length (table) result (len)
    class(string_table_t), intent(in) :: table
    integer(kind = nk) :: len

    len = table%len
  end function string_table_t_length

  function string_table_t_look_up_index (table, str) result (index)
    class(string_table_t), intent(inout) :: table
    character(*, kind = ck), intent(in) :: str
    integer(kind = rik) :: index

    !
    ! This implementation simply stores the strings sequentially into
    ! an array. Obviously, for large numbers of strings, one might
    ! wish to do something more complex.
    !
    ! Standard Fortran does not come, out of the box, with a massive
    ! runtime library for doing such things. They are, however, no
    ! longer nearly as challenging to implement in Fortran as they
    ! used to be.
    !

    integer(kind = nk) :: i

    i = 1
    index = 0
    do while (index == 0)
       if (i == table%len + 1) then
          ! The string is new and must be added to the table.
          i = table%len + 1
          if (huge (1_rik) < i) then
             ! String indices are assumed to be storable as runtime
             ! integers.
             write (error_unit, '("string_table_t capacity exceeded")')
             stop 1
          end if
          call table%ensure_storage(i)
          table%len = i
          allocate (table%strings(i)%str, source = str)
          index = int (i, kind = rik)
       else if (table%strings(i)%str == str) then
          index = int (i, kind = rik)
       else
          i = i + 1
       end if
    end do
  end function string_table_t_look_up_index

  function string_table_t_look_up_string (table, index) result (str)
    class(string_table_t), intent(inout) :: table
    integer(kind = rik), intent(in) :: index
    character(:, kind = ck), allocatable :: str

    !
    ! This is the reverse of string_table_t_look_up_index: given an
    ! index, find the string.
    !

    if (index < 1 .or. table%len < index) then
       ! In correct code, this branch should never be reached.
       error stop
    else
       allocate (str, source = table%strings(index)%str)
    end if
  end function string_table_t_look_up_string

  subroutine ast_t_ensure_storage (ast, length_needed)
    class(ast_t), intent(inout) :: ast
    integer(kind = nk), intent(in) :: length_needed

    integer(kind = nk) :: len_needed
    integer(kind = nk) :: new_size
    type(ast_t) :: new_ast

    len_needed = max (length_needed, 1_nk)

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

  subroutine read_ast (unit_no, strbuf, ast, symtab, strtab)
    integer, intent(in) :: unit_no
    type(strbuf_t), intent(inout) :: strbuf
    type(ast_t), intent(inout) :: ast
    type(string_table_t), intent(inout) :: symtab
    type(string_table_t), intent(inout) :: strtab

    logical :: eof
    logical :: no_newline
    integer(kind = nk) :: after_ast_address

    ast%len = 0
    symtab%len = 0
    strtab%len = 0
    call build_subtree (1_nk, after_ast_address)

  contains

    recursive subroutine build_subtree (here_address, after_subtree_address)
      integer(kind = nk), value :: here_address
      integer(kind = nk), intent(out) :: after_subtree_address

      integer :: node_variety
      integer(kind = nk) :: i, j
      integer(kind = nk) :: left_branch_address
      integer(kind = nk) :: right_branch_address

      ! Get a line from the parser output.
      call get_line_from_stream (unit_no, eof, no_newline, strbuf)

      if (eof) then
         call ast_error
      else
         ! Prepare to store a new node.
         call ast%ensure_storage(here_address)
         ast%len = here_address

         ! What sort of node is it?
         i = skip_whitespace (strbuf, 1_nk)
         j = skip_non_whitespace (strbuf, i)
         node_variety = strbuf_to_node_variety (strbuf, i, j - 1)

         ast%nodes(here_address)%node_variety = node_variety

         select case (node_variety)
         case (node_Nil)
            after_subtree_address = here_address + 1
         case (node_Identifier)
            i = skip_whitespace (strbuf, j)
            j = skip_non_whitespace (strbuf, i)
            ast%nodes(here_address)%int = &
                 &   strbuf_to_symbol_index (strbuf, i, j - 1, symtab)
            after_subtree_address = here_address + 1
         case (node_String)
            i = skip_whitespace (strbuf, j)
            j = skip_whitespace_backwards (strbuf, strbuf%length())
            ast%nodes(here_address)%int = &
                 &   strbuf_to_string_index (strbuf, i, j, strtab)
            after_subtree_address = here_address + 1
         case (node_Integer)
            i = skip_whitespace (strbuf, j)
            j = skip_non_whitespace (strbuf, i)
            ast%nodes(here_address)%int = strbuf_to_int (strbuf, i, j - 1)
            after_subtree_address = here_address + 1
         case default
            ! The node is internal, and has left and right branches.
            ! The left branch will start at left_branch_address; the
            ! right branch will start at left_branch_address +
            ! right_side_offset.
            left_branch_address = here_address + 1
            ! Build the left branch.
            call build_subtree (left_branch_address, right_branch_address)
            ! Build the right_branch.
            call build_subtree (right_branch_address, after_subtree_address)
            ast%nodes(here_address)%right_branch_offset = &
                 &   right_branch_address - left_branch_address
         end select

      end if
    end subroutine build_subtree

  end subroutine read_ast

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

    !
    ! This function has not been optimized in any way, unless the
    ! Fortran compiler can optimize it.
    !
    ! Something like a ‘radix tree search’ could be done on the
    ! characters of the strbuf. Or a perfect hash function. Or a
    ! binary search. Etc.
    !

    if (j == i - 1) then
       call ast_error
    else
       select case (strbuf%to_unicode(i, j))
       case (ck_";")
          node_variety = node_Nil
       case (ck_"Identifier")
          node_variety = node_Identifier
       case (ck_"String")
          node_variety = node_String
       case (ck_"Integer")
          node_variety = node_Integer
       case (ck_"Sequence")
          node_variety = node_Sequence
       case (ck_"If")
          node_variety = node_If
       case (ck_"Prtc")
          node_variety = node_Prtc
       case (ck_"Prts")
          node_variety = node_Prts
       case (ck_"Prti")
          node_variety = node_Prti
       case (ck_"While")
          node_variety = node_While
       case (ck_"Assign")
          node_variety = node_Assign
       case (ck_"Negate")
          node_variety = node_Negate
       case (ck_"Not")
          node_variety = node_Not
       case (ck_"Multiply")
          node_variety = node_Multiply
       case (ck_"Divide")
          node_variety = node_Divide
       case (ck_"Mod")
          node_variety = node_Mod
       case (ck_"Add")
          node_variety = node_Add
       case (ck_"Subtract")
          node_variety = node_Subtract
       case (ck_"Less")
          node_variety = node_Less
       case (ck_"LessEqual")
          node_variety = node_LessEqual
       case (ck_"Greater")
          node_variety = node_Greater
       case (ck_"GreaterEqual")
          node_variety = node_GreaterEqual
       case (ck_"Equal")
          node_variety = node_Equal
       case (ck_"NotEqual")
          node_variety = node_NotEqual
       case (ck_"And")
          node_variety = node_And
       case (ck_"Or")
          node_variety = node_Or
       case default
          call ast_error
       end select
    end if
  end function strbuf_to_node_variety

  function strbuf_to_symbol_index (strbuf, i, j, symtab) result (int)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i, j
    type(string_table_t), intent(inout) :: symtab
    integer(kind = rik) :: int

    if (j == i - 1) then
       call ast_error
    else
       int = symtab%look_up(strbuf%to_unicode (i, j))
    end if
  end function strbuf_to_symbol_index

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

    integer :: stat
    character(:, kind = ck), allocatable :: str

    if (j < i) then
       call ast_error
    else
       allocate (character(len = (j - i) + 1_nk, kind = ck) :: str)
       str = strbuf%to_unicode (i, j)
       read (str, *, iostat = stat) int
       if (stat /= 0) then
          call ast_error
       end if
    end if
  end function strbuf_to_int

  function strbuf_to_string_index (strbuf, i, j, strtab) result (int)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i, j
    type(string_table_t), intent(inout) :: strtab
    integer(kind = rik) :: int

    if (j == i - 1) then
       call ast_error
    else
       int = strtab%look_up(strbuf_to_string (strbuf, i, j))
    end if
  end function strbuf_to_string_index

  function strbuf_to_string (strbuf, i, j) result (str)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i, j
    character(:, kind = ck), allocatable :: str

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

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

    integer(kind = nk) :: k
    integer(kind = nk) :: count

    if (strbuf%chars(i) /= ck_'"' .or. strbuf%chars(j) /= ck_'"') then
       call ast_error
    else
       ! Count how many characters are needed.
       count = 0
       k = i + 1
       do while (k < j)
          count = count + 1
          if (strbuf%chars(k) == backslash_char) then
             k = k + 2
          else
             k = k + 1
          end if
       end do

       allocate (character(len = count, kind = ck) :: str)

       count = 0
       k = i + 1
       do while (k < j)
          if (strbuf%chars(k) == backslash_char) then
             if (k == j - 1) then
                call ast_error
             else
                select case (strbuf%chars(k + 1))
                case (ck_'n')
                   count = count + 1
                   str(count:count) = newline_char
                case (backslash_char)
                   count = count + 1
                   str(count:count) = backslash_char
                case default
                   call ast_error
                end select
                k = k + 2
             end if
          else
             count = count + 1
             str(count:count) = strbuf%chars(k)
             k = k + 1
          end if
       end do
    end if
  end function strbuf_to_string

  subroutine ast_error
    !
    ! It might be desirable to give more detail.
    !
    write (error_unit, '("The AST input seems corrupted.")')
    stop 1
  end subroutine ast_error

end module ast_reader

module code_generation

  !
  ! First we generate code as if the virtual machine itself were part
  ! of this program. Then we disassemble the generated code.
  !
  ! Because we are targeting only the one output language, this seems
  ! an easy way to perform the task.
  !
  !
  ! A point worth noting: the virtual machine is a stack
  ! architecture.
  !
  ! Stack architectures have a long history. Burroughs famously
  ! preferred stack architectures for running Algol programs. See, for
  ! instance,
  ! https://en.wikipedia.org/w/index.php?title=Burroughs_large_systems&oldid=1068076420
  !

  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 :: helper_procedures
  use, non_intrinsic :: ast_reader

  implicit none
  private

  public :: generate_and_output_code
  public :: generate_code
  public :: output_code

  ! The virtual machine cannot handle integers of more than 32 bits,
  ! two’s-complement.
  integer(kind = rik), parameter :: vm_huge_negint = -(2_rik ** 31_rik)
  integer(kind = rik), parameter :: vm_huge_posint = (2_rik ** 31_rik) - 1_rik

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

  character(8, kind = ck), parameter :: 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

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 generate_and_output_code (outp, ast, symtab, strtab)
    integer, intent(in) :: outp ! The unit to write the output to.
    type(ast_t), intent(in) :: ast
    type(string_table_t), intent(inout) :: symtab
    type(string_table_t), intent(inout) :: strtab

    type(vm_code_t) :: code
    integer(kind = rik) :: i_vm

    code%len = 0
    i_vm = 0_rik
    call generate_code (ast, 1_nk, i_vm, code)
    call output_code (outp, symtab, strtab, code)
  end subroutine generate_and_output_code

  subroutine generate_code (ast, i_ast, i_vm, code)
    type(ast_t), intent(in) :: ast
    integer(kind = nk), intent(in) :: i_ast ! Index in the ast array.
    integer(kind = rik), intent(inout) :: i_vm ! Address in the virtual machine.
    type(vm_code_t), intent(inout) :: code

    call traverse (i_ast)

    ! Generate a halt instruction.
    call code%ensure_storage(i_vm + 1)
    code%bytes(i_vm) = achar (opcode_halt)
    i_vm = i_vm + 1

    code%len = i_vm

  contains

    recursive subroutine traverse (i_ast)
      integer(kind = nk), intent(in) :: i_ast ! Index in the ast array.

      select case (ast%nodes(i_ast)%node_variety)

      case (node_Nil)
         continue

      case (node_Integer)
         block
           integer(kind = rik) :: int_value

           int_value = ast%nodes(i_ast)%int
           call ensure_integer_is_vm_compatible (int_value)
           call code%ensure_storage(i_vm + 5)
           code%bytes(i_vm) = achar (opcode_push)
           call int32_to_vm_bytes (int_value, code%bytes, i_vm + 1)
           i_vm = i_vm + 5
         end block

      case (node_Identifier)
         block
           integer(kind = rik) :: variable_index

           ! In the best Fortran tradition, we indexed the variables
           ! starting at one; however, the virtual machine starts them
           ! at zero. So subtract 1.
           variable_index = ast%nodes(i_ast)%int - 1

           call ensure_integer_is_vm_compatible (variable_index)
           call code%ensure_storage(i_vm + 5)
           code%bytes(i_vm) = achar (opcode_fetch)
           call uint32_to_vm_bytes (variable_index, code%bytes, i_vm + 1)
           i_vm = i_vm + 5
         end block

      case (node_String)
         block
           integer(kind = rik) :: string_index

           ! In the best Fortran tradition, we indexed the strings
           ! starting at one; however, the virtual machine starts them
           ! at zero. So subtract 1.
           string_index = ast%nodes(i_ast)%int - 1

           call ensure_integer_is_vm_compatible (string_index)
           call code%ensure_storage(i_vm + 5)
           code%bytes(i_vm) = achar (opcode_push)
           call uint32_to_vm_bytes (string_index, code%bytes, i_vm + 1)
           i_vm = i_vm + 5
         end block

      case (node_Assign)
         block
           integer(kind = nk) :: i_left, i_right
           integer(kind = rik) :: variable_index

           i_left = left_branch (i_ast)
           i_right = right_branch (i_ast)

           ! In the best Fortran tradition, we indexed the variables
           ! starting at one; however, the virtual machine starts them
           ! at zero. So subtract 1.
           variable_index = ast%nodes(i_left)%int - 1

           ! Create code to push the right side onto the stack
           call traverse (i_right)

           ! Create code to store that result into the variable on the
           ! left side.
           call ensure_node_variety (node_Identifier, ast%nodes(i_left)%node_variety)
           call ensure_integer_is_vm_compatible (variable_index)
           call code%ensure_storage(i_vm + 5)
           code%bytes(i_vm) = achar (opcode_store)
           call uint32_to_vm_bytes (variable_index, code%bytes, i_vm + 1)
           i_vm = i_vm + 5
         end block

      case (node_Multiply)
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_mul)
         i_vm = i_vm + 1

      case (node_Divide)
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_div)
         i_vm = i_vm + 1

      case (node_Mod)
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_mod)
         i_vm = i_vm + 1

      case (node_Add)
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_add)
         i_vm = i_vm + 1

      case (node_Subtract)
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_sub)
         i_vm = i_vm + 1

      case (node_Less)
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_lt)
         i_vm = i_vm + 1

      case (node_LessEqual)
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_le)
         i_vm = i_vm + 1

      case (node_Greater)
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_gt)
         i_vm = i_vm + 1

      case (node_GreaterEqual)
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_ge)
         i_vm = i_vm + 1

      case (node_Equal)
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_eq)
         i_vm = i_vm + 1

      case (node_NotEqual)
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_ne)
         i_vm = i_vm + 1

      case (node_Negate)
         call ensure_node_variety (node_Nil, &
              &  ast%nodes(right_branch (i_ast))%node_variety)
         call traverse (left_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_neg)
         i_vm = i_vm + 1

      case (node_Not)
         call ensure_node_variety (node_Nil, &
              &  ast%nodes(right_branch (i_ast))%node_variety)
         call traverse (left_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_not)
         i_vm = i_vm + 1

      case (node_And)
         !
         ! This is not a short-circuiting AND and so differs from
         ! C. One would not notice the difference, except in side
         ! effects that (I believe) are not possible in our tiny
         ! language.
         !
         ! Even in a language such as Fortran that has actual AND and
         ! OR operators, an optimizer may generate short-circuiting
         ! code and so spoil one’s expectations for side
         ! effects. (Therefore gfortran may issue a warning if you
         ! call an unpure function within an .AND. or
         ! .OR. expression.)
         !
         ! A C equivalent to what we have our code generator doing
         ! (and to Fortran’s .AND. operator) might be something like
         !
         !    #define AND(a, b) ((!!(a)) * (!!(b)))
         !
         ! This macro takes advantage of the equivalence of AND to
         ! multiplication modulo 2. The ‘!!’ notations are a C idiom
         ! for converting values to 0 and 1.
         !
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_and)
         i_vm = i_vm + 1

      case (node_Or)
         !
         ! This is not a short-circuiting OR and so differs from
         ! C. One would not notice the difference, except in side
         ! effects that (I believe) are not possible in our tiny
         ! language.
         !
         ! Even in a language such as Fortran that has actual AND and
         ! OR operators, an optimizer may generate short-circuiting
         ! code and so spoil one’s expectations for side
         ! effects. (Therefore gfortran may issue a warning if you
         ! call an unpure function within an .AND. or
         ! .OR. expression.)
         !
         ! A C equivalent to what we have our code generator doing
         ! (and to Fortran’s .OR. operator) might be something like
         !
         !    #define OR(a, b) (!( (!(a)) * (!(b)) ))
         !
         ! This macro takes advantage of the equivalence of AND to
         ! multiplication modulo 2, and the equivalence of OR(a,b) to
         ! !AND(!a,!b). One could instead take advantage of the
         ! equivalence of OR to addition modulo 2:
         !
         !    #define OR(a, b) ( ( (!!(a)) + (!!(b)) ) & 1 )
         !
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_or)
         i_vm = i_vm + 1

      case (node_If)
         block
           integer(kind = nk) :: i_left, i_right
           integer(kind = nk) :: i_right_then_left, i_right_then_right
           logical :: there_is_an_else_clause
           integer(kind = rik) :: fixup_address1
           integer(kind = rik) :: fixup_address2
           integer(kind = rik) :: relative_address

           i_left = left_branch (i_ast)
           i_right = right_branch (i_ast)

           call ensure_node_variety (node_If, ast%nodes(i_right)%node_variety)

           i_right_then_left = left_branch (i_right)
           i_right_then_right = right_branch (i_right)

           there_is_an_else_clause = &
                & (ast%nodes(i_right_then_right)%node_variety /= node_Nil)

           ! Generate code for the predicate.
           call traverse (i_left)

           ! Generate a conditional jump over the predicate-true code.
           call code%ensure_storage(i_vm + 5)
           code%bytes(i_vm) = achar (opcode_jz)
           call int32_to_vm_bytes (0_rik, code%bytes, i_vm + 1)
           fixup_address1 = i_vm + 1
           i_vm = i_vm + 5

           ! Generate the predicate-true code.
           call traverse (i_right_then_left)

           if (there_is_an_else_clause) then
              ! Generate an unconditional jump over the predicate-true
              ! code.
              call code%ensure_storage(i_vm + 5)
              code%bytes(i_vm) = achar (opcode_jmp)
              call int32_to_vm_bytes (0_rik, code%bytes, i_vm + 1)
              fixup_address2 = i_vm + 1
              i_vm = i_vm + 5

              ! Fix up the conditional jump, so it jumps to the
              ! predicate-false code.
              relative_address = i_vm - fixup_address1
              call int32_to_vm_bytes (relative_address, code%bytes, fixup_address1)

              ! Generate the predicate-false code.
              call traverse (i_right_then_right)

              ! Fix up the unconditional jump, so it jumps past the
              ! predicate-false code.
              relative_address = i_vm - fixup_address2
              call int32_to_vm_bytes (relative_address, code%bytes, fixup_address2)
           else
              ! Fix up the conditional jump, so it jumps past the
              ! predicate-true code.
              relative_address = i_vm - fixup_address1
              call int32_to_vm_bytes (relative_address, code%bytes, fixup_address1)
           end if
         end block

      case (node_While)
         block

           !
           ! Note there is another common way to translate a
           ! while-loop which is to put (logically inverted) predicate
           ! code *after* the loop-body code, followed by a
           ! conditional jump to the start of the loop. You start the
           ! loop by unconditionally jumping to the predicate code.
           !
           ! If our VM had a ‘jnz’ instruction, that translation would
           ! almost certainly be slightly better than this one. Given
           ! that we do not have a ‘jnz’, the code would end up
           ! slightly enlarged; one would have to put ‘not’ before the
           ! ‘jz’ at the bottom of the loop.
           !

           integer(kind = nk) :: i_left, i_right
           integer(kind = rik) :: loop_address
           integer(kind = rik) :: fixup_address
           integer(kind = rik) :: relative_address

           i_left = left_branch (i_ast)
           i_right = right_branch (i_ast)

           ! Generate code for the predicate.
           loop_address = i_vm
           call traverse (i_left)

           ! Generate a conditional jump out of the loop.
           call code%ensure_storage(i_vm + 5)
           code%bytes(i_vm) = achar (opcode_jz)
           call int32_to_vm_bytes (0_rik, code%bytes, i_vm + 1)
           fixup_address = i_vm + 1
           i_vm = i_vm + 5

           ! Generate code for the loop body.
           call traverse (i_right)

           ! Generate an unconditional jump to the top of the loop.
           call code%ensure_storage(i_vm + 5)
           code%bytes(i_vm) = achar (opcode_jmp)
           relative_address = loop_address - (i_vm + 1)
           call int32_to_vm_bytes (relative_address, code%bytes, i_vm + 1)
           i_vm = i_vm + 5

           ! Fix up the conditional jump, so it jumps after the loop
           ! body.
           relative_address = i_vm - fixup_address
           call int32_to_vm_bytes (relative_address, code%bytes, fixup_address)
         end block

      case (node_Prtc)
         call ensure_node_variety (node_Nil, &
              &  ast%nodes(right_branch (i_ast))%node_variety)
         call traverse (left_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_prtc)
         i_vm = i_vm + 1

      case (node_Prti)
         call ensure_node_variety (node_Nil, &
              &  ast%nodes(right_branch (i_ast))%node_variety)
         call traverse (left_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_prti)
         i_vm = i_vm + 1

      case (node_Prts)
         call ensure_node_variety (node_Nil, &
              &  ast%nodes(right_branch (i_ast))%node_variety)
         call traverse (left_branch (i_ast))
         call code%ensure_storage(i_vm + 1)
         code%bytes(i_vm) = achar (opcode_prts)
         i_vm = i_vm + 1

      case (node_Sequence)
         call traverse (left_branch (i_ast))
         call traverse (right_branch (i_ast))

      case default
         call bad_ast

      end select

      code%len = i_vm

    end subroutine traverse

    elemental function left_branch (i_here) result (i_left)
      integer(kind = nk), intent(in) :: i_here
      integer(kind = nk) :: i_left

      i_left = i_here + 1
    end function left_branch

    elemental function right_branch (i_here) result (i_right)
      integer(kind = nk), intent(in) :: i_here
      integer(kind = nk) :: i_right

      i_right = i_here + 1 + ast%nodes(i_here)%right_branch_offset
    end function right_branch

    subroutine ensure_node_variety (expected_node_variety, found_node_variety)
      integer, intent(in) :: expected_node_variety
      integer, intent(in) :: found_node_variety
      if (expected_node_variety /= found_node_variety) call bad_ast
    end subroutine ensure_node_variety

    subroutine bad_ast
      call codegen_error_message
      write (error_unit, '("unexpected abstract syntax")')
      stop 1
    end subroutine bad_ast

  end subroutine generate_code

  subroutine output_code (outp, symtab, strtab, code)
    integer, intent(in) :: outp ! The unit to write the output to.
    type(string_table_t), intent(inout) :: symtab
    type(string_table_t), intent(inout) :: strtab
    type(vm_code_t), intent(in) :: code

    call write_header (outp, symtab%length(), strtab%length())
    call write_strings (outp, strtab)
    call disassemble_instructions (outp, code)
  end subroutine output_code

  subroutine write_header (outp, data_size, strings_size)
    integer, intent(in) :: outp
    integer(kind = rik) :: data_size
    integer(kind = rik) :: strings_size

    call ensure_integer_is_vm_compatible (data_size)
    call ensure_integer_is_vm_compatible (strings_size)
    write (outp, '("Datasize: ", I0, " Strings: ", I0)') data_size, strings_size
  end subroutine write_header

  subroutine write_strings (outp, strtab)
    integer, intent(in) :: outp
    type(string_table_t), intent(inout) :: strtab

    integer(kind = rik) :: i

    do i = 1_rik, strtab%length()
       write (outp, '(1A)') quoted_string (strtab%look_up(i))
    end do
  end subroutine write_strings

  subroutine disassemble_instructions (outp, code)
    integer, intent(in) :: outp
    type(vm_code_t), intent(in) :: code

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

    i_vm = 0_rik
    do while (i_vm /= code%length())
       call write_vm_code_address (outp, i_vm)
       opcode = iachar (code%bytes(i_vm))
       call write_vm_opcode (outp, opcode)
       select case (opcode)
       case (opcode_push)
          call int32_from_vm_bytes (n, code%bytes, i_vm + 1)
          call write_vm_int_literal (outp, n)
          i_vm = i_vm + 5
       case (opcode_fetch, opcode_store)
          call uint32_from_vm_bytes (n, code%bytes, i_vm + 1)
          call write_vm_data_address (outp, n)
          i_vm = i_vm + 5
       case (opcode_jmp, opcode_jz)
          call int32_from_vm_bytes (n, code%bytes, i_vm + 1)
          call write_vm_jump_address (outp, n, i_vm + 1)
          i_vm = i_vm + 5
       case default
          i_vm = i_vm + 1
       end select
       write (outp, '()', advance = 'yes')
    end do
  end subroutine disassemble_instructions

  subroutine write_vm_code_address (outp, i_vm)
    integer, intent(in) :: outp
    integer(kind = rik), intent(in) :: i_vm

    ! 10 characters is wide enough for any 32-bit unsigned number.
    write (outp, '(I10, 1X)', advance = 'no') i_vm
  end subroutine write_vm_code_address

  subroutine write_vm_opcode (outp, opcode)
    integer, intent(in) :: outp
    integer, intent(in) :: opcode

    character(8, kind = ck) :: opcode_name

    opcode_name = opcode_names(opcode)

    select case (opcode)
    case (opcode_push, opcode_fetch, opcode_store, opcode_jz, opcode_jmp)
       write (outp, '(1A)', advance = 'no') opcode_name(1:6)
    case default
       write (outp, '(1A)', advance = 'no') trim (opcode_name)
    end select
  end subroutine write_vm_opcode

  subroutine write_vm_int_literal (outp, n)
    integer, intent(in) :: outp
    integer(kind = rik), intent(in) :: n

    write (outp, '(I0)', advance = 'no') n
  end subroutine write_vm_int_literal

  subroutine write_vm_data_address (outp, i)
    integer, intent(in) :: outp
    integer(kind = rik), intent(in) :: i

    write (outp, '("[", I0, "]")', advance = 'no') i
  end subroutine write_vm_data_address

  subroutine write_vm_jump_address (outp, relative_address, i_vm)
    integer, intent(in) :: outp
    integer(kind = rik), intent(in) :: relative_address
    integer(kind = rik), intent(in) :: i_vm

    write (outp, '(" (", I0, ") ", I0)', advance = 'no') &
         &    relative_address, i_vm + relative_address
  end subroutine write_vm_jump_address

  subroutine ensure_integer_is_vm_compatible (n)
    integer(kind = rik), intent(in) :: n
    !
    ! It would seem desirable to check this in the syntax analyzer,
    ! instead, so line and column numbers can be given. But checking
    ! here will not hurt.
    !
    if (n < vm_huge_negint .or. vm_huge_posint < n) then
       call codegen_error_message
       write (error_unit, '("integer is too large for the virtual machine: ", I0)') n
       stop 1
    end if
  end subroutine ensure_integer_is_vm_compatible

  subroutine codegen_error_message
    write (error_unit, '("Code generation error: ")', advance = 'no')
  end subroutine codegen_error_message

end module code_generation

program gen
  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 :: ast_reader
  use, non_intrinsic :: code_generation

  implicit none

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

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

  type(strbuf_t) :: strbuf
  type(ast_t) :: ast
  type(string_table_t) :: symtab
  type(string_table_t) :: strtab

  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

     call read_ast (inp, strbuf, ast, symtab, strtab)
     call generate_and_output_code (outp, ast, symtab, strtab)
  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 gen


function Token_assign(tk, attr,      attr_array, n, i) {
  n=split(attr, attr_array)
  for(i=1; i<=n; i++)
    Tokens[tk,i-1] = attr_array[i]
}

#*** show error and exit
function error(msg) {
  printf("(%s, %s) %s\n", err_line, err_col, msg)
  exit(1)
}

function gettok(      line, n, i) {
  getline line
  if (line == "")
    error("empty line")
  n=split(line, line_list)
  # line col Ident var_name
  # 1    2   3     4
  err_line = line_list[1]
  err_col  = line_list[2]
  tok_text = line_list[3]
  tok = all_syms[tok_text]
  for (i=5; i<=n; i++)
    line_list[4] = line_list[4] " " line_list[i]
  if (tok == "")
    error("Unknown token " tok_text)
  tok_other = ""
  if (tok == "tk_Integer" || tok == "tk_Ident" || tok =="tk_String")
    tok_other = line_list[4]
}

function make_node(oper, left, right, value) {
  node_type [next_free_node_index] = oper
  node_left [next_free_node_index] = left
  node_right[next_free_node_index] = right
  node_value[next_free_node_index] = value
  return next_free_node_index ++
}

function make_leaf(oper, n) {
  return make_node(oper, 0, 0, n)
}

function expect(msg, s) {
  if (tok == s) {
    gettok()
    return
  }
  error(msg ": Expecting '" Tokens[s,TK_NAME] "', found '" Tokens[tok,TK_NAME] "'")
}

function expr(p,       x, op, node) {
  x = 0
  if (tok == "tk_Lparen") {
    x = paren_expr()
  } else if (tok == "tk_Sub" || tok == "tk_Add") {
    if (tok == "tk_Sub")
      op = "tk_Negate"
    else
      op = "tk_Add"
    gettok()
    node = expr(Tokens["tk_Negate",TK_PRECEDENCE]+0)
    if (op == "tk_Negate")
      x = make_node("nd_Negate", node)
    else
      x = node
  } else if (tok == "tk_Not") {
    gettok()
    x = make_node("nd_Not", expr(Tokens["tk_Not",TK_PRECEDENCE]+0))
  } else if (tok == "tk_Ident") {
    x = make_leaf("nd_Ident", tok_other)
    gettok()
  } else if (tok == "tk_Integer") {
    x = make_leaf("nd_Integer", tok_other)
    gettok()
  } else {
    error("Expecting a primary, found: " Tokens[tok,TK_NAME])
  }
  while (((Tokens[tok,TK_IS_BINARY]+0) > 0) && ((Tokens[tok,TK_PRECEDENCE]+0) >= p)) {
    op = tok
    gettok()
    q = Tokens[op,TK_PRECEDENCE]+0
    if (! (Tokens[op,TK_RIGHT_ASSOC]+0 > 0))
      q += 1
    node = expr(q)
    x = make_node(Tokens[op,TK_NODE], x, node)
  }
  return x
}

function paren_expr(        node) {
  expect("paren_expr", "tk_Lparen")
  node = expr(0)
  expect("paren_expr", "tk_Rparen")
  return node
}

function stmt(              t, e, s, s2, v) {
  t = 0
  if (tok == "tk_If") {
    gettok()
    e = paren_expr()
    s = stmt()
    s2 = 0
    if (tok == "tk_Else") {
      gettok()
      s2 = stmt()
    }
    t = make_node("nd_If", e, make_node("nd_If", s, s2))
  } else if (tok == "tk_Putc") {
    gettok()
    e = paren_expr()
    t = make_node("nd_Prtc", e)
    expect("Putc", "tk_Semi")
  } else if (tok == "tk_Print") {
    gettok()
    expect("Print", "tk_Lparen")
    while (1) {
      if (tok == "tk_String") {
        e = make_node("nd_Prts", make_leaf("nd_String", tok_other))
        gettok()
      } else {
        e = make_node("nd_Prti", expr(0))
      }
      t = make_node("nd_Sequence", t, e)
      if (tok != "tk_Comma")
        break
      gettok()
    }
    expect("Print", "tk_Rparen")
    expect("Print", "tk_Semi")
  } else if (tok == "tk_Semi") {
    gettok()
  } else if (tok == "tk_Ident") {
    v = make_leaf("nd_Ident", tok_other)
    gettok()
    expect("assign", "tk_Assign")
    e = expr(0)
    t = make_node("nd_Assign", v, e)
    expect("assign", "tk_Semi")
  } else if (tok == "tk_While") {
    gettok()
    e = paren_expr()
    s = stmt()
    t = make_node("nd_While", e, s)
  } else if (tok == "tk_Lbrace") {
    gettok()
    while (tok != "tk_Rbrace" && tok != "tk_EOI")
      t = make_node("nd_Sequence", t, stmt())
    expect("Lbrace", "tk_Rbrace")
  } else if (tok == "tk_EOI") {
  } else {
    error("Expecting start of statement, found: " Tokens[tok,TK_NAME])
  }
  return t
}

function parse(         t) {
  t = 0   # None
  gettok()
  while (1) {
    t = make_node("nd_Sequence", t, stmt())
    if (tok == "tk_EOI" || t == 0)
      break
  }
  return t
}

function prt_ast(t) {
  if (t == 0) {
    print(";")
  } else {
    printf("%-14s", Display_nodes[node_type[t]])
    if ((node_type[t] == "nd_Ident") || (node_type[t] == "nd_Integer"))
      printf("%s\n", node_value[t])
    else if (node_type[t] == "nd_String") {
      printf("%s\n", node_value[t])
    } else {
      print("")
      prt_ast(node_left[t])
      prt_ast(node_right[t])
    }
  }
}

BEGIN {
  all_syms["End_of_input"    ] = "tk_EOI"
  all_syms["Op_multiply"     ] = "tk_Mul"
  all_syms["Op_divide"       ] = "tk_Div"
  all_syms["Op_mod"          ] = "tk_Mod"
  all_syms["Op_add"          ] = "tk_Add"
  all_syms["Op_subtract"     ] = "tk_Sub"
  all_syms["Op_negate"       ] = "tk_Negate"
  all_syms["Op_not"          ] = "tk_Not"
  all_syms["Op_less"         ] = "tk_Lss"
  all_syms["Op_lessequal"    ] = "tk_Leq"
  all_syms["Op_greater"      ] = "tk_Gtr"
  all_syms["Op_greaterequal" ] = "tk_Geq"
  all_syms["Op_equal"        ] = "tk_Eq"
  all_syms["Op_notequal"     ] = "tk_Neq"
  all_syms["Op_assign"       ] = "tk_Assign"
  all_syms["Op_and"          ] = "tk_And"
  all_syms["Op_or"           ] = "tk_Or"
  all_syms["Keyword_if"      ] = "tk_If"
  all_syms["Keyword_else"    ] = "tk_Else"
  all_syms["Keyword_while"   ] = "tk_While"
  all_syms["Keyword_print"   ] = "tk_Print"
  all_syms["Keyword_putc"    ] = "tk_Putc"
  all_syms["LeftParen"       ] = "tk_Lparen"
  all_syms["RightParen"      ] = "tk_Rparen"
  all_syms["LeftBrace"       ] = "tk_Lbrace"
  all_syms["RightBrace"      ] = "tk_Rbrace"
  all_syms["Semicolon"       ] = "tk_Semi"
  all_syms["Comma"           ] = "tk_Comma"
  all_syms["Identifier"      ] = "tk_Ident"
  all_syms["Integer"         ] = "tk_Integer"
  all_syms["String"          ] = "tk_String"

  Display_nodes["nd_Ident"   ] = "Identifier"
  Display_nodes["nd_String"  ] = "String"
  Display_nodes["nd_Integer" ] = "Integer"
  Display_nodes["nd_Sequence"] = "Sequence"
  Display_nodes["nd_If"      ] = "If"
  Display_nodes["nd_Prtc"    ] = "Prtc"
  Display_nodes["nd_Prts"    ] = "Prts"
  Display_nodes["nd_Prti"    ] = "Prti"
  Display_nodes["nd_While"   ] = "While"
  Display_nodes["nd_Assign"  ] = "Assign"
  Display_nodes["nd_Negate"  ] = "Negate"
  Display_nodes["nd_Not"     ] = "Not"
  Display_nodes["nd_Mul"     ] = "Multiply"
  Display_nodes["nd_Div"     ] = "Divide"
  Display_nodes["nd_Mod"     ] = "Mod"
  Display_nodes["nd_Add"     ] = "Add"
  Display_nodes["nd_Sub"     ] = "Subtract"
  Display_nodes["nd_Lss"     ] = "Less"
  Display_nodes["nd_Leq"     ] = "LessEqual"
  Display_nodes["nd_Gtr"     ] = "Greater"
  Display_nodes["nd_Geq"     ] = "GreaterEqual"
  Display_nodes["nd_Eql"     ] = "Equal"
  Display_nodes["nd_Neq"     ] = "NotEqual"
  Display_nodes["nd_And"     ] = "And"
  Display_nodes["nd_Or"      ] = "Or"

  TK_NAME         =          0
  TK_RIGHT_ASSOC  =                   1
  TK_IS_BINARY    =                     2
  TK_IS_UNARY     =                       3
  TK_PRECEDENCE   =                          4
  TK_NODE         =                             5
  Token_assign("tk_EOI"    , "EOI     0 0 0 -1 -1        ")
  Token_assign("tk_Mul"    , "*       0 1 0 13 nd_Mul    ")
  Token_assign("tk_Div"    , "/       0 1 0 13 nd_Div    ")
  Token_assign("tk_Mod"    , "%       0 1 0 13 nd_Mod    ")
  Token_assign("tk_Add"    , "+       0 1 0 12 nd_Add    ")
  Token_assign("tk_Sub"    , "-       0 1 0 12 nd_Sub    ")
  Token_assign("tk_Negate" , "-       0 0 1 14 nd_Negate ")
  Token_assign("tk_Not"    , "!       0 0 1 14 nd_Not    ")
  Token_assign("tk_Lss"    , "<       0 1 0 10 nd_Lss    ")
  Token_assign("tk_Leq"    , "<=      0 1 0 10 nd_Leq    ")
  Token_assign("tk_Gtr"    , ">       0 1 0 10 nd_Gtr    ")
  Token_assign("tk_Geq"    , ">=      0 1 0 10 nd_Geq    ")
  Token_assign("tk_Eql"    , "==      0 1 0  9 nd_Eql    ")
  Token_assign("tk_Neq"    , "!=      0 1 0  9 nd_Neq    ")
  Token_assign("tk_Assign" , "=       0 0 0 -1 nd_Assign ")
  Token_assign("tk_And"    , "&&      0 1 0  5 nd_And    ")
  Token_assign("tk_Or"     , "||      0 1 0  4 nd_Or     ")
  Token_assign("tk_If"     , "if      0 0 0 -1 nd_If     ")
  Token_assign("tk_Else"   , "else    0 0 0 -1 -1        ")
  Token_assign("tk_While"  , "while   0 0 0 -1 nd_While  ")
  Token_assign("tk_Print"  , "print   0 0 0 -1 -1        ")
  Token_assign("tk_Putc"   , "putc    0 0 0 -1 -1        ")
  Token_assign("tk_Lparen" , "(       0 0 0 -1 -1        ")
  Token_assign("tk_Rparen" , ")       0 0 0 -1 -1        ")
  Token_assign("tk_Lbrace" , "{       0 0 0 -1 -1        ")
  Token_assign("tk_Rbrace" , "}       0 0 0 -1 -1        ")
  Token_assign("tk_Semi"   , ";       0 0 0 -1 -1        ")
  Token_assign("tk_Comma"  , ",       0 0 0 -1 -1        ")
  Token_assign("tk_Ident"  , "Ident   0 0 0 -1 nd_Ident  ")
  Token_assign("tk_Integer", "Integer 0 0 0 -1 nd_Integer")
  Token_assign("tk_String" , "String  0 0 0 -1 nd_String ")

  input_file = "-"
  err_line   = 0
  err_col    = 0
  tok        = ""
  tok_text   = ""
  next_free_node_index = 1

  if (ARGC > 1)
    input_file = ARGV[1]
  t = parse()
  prt_ast(t)
}


package xyz.hyperreal.rosettacodeCompiler

import java.io.{BufferedReader, FileReader, Reader, StringReader}

import scala.collection.mutable
import scala.collection.mutable.ArrayBuffer

object VirtualMachine {

  private object Opcodes {
    val FETCH: Byte = 0
    val STORE: Byte = 1
    val PUSH: Byte  = 2
    val JMP: Byte   = 3
    val JZ: Byte    = 4
    val ADD: Byte   = 5
    val SUB: Byte   = 6
    val MUL: Byte   = 7
    val DIV: Byte   = 8
    val MOD: Byte   = 9
    val LT: Byte    = 10
    val GT: Byte    = 11
    val LE: Byte    = 12
    val GE: Byte    = 13
    val EQ: Byte    = 14
    val NE: Byte    = 15
    val AND: Byte   = 16
    val OR: Byte    = 17
    val NEG: Byte   = 18
    val NOT: Byte   = 19
    val PRTC: Byte  = 20
    val PRTI: Byte  = 21
    val PRTS: Byte  = 22
    val HALT: Byte  = 23
  }

  import Opcodes._

  private val HEADER_REGEX = "Datasize: ([0-9]+) Strings: ([0-9]+)" r
  private val STRING_REGEX = "\"([^\"]*)\"" r
  private val PUSH_REGEX   = " *[0-9]+ push +([0-9]+|'(?:[^'\\n]|\\\\n|\\\\\\\\)')" r
  private val PRTS_REGEX   = " *[0-9]+ prts" r
  private val PRTI_REGEX   = " *[0-9]+ prti" r
  private val PRTC_REGEX   = " *[0-9]+ prtc" r
  private val HALT_REGEX   = " *[0-9]+ halt" r
  private val STORE_REGEX  = " *[0-9]+ store +\\[([0-9]+)\\]" r
  private val FETCH_REGEX  = " *[0-9]+ fetch +\\[([0-9]+)\\]" r
  private val LT_REGEX     = " *[0-9]+ lt" r
  private val GT_REGEX     = " *[0-9]+ gt" r
  private val LE_REGEX     = " *[0-9]+ le" r
  private val GE_REGEX     = " *[0-9]+ ge" r
  private val NE_REGEX     = " *[0-9]+ ne" r
  private val EQ_REGEX     = " *[0-9]+ eq" r
  private val JZ_REGEX     = " *[0-9]+ jz +\\((-?[0-9]+)\\) [0-9]+" r
  private val ADD_REGEX    = " *[0-9]+ add" r
  private val SUB_REGEX    = " *[0-9]+ sub" r
  private val MUL_REGEX    = " *[0-9]+ mul" r
  private val DIV_REGEX    = " *[0-9]+ div" r
  private val MOD_REGEX    = " *[0-9]+ mod" r
  private val AND_REGEX    = " *[0-9]+ and" r
  private val OR_REGEX     = " *[0-9]+ or" r
  private val NOT_REGEX    = " *[0-9]+ not" r
  private val NEG_REGEX    = " *[0-9]+ neg" r
  private val JMP_REGEX    = " *[0-9]+ jmp +\\((-?[0-9]+)\\) [0-9]+" r

  def fromStdin = fromReader(Console.in)

  def fromFile(file: String) = fromReader(new FileReader(file))

  def fromString(src: String) = fromReader(new StringReader(src))

  def fromReader(r: Reader) = {
    val in = new BufferedReader(r)
    val vm =
      in.readLine match {
        case HEADER_REGEX(datasize, stringsize) =>
          val strings =
            for (_ <- 1 to stringsize.toInt)
              yield
                in.readLine match {
                  case STRING_REGEX(s) => unescape(s)
                  case null            => sys.error("expected string constant but encountered end of input")
                  case s               => sys.error(s"expected string constant: $s")
                }
          var line: String = null
          val code         = new ArrayBuffer[Byte]

          def addShort(a: Int) = {
            code += (a >> 8).toByte
            code += a.toByte
          }

          def addInstIntOperand(opcode: Byte, operand: Int) = {
            code += opcode
            addShort(operand >> 16)
            addShort(operand)
          }

          def addInst(opcode: Byte, operand: String) = addInstIntOperand(opcode, operand.toInt)

          while ({ line = in.readLine; line ne null }) line match {
            case PUSH_REGEX(n) if n startsWith "'" =>
              addInstIntOperand(PUSH, unescape(n.substring(1, n.length - 1)).head)
            case PUSH_REGEX(n)    => addInst(PUSH, n)
            case PRTS_REGEX()     => code += PRTS
            case PRTI_REGEX()     => code += PRTI
            case PRTC_REGEX()     => code += PRTC
            case HALT_REGEX()     => code += HALT
            case STORE_REGEX(idx) => addInst(STORE, idx)
            case FETCH_REGEX(idx) => addInst(FETCH, idx)
            case LT_REGEX()       => code += LT
            case GT_REGEX()       => code += GT
            case LE_REGEX()       => code += LE
            case GE_REGEX()       => code += GE
            case NE_REGEX()       => code += NE
            case EQ_REGEX()       => code += EQ
            case JZ_REGEX(disp)   => addInst(JZ, disp)
            case ADD_REGEX()      => code += ADD
            case SUB_REGEX()      => code += SUB
            case MUL_REGEX()      => code += MUL
            case DIV_REGEX()      => code += DIV
            case MOD_REGEX()      => code += MOD
            case AND_REGEX()      => code += AND
            case OR_REGEX()       => code += OR
            case NOT_REGEX()      => code += NOT
            case NEG_REGEX()      => code += NEG
            case JMP_REGEX(disp)  => addInst(JMP, disp)
          }

          new VirtualMachine(code, datasize.toInt, strings)
        case _ => sys.error("expected header")
      }

    in.close
    vm
  }

}

class VirtualMachine(code: IndexedSeq[Byte], datasize: Int, strings: IndexedSeq[String]) {

  import VirtualMachine.Opcodes._

  var pc      = 0
  val stack   = new mutable.ArrayStack[Int]
  val data    = new Array[Int](datasize)
  var running = false

  def getByte = {
    val byte = code(pc) & 0xFF

    pc += 1
    byte
  }

  def getShort = getByte << 8 | getByte

  def getInt = getShort << 16 | getShort

  def pushBoolean(b: Boolean) = stack push (if (b) 1 else 0)

  def popBoolean = if (stack.pop != 0) true else false

  def operator(f: (Int, Int) => Int) = {
    val y = stack.pop

    stack.push(f(stack.pop, y))
  }

  def relation(r: (Int, Int) => Boolean) = {
    val y = stack.pop

    pushBoolean(r(stack.pop, y))
  }

  def connective(c: (Boolean, Boolean) => Boolean) = pushBoolean(c(popBoolean, popBoolean))

  def execute: Unit =
    getByte match {
      case FETCH => stack push data(getInt)
      case STORE => data(getInt) = stack.pop
      case PUSH  => stack push getInt
      case JMP   => pc = pc + getInt
      case JZ    => if (stack.pop == 0) pc = pc + getInt else pc += 4
      case ADD   => operator(_ + _)
      case SUB   => operator(_ - _)
      case MUL   => operator(_ * _)
      case DIV   => operator(_ / _)
      case MOD   => operator(_ % _)
      case LT    => relation(_ < _)
      case GT    => relation(_ > _)
      case LE    => relation(_ <= _)
      case GE    => relation(_ >= _)
      case EQ    => relation(_ == _)
      case NE    => relation(_ != _)
      case AND   => connective(_ && _)
      case OR    => connective(_ || _)
      case NEG   => stack push -stack.pop
      case NOT   => pushBoolean(!popBoolean)
      case PRTC  => print(stack.pop.toChar)
      case PRTI  => print(stack.pop)
      case PRTS  => print(strings(stack.pop))
      case HALT  => running = false
    }

  def run = {
    pc = 0
    stack.clear
    running = true

    for (i <- data.indices) data(i) = 0

    while (running) execute
  }

}


#lang racket
(require (only-in srfi/13 [string-reverse gnirts]))

;; returns a string with the "comma"s inserted every step characters from the RIGHT of n.
;; because of the right handedness of this, there is a lot of reversal going on
(define ((insert-commas comma step) n)
  (define px (pregexp (format ".{1,~a}" step)))
  (string-join (add-between (reverse (map gnirts (regexp-match* px (gnirts n)))) comma) ""))

(define (commatize s #:start (start 0) #:comma (comma ",") #:step (step 3))
  (define ins-comms (insert-commas comma step)) ; specific to our comma and step

  (define split-into-numbers
    (match-lambda
      [(regexp
        #px"^([^1-9]*)([1-9][0-9.]*)(\\S*)(.*)$" ; see below for description of bits
        (list _                               ; the whole match
              (app split-into-numbers pre)    ; recur on left
              num                             ; the number bit before any exponent or other
                                              ; interestingness
              post-number                     ; from exponent to the first space
              (app split-into-numbers post))) ; recur on right
       (define skip (substring num 0 start))
       (match-define
         (regexp #px"^(.*?)(\\..*)?$"
                 (list _                      ; whole match
                       (app ins-comms n)      ; the bit that gets the commas added
                       (or (? string? d)      ; if it matches, then the raw string is in d
                           (and #f (app (lambda (f) "") d))))) ; if (...)? doesn't match it returns
                                                               ; #f which we thunk to an empty string
         (substring num start))                       ; do the match on the unskipped bit
       (string-append pre skip n d post-number post)] ; stitch it back together
      [else else]))                                   ; if it doesn't match leave as is

  ;; kick it off
  (split-into-numbers s))

(module+ test
  (require tests/eli-tester)

  (test
   (commatize "pi=3.14159265358979323846264338327950288419716939937510582097494459231"
              #:start 6 #:comma " " #:step 5)
   =>"pi=3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59231"

   (commatize "The author has two Z$100000000000000 Zimbabwe notes (100 trillion)." #:comma ".")
   =>"The author has two Z$100.000.000.000.000 Zimbabwe notes (100 trillion)."

   (commatize "-in Aus$+1411.8millions")
   =>"-in Aus$+1,411.8millions"

   (commatize "===US$0017440 millions=== (in 2000 dollars)")
   =>"===US$0017,440 millions=== (in 2,000 dollars)"

   (commatize "123.e8000 is pretty big.")
   =>"123.e8000 is pretty big."

   (commatize "The land area of the earth is  57268900(29% of the surface)  square miles.")
   =>"The land area of the earth is  57,268,900(29% of the surface)  square miles."

   (commatize "Ain't no numbers in this here words, nohow, no way, Jose.")
   =>"Ain't no numbers in this here words, nohow, no way, Jose."

   (commatize "James was never known as  0000000007")
   =>"James was never known as  0000000007"

   (commatize "Arthur Eddington wrote: I believe there are 15747724136275002577605653961181555468044717914527116709366231425076185631031296 protons in the universe.")
   =>"Arthur Eddington wrote: I believe there are 15,747,724,136,275,002,577,605,653,961,181,555,468,044,717,914,527,116,709,366,231,425,076,185,631,031,296 protons in the universe."

   (commatize "   $-140000±100  millions.")

   =>"   $-140,000±100  millions."
   (commatize "6/9/1946 was a good year for some.")
   =>"6/9/1946 was a good year for some."))


/*REXX program adds commas (or other chars) to a  string  or a  number  within a string.*/
@. =
@.1= "pi=3.14159265358979323846264338327950288419716939937510582097494459231"
@.2= "The author has two Z$100000000000000 Zimbabwe notes (100 trillion)."
@.3= "-in Aus$+1411.8millions"
@.4= "===US$0017440 millions=== (in 2000 dollars)"
@.5= "123.e8000 is pretty big."
@.6= "The land area of the earth is  57268900(29% of the surface)  square miles."
@.7= "Ain't no numbers in this here words, nohow, no way, Jose."
@.8= "James was never known as  0000000007"
@.9= "Arthur Eddington wrote: I believe there are 15747724136275002577605653961181555468044717914527116709366231425076185631031296 protons in the universe."
@.10= "   $-140000±100  millions."
@.11= "6/9/1946 was a good year for some."

       do i=1  while  @.i\=='';               if i\==1  then say  /*process each string.*/
                     say 'before──►'@.i                           /*show the before str.*/
       if i==1  then say ' after──►'comma(@.i, 'blank', 5, , 6)   /*   p=5,  start=6.   */
       if i==2  then say ' after──►'comma(@.i, ".")               /*comma=decimal point.*/
       if i>2   then say ' after──►'comma(@.i)                    /*use the defaults.   */
       end   /*j*/
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
comma: procedure; parse arg x,sep,period,times,start       /*obtain true case arguments.*/
                        arg  ,sepU                         /*   "   uppercase 2nd arg.  */
       bla= ' '                                            /*literal to hold a  "blank".*/
       sep= word(sep ',', 1)                               /*define comma (string/char.)*/
       if sepU=='BLANK'  then sep= bla                     /*allow the use of  'BLANK'. */
       period= word(period 3, 1)                           /*defined "period" to be used*/
       times= word(times 999999999, 1)                     /*limits # changes to be made*/
       start= word(start 1        , 1)                     /*where to start commatizing.*/
                                                           /* [↓]  various error tests. */
       if \datatype(period, 'W')  | ,                      /*test for a whole number.   */
          \datatype(times , 'W')  | ,                      /*  "   "  "   "      "      */
          \datatype(start , 'W')  | ,                      /*  "   "  "   "      "      */
          start <1                | ,                      /*start can't be less then 1.*/
          arg() >5                      then return x      /*# of args can't be  >  5.  */
                                                           /* [↑]  some arg is invalid. */
       op= period                                          /*save the original period.  */
       period= abs(period)                                 /*use the absolute value.    */
       n= x'.9'                                            /*a literal string for  end. */
       digs=   123456789                                   /*the legal digits for start.*/
       digsz=  1234567890                                  /* "    "      "    "   fin. */
       digszp= 1234567890.                                 /* "    "      "    "   fin. */
                                                           /* [↓]  note: no zero in digs*/
       if op<0  then do                                    /*Negative?  Treat as chars. */
                     beg= start                            /*begin at the start.        */
                     L= length(x)                          /*obtain the length of  X.   */
                     fin= L - verify( reverse(x), bla) + 1 /*find the ending of the num.*/
                     end                                   /* [↑]  find number ending.  */
                else do                                    /*Positive?  Treat as numbers*/
                     beg=   verify(n, digs,  "M",start)    /*find beginning of number.  */
                     v2=max(verify(n, digszp,'M',start),1) /*end of the usable number.  */
                     fin=verify(n, digsz, , v2) -period -1 /*adjust the ending  (fin).  */
                     end                                   /* [↑]  find ending of number*/
       #= 0                                                /*the count of changes made. */
       if beg>0  &  fin>0  then                            /* [↓]  process  TIMES  times*/
                     do j=fin   to beg   by -period   while #<times
                     x= insert(sep, x, j)                  /*insert a comma into string.*/
                     #= # + 1                              /*bump the count of changes. */
                     end   /*j*/                           /*(maybe no changes are made)*/
       return x                                            /*return the commatized str. */


package main

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

type NodeType int

const (
    ndIdent NodeType = iota
    ndString
    ndInteger
    ndSequence
    ndIf
    ndPrtc
    ndPrts
    ndPrti
    ndWhile
    ndAssign
    ndNegate
    ndNot
    ndMul
    ndDiv
    ndMod
    ndAdd
    ndSub
    ndLss
    ndLeq
    ndGtr
    ndGeq
    ndEql
    ndNeq
    ndAnd
    ndOr
)

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
)

type Tree struct {
    nodeType NodeType
    left     *Tree
    right    *Tree
    value    string
}

// dependency: Ordered by NodeType, must remain in same order as NodeType enum
type atr struct {
    enumText string
    nodeType NodeType
    opcode   code
}

var atrs = []atr{
    {"Identifier", ndIdent, 255},
    {"String", ndString, 255},
    {"Integer", ndInteger, 255},
    {"Sequence", ndSequence, 255},
    {"If", ndIf, 255},
    {"Prtc", ndPrtc, 255},
    {"Prts", ndPrts, 255},
    {"Prti", ndPrti, 255},
    {"While", ndWhile, 255},
    {"Assign", ndAssign, 255},
    {"Negate", ndNegate, neg},
    {"Not", ndNot, not},
    {"Multiply", ndMul, mul},
    {"Divide", ndDiv, div},
    {"Mod", ndMod, mod},
    {"Add", ndAdd, add},
    {"Subtract", ndSub, sub},
    {"Less", ndLss, lt},
    {"LessEqual", ndLeq, le},
    {"Greater", ndGtr, gt},
    {"GreaterEqual", ndGeq, ge},
    {"Equal", ndEql, eq},
    {"NotEqual", ndNeq, ne},
    {"And", ndAnd, and},
    {"Or", ndOr, or},
}

var (
    stringPool []string
    globals    []string
    object     []code
)

var (
    err     error
    scanner *bufio.Scanner
)

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

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

func nodeType2Op(nodeType NodeType) code {
    return atrs[nodeType].opcode
}

func makeNode(nodeType NodeType, left *Tree, right *Tree) *Tree {
    return &Tree{nodeType, left, right, ""}
}

func makeLeaf(nodeType NodeType, value string) *Tree {
    return &Tree{nodeType, nil, nil, value}
}

/*** Code generator ***/

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

func emitWordAt(at, n int) {
    bs := make([]byte, 4)
    binary.LittleEndian.PutUint32(bs, uint32(n))
    for i := at; i < at+4; i++ {
        object[i] = code(bs[i-at])
    }
}

func hole() int {
    t := len(object)
    emitWord(0)
    return t
}

func fetchVarOffset(id string) int {
    for i := 0; i < len(globals); i++ {
        if globals[i] == id {
            return i
        }
    }
    globals = append(globals, id)
    return len(globals) - 1
}

func fetchStringOffset(st string) int {
    for i := 0; i < len(stringPool); i++ {
        if stringPool[i] == st {
            return i
        }
    }
    stringPool = append(stringPool, st)
    return len(stringPool) - 1
}

func codeGen(x *Tree) {
    if x == nil {
        return
    }
    var n, p1, p2 int
    switch x.nodeType {
    case ndIdent:
        emitByte(fetch)
        n = fetchVarOffset(x.value)
        emitWord(n)
    case ndInteger:
        emitByte(push)
        n, err = strconv.Atoi(x.value)
        check(err)
        emitWord(n)
    case ndString:
        emitByte(push)
        n = fetchStringOffset(x.value)
        emitWord(n)
    case ndAssign:
        n = fetchVarOffset(x.left.value)
        codeGen(x.right)
        emitByte(store)
        emitWord(n)
    case ndIf:
        codeGen(x.left)       // if expr
        emitByte(jz)          // if false, jump
        p1 = hole()           // make room forjump dest
        codeGen(x.right.left) // if true statements
        if x.right.right != nil {
            emitByte(jmp)
            p2 = hole()
        }
        emitWordAt(p1, len(object)-p1)
        if x.right.right != nil {
            codeGen(x.right.right)
            emitWordAt(p2, len(object)-p2)
        }
    case ndWhile:
        p1 = len(object)
        codeGen(x.left)                // while expr
        emitByte(jz)                   // if false, jump
        p2 = hole()                    // make room for jump dest
        codeGen(x.right)               // statements
        emitByte(jmp)                  // back to the top
        emitWord(p1 - len(object))     // plug the top
        emitWordAt(p2, len(object)-p2) // plug the 'if false, jump'
    case ndSequence:
        codeGen(x.left)
        codeGen(x.right)
    case ndPrtc:
        codeGen(x.left)
        emitByte(prtc)
    case ndPrti:
        codeGen(x.left)
        emitByte(prti)
    case ndPrts:
        codeGen(x.left)
        emitByte(prts)
    case ndLss, ndGtr, ndLeq, ndGeq, ndEql, ndNeq,
        ndAnd, ndOr, ndSub, ndAdd, ndDiv, ndMul, ndMod:
        codeGen(x.left)
        codeGen(x.right)
        emitByte(nodeType2Op(x.nodeType))
    case ndNegate, ndNot:
        codeGen(x.left)
        emitByte(nodeType2Op(x.nodeType))
    default:
        msg := fmt.Sprintf("error in code generator - found %d, expecting operator\n", x.nodeType)
        reportError(msg)
    }
}

func codeFinish() {
    emitByte(halt)
}

func listCode() {
    fmt.Printf("Datasize: %d Strings: %d\n", len(globals), len(stringPool))
    for _, s := range stringPool {
        fmt.Println(s)
    }
    pc := 0
    for pc < len(object) {
        fmt.Printf("%5d ", pc)
        op := object[pc]
        pc++
        switch op {
        case fetch:
            x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
            fmt.Printf("fetch [%d]\n", x)
            pc += 4
        case store:
            x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
            fmt.Printf("store [%d]\n", x)
            pc += 4
        case push:
            x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
            fmt.Printf("push  %d\n", x)
            pc += 4
        case add:
            fmt.Println("add")
        case sub:
            fmt.Println("sub")
        case mul:
            fmt.Println("mul")
        case div:
            fmt.Println("div")
        case mod:
            fmt.Println("mod")
        case lt:
            fmt.Println("lt")
        case gt:
            fmt.Println("gt")
        case le:
            fmt.Println("le")
        case ge:
            fmt.Println("ge")
        case eq:
            fmt.Println("eq")
        case ne:
            fmt.Println("ne")
        case and:
            fmt.Println("and")
        case or:
            fmt.Println("or")
        case neg:
            fmt.Println("neg")
        case not:
            fmt.Println("not")
        case jmp:
            x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
            fmt.Printf("jmp    (%d) %d\n", x, int32(pc)+x)
            pc += 4
        case jz:
            x := int32(binary.LittleEndian.Uint32(object[pc : pc+4]))
            fmt.Printf("jz     (%d) %d\n", x, int32(pc)+x)
            pc += 4
        case prtc:
            fmt.Println("prtc")
        case prti:
            fmt.Println("prti")
        case prts:
            fmt.Println("prts")
        case halt:
            fmt.Println("halt")
        default:
            reportError(fmt.Sprintf("listCode: Unknown opcode %d", op))
        }
    }
}

func getEnumValue(name string) NodeType {
    for _, atr := range atrs {
        if atr.enumText == name {
            return atr.nodeType
        }
    }
    reportError(fmt.Sprintf("Unknown token %s\n", name))
    return -1
}

func loadAst() *Tree {
    var nodeType NodeType
    var s string
    if scanner.Scan() {
        line := strings.TrimRight(scanner.Text(), " \t")
        tokens := strings.Fields(line)
        first := tokens[0]
        if first[0] == ';' {
            return nil
        }
        nodeType = getEnumValue(first)
        le := len(tokens)
        if le == 2 {
            s = tokens[1]
        } else if le > 2 {
            idx := strings.Index(line, `"`)
            s = line[idx:]
        }
    }
    check(scanner.Err())
    if s != "" {
        return makeLeaf(nodeType, s)
    }
    left := loadAst()
    right := loadAst()
    return makeNode(nodeType, left, right)
}

func main() {
    ast, err := os.Open("ast.txt")
    check(err)
    defer ast.Close()
    scanner = bufio.NewScanner(ast)
    codeGen(loadAst())
    codeFinish()
    listCode()
}