Rosetta Code

Compiler/virtual machine interpreter: Difference between revisions

Page Discussion

Compiler/virtual machine interpreter (view source)

Revision as of 20:56, 13 February 2022

46,794 bytes added ,  2 years ago
→‎{{header|Go}}
Line 1,574:
BEGIN C@A+ CELLS OPS + @ EXECUTE AGAIN ;
>HEADER >BYTECODE RUN</lang>
 
=={{header|Fortran}}==
{{works with|gfortran|11.2.1}}
Fortran 2008/2018 code with some limited use of the C preprocessor. If you are on a platform with case-sensitive filenames, and call the source file vm.F90, then gfortran will know to use the C preprocessor.
<lang fortran>module compiler_type_kinds
use, intrinsic :: iso_fortran_env, only: int32
use, intrinsic :: iso_fortran_env, only: int64
 
implicit none
private
 
! Synonyms.
integer, parameter, public :: size_kind = int64
integer, parameter, public :: length_kind = size_kind
integer, parameter, public :: nk = size_kind
 
! Synonyms for character capable of storing a Unicode code point.
integer, parameter, public :: unicode_char_kind = selected_char_kind ('ISO_10646')
integer, parameter, public :: ck = unicode_char_kind
 
! Synonyms for integers capable of storing a Unicode code point.
integer, parameter, public :: unicode_ichar_kind = int32
integer, parameter, public :: ick = unicode_ichar_kind
 
! Synonyms for integers in the virtual machine or the interpreter’s
! runtime. (The Rosetta Code task says integers in the virtual
! machine are 32-bit, but there is nothing in the task that prevents
! us using 64-bit integers in the compiler and interpreter.)
integer, parameter, public :: runtime_int_kind = int64
integer, parameter, public :: rik = runtime_int_kind
end module compiler_type_kinds
 
module helpers
use, non_intrinsic :: compiler_type_kinds, only: nk, rik, ck
 
implicit none
private
 
public :: new_storage_size
public :: next_power_of_two
 
public :: isspace
public :: quoted_string
 
public :: int32_to_vm_bytes
public :: uint32_to_vm_bytes
public :: int32_from_vm_bytes
public :: uint32_from_vm_bytes
 
public :: bool2int
 
character(1, kind = ck), parameter, public :: horizontal_tab_char = char (9, kind = ck)
character(1, kind = ck), parameter, public :: linefeed_char = char (10, kind = ck)
character(1, kind = ck), parameter, public :: vertical_tab_char = char (11, kind = ck)
character(1, kind = ck), parameter, public :: formfeed_char = char (12, kind = ck)
character(1, kind = ck), parameter, public :: carriage_return_char = char (13, kind = ck)
character(1, kind = ck), parameter, public :: space_char = ck_' '
 
! The following is correct for Unix and its relatives.
character(1, kind = ck), parameter, public :: newline_char = linefeed_char
 
character(1, kind = ck), parameter, public :: backslash_char = char (92, kind = ck)
 
contains
 
elemental function new_storage_size (length_needed) result (size)
integer(kind = nk), intent(in) :: length_needed
integer(kind = nk) :: size
 
! Increase storage by orders of magnitude.
 
if (2_nk**32 < length_needed) then
size = huge (1_nk)
else
size = next_power_of_two (length_needed)
end if
end function new_storage_size
 
elemental function next_power_of_two (x) result (y)
integer(kind = nk), intent(in) :: x
integer(kind = nk) :: y
 
!
! It is assumed that no more than 64 bits are used.
!
! The branch-free algorithm is that of
! https://archive.is/nKxAc#RoundUpPowerOf2
!
! Fill in bits until one less than the desired power of two is
! reached, and then add one.
!
 
y = x - 1
y = ior (y, ishft (y, -1))
y = ior (y, ishft (y, -2))
y = ior (y, ishft (y, -4))
y = ior (y, ishft (y, -8))
y = ior (y, ishft (y, -16))
y = ior (y, ishft (y, -32))
y = y + 1
end function next_power_of_two
 
elemental function isspace (ch) result (bool)
character(1, kind = ck), intent(in) :: ch
logical :: bool
 
bool = (ch == horizontal_tab_char) .or. &
& (ch == linefeed_char) .or. &
& (ch == vertical_tab_char) .or. &
& (ch == formfeed_char) .or. &
& (ch == carriage_return_char) .or. &
& (ch == space_char)
end function isspace
 
function quoted_string (str) result (qstr)
character(*, kind = ck), intent(in) :: str
character(:, kind = ck), allocatable :: qstr
 
integer(kind = nk) :: n, i, j
 
! Compute n = the size of qstr.
n = 2_nk
do i = 1_nk, len (str, kind = nk)
select case (str(i:i))
case (newline_char, backslash_char)
n = n + 2
case default
n = n + 1
end select
end do
 
allocate (character(n, kind = ck) :: qstr)
 
! Quote the string.
qstr(1:1) = ck_'"'
j = 2_nk
do i = 1_nk, len (str, kind = nk)
select case (str(i:i))
case (newline_char)
qstr(j:j) = backslash_char
qstr((j + 1):(j + 1)) = ck_'n'
j = j + 2
case (backslash_char)
qstr(j:j) = backslash_char
qstr((j + 1):(j + 1)) = backslash_char
j = j + 2
case default
qstr(j:j) = str(i:i)
j = j + 1
end select
end do
if (j /= n) error stop ! Check code correctness.
qstr(n:n) = ck_'"'
end function quoted_string
 
subroutine int32_to_vm_bytes (n, bytes, i)
integer(kind = rik), intent(in) :: n
character(1), intent(inout) :: bytes(0:*)
integer(kind = rik), intent(in) :: i
 
!
! The virtual machine is presumed to be little-endian. Because I
! slightly prefer little-endian.
!
 
bytes(i) = achar (ibits (n, 0, 8))
bytes(i + 1) = achar (ibits (n, 8, 8))
bytes(i + 2) = achar (ibits (n, 16, 8))
bytes(i + 3) = achar (ibits (n, 24, 8))
end subroutine int32_to_vm_bytes
 
subroutine uint32_to_vm_bytes (n, bytes, i)
integer(kind = rik), intent(in) :: n
character(1), intent(inout) :: bytes(0:*)
integer(kind = rik), intent(in) :: i
 
call int32_to_vm_bytes (n, bytes, i)
end subroutine uint32_to_vm_bytes
 
subroutine int32_from_vm_bytes (n, bytes, i)
integer(kind = rik), intent(out) :: n
character(1), intent(in) :: bytes(0:*)
integer(kind = rik), intent(in) :: i
 
!
! The virtual machine is presumed to be little-endian. Because I
! slightly prefer little-endian.
!
 
call uint32_from_vm_bytes (n, bytes, i)
if (ibits (n, 31, 1) == 1) then
! Extend the sign bit.
n = ior (n, not ((2_rik ** 32) - 1))
end if
end subroutine int32_from_vm_bytes
 
subroutine uint32_from_vm_bytes (n, bytes, i)
integer(kind = rik), intent(out) :: n
character(1), intent(in) :: bytes(0:*)
integer(kind = rik), intent(in) :: i
 
!
! The virtual machine is presumed to be little-endian. Because I
! slightly prefer little-endian.
!
 
integer(kind = rik) :: n0, n1, n2, n3
 
n0 = iachar (bytes(i), kind = rik)
n1 = ishft (iachar (bytes(i + 1), kind = rik), 8)
n2 = ishft (iachar (bytes(i + 2), kind = rik), 16)
n3 = ishft (iachar (bytes(i + 3), kind = rik), 24)
n = ior (n0, ior (n1, ior (n2, n3)))
end subroutine uint32_from_vm_bytes
 
elemental function bool2int (bool) result (int)
logical, intent(in) :: bool
integer(kind = rik) :: int
 
if (bool) then
int = 1_rik
else
int = 0_rik
end if
end function bool2int
 
end module helpers
 
module string_buffers
use, intrinsic :: iso_fortran_env, only: error_unit
use, intrinsic :: iso_fortran_env, only: int64
use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
use, non_intrinsic :: helpers
 
implicit none
private
 
public :: strbuf_t
public :: skip_whitespace
public :: skip_non_whitespace
public :: skip_whitespace_backwards
public :: at_end_of_line
 
type :: strbuf_t
integer(kind = nk), private :: len = 0
!
! ‘chars’ is made public for efficient access to the individual
! characters.
!
character(1, kind = ck), allocatable, public :: chars(:)
contains
procedure, pass, private :: ensure_storage => strbuf_t_ensure_storage
procedure, pass :: to_unicode_full_string => strbuf_t_to_unicode_full_string
procedure, pass :: to_unicode_substring => strbuf_t_to_unicode_substring
procedure, pass :: length => strbuf_t_length
procedure, pass :: set => strbuf_t_set
procedure, pass :: append => strbuf_t_append
generic :: to_unicode => to_unicode_full_string
generic :: to_unicode => to_unicode_substring
generic :: assignment(=) => set
end type strbuf_t
 
contains
 
function strbuf_t_to_unicode_full_string (strbuf) result (s)
class(strbuf_t), intent(in) :: strbuf
character(:, kind = ck), allocatable :: s
 
!
! This does not actually ensure that the string is valid Unicode;
! any 31-bit ‘character’ is supported.
!
 
integer(kind = nk) :: i
 
allocate (character(len = strbuf%len, kind = ck) :: s)
do i = 1, strbuf%len
s(i:i) = strbuf%chars(i)
end do
end function strbuf_t_to_unicode_full_string
 
function strbuf_t_to_unicode_substring (strbuf, i, j) result (s)
!
! ‘Extreme’ values of i and j are allowed, as shortcuts for ‘from
! the beginning’, ‘up to the end’, or ‘empty substring’.
!
class(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i, j
character(:, kind = ck), allocatable :: s
 
!
! This does not actually ensure that the string is valid Unicode;
! any 31-bit ‘character’ is supported.
!
 
integer(kind = nk) :: i1, j1
integer(kind = nk) :: n
integer(kind = nk) :: k
 
i1 = max (1_nk, i)
j1 = min (strbuf%len, j)
n = max (0_nk, (j1 - i1) + 1_nk)
 
allocate (character(n, kind = ck) :: s)
do k = 1, n
s(k:k) = strbuf%chars(i1 + (k - 1_nk))
end do
end function strbuf_t_to_unicode_substring
 
elemental function strbuf_t_length (strbuf) result (n)
class(strbuf_t), intent(in) :: strbuf
integer(kind = nk) :: n
 
n = strbuf%len
end function strbuf_t_length
 
subroutine strbuf_t_ensure_storage (strbuf, length_needed)
class(strbuf_t), intent(inout) :: strbuf
integer(kind = nk), intent(in) :: length_needed
 
integer(kind = nk) :: len_needed
integer(kind = nk) :: new_size
type(strbuf_t) :: new_strbuf
 
len_needed = max (length_needed, 1_nk)
 
if (.not. allocated (strbuf%chars)) then
! Initialize a new strbuf%chars array.
new_size = new_storage_size (len_needed)
allocate (strbuf%chars(1:new_size))
else if (ubound (strbuf%chars, 1) < len_needed) then
! Allocate a new strbuf%chars array, larger than the current
! one, but containing the same characters.
new_size = new_storage_size (len_needed)
allocate (new_strbuf%chars(1:new_size))
new_strbuf%chars(1:strbuf%len) = strbuf%chars(1:strbuf%len)
call move_alloc (new_strbuf%chars, strbuf%chars)
end if
end subroutine strbuf_t_ensure_storage
 
subroutine strbuf_t_set (dst, src)
class(strbuf_t), intent(inout) :: dst
class(*), intent(in) :: src
 
integer(kind = nk) :: n
integer(kind = nk) :: i
 
select type (src)
type is (character(*, kind = ck))
n = len (src, kind = nk)
call dst%ensure_storage(n)
do i = 1, n
dst%chars(i) = src(i:i)
end do
dst%len = n
type is (character(*))
n = len (src, kind = nk)
call dst%ensure_storage(n)
do i = 1, n
dst%chars(i) = src(i:i)
end do
dst%len = n
class is (strbuf_t)
n = src%len
call dst%ensure_storage(n)
dst%chars(1:n) = src%chars(1:n)
dst%len = n
class default
error stop
end select
end subroutine strbuf_t_set
 
subroutine strbuf_t_append (dst, src)
class(strbuf_t), intent(inout) :: dst
class(*), intent(in) :: src
 
integer(kind = nk) :: n_dst, n_src, n
integer(kind = nk) :: i
 
select type (src)
type is (character(*, kind = ck))
n_dst = dst%len
n_src = len (src, kind = nk)
n = n_dst + n_src
call dst%ensure_storage(n)
do i = 1, n_src
dst%chars(n_dst + i) = src(i:i)
end do
dst%len = n
type is (character(*))
n_dst = dst%len
n_src = len (src, kind = nk)
n = n_dst + n_src
call dst%ensure_storage(n)
do i = 1, n_src
dst%chars(n_dst + i) = src(i:i)
end do
dst%len = n
class is (strbuf_t)
n_dst = dst%len
n_src = src%len
n = n_dst + n_src
call dst%ensure_storage(n)
dst%chars((n_dst + 1):n) = src%chars(1:n_src)
dst%len = n
class default
error stop
end select
end subroutine strbuf_t_append
 
function skip_whitespace (strbuf, i) result (j)
class(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i
integer(kind = nk) :: j
 
logical :: done
 
j = i
done = .false.
do while (.not. done)
if (at_end_of_line (strbuf, j)) then
done = .true.
else if (.not. isspace (strbuf%chars(j))) then
done = .true.
else
j = j + 1
end if
end do
end function skip_whitespace
 
function skip_non_whitespace (strbuf, i) result (j)
class(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i
integer(kind = nk) :: j
 
logical :: done
 
j = i
done = .false.
do while (.not. done)
if (at_end_of_line (strbuf, j)) then
done = .true.
else if (isspace (strbuf%chars(j))) then
done = .true.
else
j = j + 1
end if
end do
end function skip_non_whitespace
 
function skip_whitespace_backwards (strbuf, i) result (j)
class(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i
integer(kind = nk) :: j
 
logical :: done
 
j = i
done = .false.
do while (.not. done)
if (j == -1) then
done = .true.
else if (.not. isspace (strbuf%chars(j))) then
done = .true.
else
j = j - 1
end if
end do
end function skip_whitespace_backwards
 
function at_end_of_line (strbuf, i) result (bool)
class(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i
logical :: bool
 
bool = (strbuf%length() < i)
end function at_end_of_line
 
end module string_buffers
 
module reading_one_line_from_a_stream
use, intrinsic :: iso_fortran_env, only: input_unit
use, intrinsic :: iso_fortran_env, only: error_unit
use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
use, non_intrinsic :: string_buffers
 
implicit none
private
 
! get_line_from_stream: read an entire input line from a stream into
! a strbuf_t.
public :: get_line_from_stream
 
character(1, kind = ck), parameter :: linefeed_char = char (10, kind = ck)
 
! The following is correct for Unix and its relatives.
character(1, kind = ck), parameter :: newline_char = linefeed_char
 
contains
 
subroutine get_line_from_stream (unit_no, eof, no_newline, strbuf)
integer, intent(in) :: unit_no
logical, intent(out) :: eof ! End of file?
logical, intent(out) :: no_newline ! There is a line but it has no
! newline? (Thus eof also must
! be .true.)
class(strbuf_t), intent(inout) :: strbuf
 
character(1, kind = ck) :: ch
 
strbuf = ''
call get_ch (unit_no, eof, ch)
do while (.not. eof .and. ch /= newline_char)
call strbuf%append (ch)
call get_ch (unit_no, eof, ch)
end do
no_newline = eof .and. (strbuf%length() /= 0)
end subroutine get_line_from_stream
 
subroutine get_ch (unit_no, eof, ch)
!
! Read a single code point from the stream.
!
! Currently this procedure simply inputs ‘ASCII’ bytes rather than
! Unicode code points.
!
integer, intent(in) :: unit_no
logical, intent(out) :: eof
character(1, kind = ck), intent(out) :: ch
 
integer :: stat
character(1) :: c = '*'
 
eof = .false.
 
if (unit_no == input_unit) then
call get_input_unit_char (c, stat)
else
read (unit = unit_no, iostat = stat) c
end if
 
if (stat < 0) then
ch = ck_'*'
eof = .true.
else if (0 < stat) then
write (error_unit, '("Input error with status code ", I0)') stat
stop 1
else
ch = char (ichar (c, kind = ick), kind = ck)
end if
end subroutine get_ch
 
!!!
!!! If you tell gfortran you want -std=f2008 or -std=f2018, you likely
!!! will need to add also -fall-intrinsics or -U__GFORTRAN__
!!!
!!! The first way, you get the FGETC intrinsic. The latter way, you
!!! get the C interface code that uses getchar(3).
!!!
#ifdef __GFORTRAN__
 
subroutine get_input_unit_char (c, stat)
!
! The following works if you are using gfortran.
!
! (FGETC is considered a feature for backwards compatibility with
! g77. However, I know of no way to reconfigure input_unit as a
! Fortran 2003 stream, for use with ordinary ‘read’.)
!
character, intent(inout) :: c
integer, intent(out) :: stat
 
call fgetc (input_unit, c, stat)
end subroutine get_input_unit_char
 
#else
 
subroutine get_input_unit_char (c, stat)
!
! An alternative implementation of get_input_unit_char. This
! actually reads input from the C standard input, which might not
! be the same as input_unit.
!
use, intrinsic :: iso_c_binding, only: c_int
character, intent(inout) :: c
integer, intent(out) :: stat
 
interface
!
! Use getchar(3) to read characters from standard input. This
! assumes there is actually such a function available, and that
! getchar(3) does not exist solely as a macro. (One could write
! one’s own getchar() if necessary, of course.)
!
function getchar () result (c) bind (c, name = 'getchar')
use, intrinsic :: iso_c_binding, only: c_int
integer(kind = c_int) :: c
end function getchar
end interface
 
integer(kind = c_int) :: i_char
 
i_char = getchar ()
!
! The C standard requires that EOF have a negative value. If the
! value returned by getchar(3) is not EOF, then it will be
! representable as an unsigned char. Therefore, to check for end
! of file, one need only test whether i_char is negative.
!
if (i_char < 0) then
stat = -1
else
stat = 0
c = char (i_char)
end if
end subroutine get_input_unit_char
 
#endif
 
end module reading_one_line_from_a_stream
 
module vm_reader
use, intrinsic :: iso_fortran_env, only: error_unit
use, non_intrinsic :: compiler_type_kinds
use, non_intrinsic :: helpers
use, non_intrinsic :: string_buffers
use, non_intrinsic :: reading_one_line_from_a_stream
 
implicit none
private
 
public :: vm_code_t
public :: vm_t
public :: read_vm
 
!
! Arbitrarily chosen opcodes.
!
! I think there should be a no-operation ‘nop’ opcode, to reserve
! space for later hand-patching. :)
!
integer, parameter, public :: opcode_nop = 0
integer, parameter, public :: opcode_halt = 1
integer, parameter, public :: opcode_add = 2
integer, parameter, public :: opcode_sub = 3
integer, parameter, public :: opcode_mul = 4
integer, parameter, public :: opcode_div = 5
integer, parameter, public :: opcode_mod = 6
integer, parameter, public :: opcode_lt = 7
integer, parameter, public :: opcode_gt = 8
integer, parameter, public :: opcode_le = 9
integer, parameter, public :: opcode_ge = 10
integer, parameter, public :: opcode_eq = 11
integer, parameter, public :: opcode_ne = 12
integer, parameter, public :: opcode_and = 13
integer, parameter, public :: opcode_or = 14
integer, parameter, public :: opcode_neg = 15
integer, parameter, public :: opcode_not = 16
integer, parameter, public :: opcode_prtc = 17
integer, parameter, public :: opcode_prti = 18
integer, parameter, public :: opcode_prts = 19
integer, parameter, public :: opcode_fetch = 20
integer, parameter, public :: opcode_store = 21
integer, parameter, public :: opcode_push = 22
integer, parameter, public :: opcode_jmp = 23
integer, parameter, public :: opcode_jz = 24
 
character(8, kind = ck), parameter, public :: opcode_names(0:24) = &
& (/ "nop ", &
& "halt ", &
& "add ", &
& "sub ", &
& "mul ", &
& "div ", &
& "mod ", &
& "lt ", &
& "gt ", &
& "le ", &
& "ge ", &
& "eq ", &
& "ne ", &
& "and ", &
& "or ", &
& "neg ", &
& "not ", &
& "prtc ", &
& "prti ", &
& "prts ", &
& "fetch ", &
& "store ", &
& "push ", &
& "jmp ", &
& "jz " /)
 
type :: vm_code_t
integer(kind = rik), private :: len = 0_rik
character(1), allocatable :: bytes(:)
contains
procedure, pass, private :: ensure_storage => vm_code_t_ensure_storage
procedure, pass :: length => vm_code_t_length
end type vm_code_t
 
type :: vm_t
integer(kind = rik), allocatable :: string_boundaries(:)
character(:, kind = ck), allocatable :: strings
character(1), allocatable :: data(:)
character(1), allocatable :: stack(:)
type(vm_code_t) :: code
integer(kind = rik) :: sp = 0_rik
integer(kind = rik) :: pc = 0_rik
end type vm_t
 
contains
 
subroutine vm_code_t_ensure_storage (code, length_needed)
class(vm_code_t), intent(inout) :: code
integer(kind = nk), intent(in) :: length_needed
 
integer(kind = nk) :: len_needed
integer(kind = nk) :: new_size
type(vm_code_t) :: new_code
 
len_needed = max (length_needed, 1_nk)
 
if (.not. allocated (code%bytes)) then
! Initialize a new code%bytes array.
new_size = new_storage_size (len_needed)
allocate (code%bytes(0:(new_size - 1)))
else if (ubound (code%bytes, 1) < len_needed - 1) then
! Allocate a new code%bytes array, larger than the current one,
! but containing the same bytes.
new_size = new_storage_size (len_needed)
allocate (new_code%bytes(0:(new_size - 1)))
new_code%bytes(0:(code%len - 1)) = code%bytes(0:(code%len - 1))
call move_alloc (new_code%bytes, code%bytes)
end if
end subroutine vm_code_t_ensure_storage
 
elemental function vm_code_t_length (code) result (len)
class(vm_code_t), intent(in) :: code
integer(kind = rik) :: len
 
len = code%len
end function vm_code_t_length
 
subroutine read_vm (inp, strbuf, vm)
integer, intent(in) :: inp
type(strbuf_t), intent(inout) :: strbuf
type(vm_t), intent(out) :: vm
 
integer(kind = rik) :: data_size
integer(kind = rik) :: number_of_strings
 
! Read the header.
call read_datasize_and_number_of_strings (inp, strbuf, data_size, number_of_strings)
 
! Allocate storage for data_size 32-bit numbers. Initialize them
! to zero, for no better reason than that C initializes global
! variables to zero.
allocate (vm%data(0_rik:(4_rik * (data_size - 1))), source = achar (0))
 
! Allocate storage for indices/bounds of the strings to be loaded
! into the string storage space.
allocate (vm%string_boundaries(0_rik:number_of_strings))
 
! Fill the strings storage and the string boundaries array.
call read_strings (inp, strbuf, number_of_strings, vm)
 
! Read the program instructions.
call read_code (inp, strbuf, vm)
 
! Allocate a stack. Let us say that the stack size must be a
! multiple of 4, and is fixed at 65536 = 4**8 bytes. Pushing a
! 32-bit integer increases the stack pointer by 4, popping
! decreases it by 4.
allocate (vm%stack(0_rik:(4_rik ** 8)))
end subroutine read_vm
 
subroutine read_datasize_and_number_of_strings (inp, strbuf, data_size, number_of_strings)
integer, intent(in) :: inp
type(strbuf_t), intent(inout) :: strbuf
integer(kind = rik), intent(out) :: data_size
integer(kind = rik), intent(out) :: number_of_strings
 
logical :: eof
logical :: no_newline
integer(kind = nk) :: i, j
character(:, kind = ck), allocatable :: data_size_str
character(:, kind = ck), allocatable :: number_of_strings_str
integer :: stat
 
call get_line_from_stream (inp, eof, no_newline, strbuf)
if (eof) call bad_vm_assembly
 
i = skip_whitespace (strbuf, 1_nk)
i = skip_datasize_keyword (strbuf, i)
i = skip_whitespace (strbuf, i)
i = skip_specific_character (strbuf, i, ck_':')
i = skip_whitespace (strbuf, i)
j = skip_non_whitespace (strbuf, i)
if (j == i) call bad_vm_assembly
allocate (data_size_str, source = strbuf%to_unicode (i, j - 1))
 
i = skip_whitespace(strbuf, j)
i = skip_strings_keyword (strbuf, i)
i = skip_whitespace (strbuf, i)
i = skip_specific_character (strbuf, i, ck_':')
i = skip_whitespace (strbuf, i)
j = skip_non_whitespace (strbuf, i)
if (j == i) call bad_vm_assembly
allocate (number_of_strings_str, source = strbuf%to_unicode (i, j - 1))
 
read (data_size_str, *, iostat = stat) data_size
if (stat /= 0) call bad_vm_assembly
read (number_of_strings_str, *, iostat = stat) number_of_strings
if (stat /= 0) call bad_vm_assembly
end subroutine read_datasize_and_number_of_strings
 
subroutine read_strings (inp, strbuf, number_of_strings, vm)
integer, intent(in) :: inp
type(strbuf_t), intent(inout) :: strbuf
integer(kind = rik), intent(in) :: number_of_strings
type(vm_t), intent(inout) :: vm
 
type(strbuf_t) :: strings_temporary
integer(kind = rik) :: i
 
vm%string_boundaries(0) = 0_rik
do i = 0_rik, number_of_strings - 1
call read_one_string (inp, strbuf, strings_temporary)
vm%string_boundaries(i + 1) = strings_temporary%length()
end do
allocate (vm%strings, source = strings_temporary%to_unicode())
end subroutine read_strings
 
subroutine read_one_string (inp, strbuf, strings_temporary)
integer, intent(in) :: inp
type(strbuf_t), intent(inout) :: strbuf
type(strbuf_t), intent(inout) :: strings_temporary
 
logical :: eof
logical :: no_newline
integer(kind = nk) :: i
logical :: done
 
call get_line_from_stream (inp, eof, no_newline, strbuf)
if (eof) call bad_vm_assembly
i = skip_whitespace (strbuf, 1_nk)
i = skip_specific_character (strbuf, i, ck_'"')
done = .false.
do while (.not. done)
if (i == strbuf%length() + 1) call bad_vm_assembly
if (strbuf%chars(i) == ck_'"') then
done = .true.
else if (strbuf%chars(i) == backslash_char) then
if (i == strbuf%length()) call bad_vm_assembly
select case (strbuf%chars(i + 1))
case (ck_'n')
call strings_temporary%append(newline_char)
case (backslash_char)
call strings_temporary%append(backslash_char)
case default
call bad_vm_assembly
end select
i = i + 2
else
call strings_temporary%append(strbuf%chars(i))
i = i + 1
end if
end do
end subroutine read_one_string
 
subroutine read_code (inp, strbuf, vm)
integer, intent(in) :: inp
type(strbuf_t), intent(inout) :: strbuf
type(vm_t), intent(inout) :: vm
 
logical :: eof
logical :: no_newline
 
call get_line_from_stream (inp, eof, no_newline, strbuf)
do while (.not. eof)
call parse_instruction (strbuf, vm%code)
call get_line_from_stream (inp, eof, no_newline, strbuf)
end do
end subroutine read_code
 
subroutine parse_instruction (strbuf, code)
type(strbuf_t), intent(in) :: strbuf
type(vm_code_t), intent(inout) :: code
 
integer(kind = nk) :: i, j
integer :: stat
 
integer :: opcode
integer(kind = rik) :: i_vm
integer(kind = rik) :: arg
 
character(8, kind = ck) :: opcode_name_str
character(:, kind = ck), allocatable :: i_vm_str
character(:, kind = ck), allocatable :: arg_str
 
i = skip_whitespace (strbuf, 1_nk)
j = skip_non_whitespace (strbuf, i)
if (j == i) call bad_vm_assembly
allocate (i_vm_str, source = strbuf%to_unicode(i, j - 1))
read (i_vm_str, *, iostat = stat) i_vm
if (stat /= 0) call bad_vm_assembly
 
i = skip_whitespace (strbuf, j)
j = skip_non_whitespace (strbuf, i)
opcode_name_str = ck_' '
opcode_name_str(1:(j - i)) = strbuf%to_unicode(i, j - 1)
opcode = findloc (opcode_names, opcode_name_str, 1) - 1
if (opcode == -1) call bad_vm_assembly
 
select case (opcode)
 
case (opcode_push)
call code%ensure_storage(i_vm + 5)
code%bytes(i_vm) = achar (opcode)
i = skip_whitespace (strbuf, j)
j = skip_non_whitespace (strbuf, i)
if (j == i) call bad_vm_assembly
allocate (arg_str, source = strbuf%to_unicode(i, j - 1))
read (arg_str, *, iostat = stat) arg
if (stat /= 0) call bad_vm_assembly
call int32_to_vm_bytes (arg, code%bytes, i_vm + 1)
code%len = max (code%len, i_vm + 5)
 
case (opcode_fetch, opcode_store)
call code%ensure_storage(i_vm + 5)
code%bytes(i_vm) = achar (opcode)
i = skip_whitespace (strbuf, j)
i = skip_specific_character (strbuf, i, ck_'[')
i = skip_whitespace (strbuf, i)
j = skip_non_whitespace (strbuf, i)
if (j == i) call bad_vm_assembly
if (strbuf%chars(j - 1) == ck_']') j = j - 1
allocate (arg_str, source = strbuf%to_unicode(i, j - 1))
read (arg_str, *, iostat = stat) arg
if (stat /= 0) call bad_vm_assembly
call uint32_to_vm_bytes (arg, code%bytes, i_vm + 1)
code%len = max (code%len, i_vm + 5)
 
case (opcode_jmp, opcode_jz)
call code%ensure_storage(i_vm + 5)
code%bytes(i_vm) = achar (opcode)
call code%ensure_storage(i_vm + 5)
code%bytes(i_vm) = achar (opcode)
i = skip_whitespace (strbuf, j)
i = skip_specific_character (strbuf, i, ck_'(')
i = skip_whitespace (strbuf, i)
j = skip_non_whitespace (strbuf, i)
if (j == i) call bad_vm_assembly
if (strbuf%chars(j - 1) == ck_')') j = j - 1
allocate (arg_str, source = strbuf%to_unicode(i, j - 1))
read (arg_str, *, iostat = stat) arg
if (stat /= 0) call bad_vm_assembly
call int32_to_vm_bytes (arg, code%bytes, i_vm + 1)
code%len = max (code%len, i_vm + 5)
 
case default
call code%ensure_storage(i_vm + 1)
code%bytes(i_vm) = achar (opcode)
code%len = max (code%len, i_vm + 1)
end select
 
end subroutine parse_instruction
 
function skip_datasize_keyword (strbuf, i) result (j)
type(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i
integer(kind = nk) :: j
 
j = skip_specific_character (strbuf, i, ck_'D')
j = skip_specific_character (strbuf, j, ck_'a')
j = skip_specific_character (strbuf, j, ck_'t')
j = skip_specific_character (strbuf, j, ck_'a')
j = skip_specific_character (strbuf, j, ck_'s')
j = skip_specific_character (strbuf, j, ck_'i')
j = skip_specific_character (strbuf, j, ck_'z')
j = skip_specific_character (strbuf, j, ck_'e')
end function skip_datasize_keyword
 
function skip_strings_keyword (strbuf, i) result (j)
type(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i
integer(kind = nk) :: j
 
j = skip_specific_character (strbuf, i, ck_'S')
j = skip_specific_character (strbuf, j, ck_'t')
j = skip_specific_character (strbuf, j, ck_'r')
j = skip_specific_character (strbuf, j, ck_'i')
j = skip_specific_character (strbuf, j, ck_'n')
j = skip_specific_character (strbuf, j, ck_'g')
j = skip_specific_character (strbuf, j, ck_'s')
end function skip_strings_keyword
 
function skip_specific_character (strbuf, i, ch) result (j)
type(strbuf_t), intent(in) :: strbuf
integer(kind = nk), intent(in) :: i
character(1, kind = ck), intent(in) :: ch
integer(kind = nk) :: j
 
if (strbuf%length() < i) call bad_vm_assembly
if (strbuf%chars(i) /= ch) call bad_vm_assembly
j = i + 1
end function skip_specific_character
 
subroutine bad_vm_assembly
write (error_unit, '("The input is not a correct virtual machine program.")')
stop 1
end subroutine bad_vm_assembly
 
end module vm_reader
 
module vm_runner
use, intrinsic :: iso_fortran_env, only: error_unit
use, non_intrinsic :: compiler_type_kinds
use, non_intrinsic :: helpers
use, non_intrinsic :: vm_reader
 
implicit none
private
 
public :: run_vm
 
contains
 
subroutine run_vm (outp, vm)
integer, intent(in) :: outp
type(vm_t), intent(inout) :: vm
 
logical :: done
integer :: opcode
 
vm%sp = 0
vm%pc = 0
done = .false.
do while (.not. done)
if (vm%pc < 0 .or. vm%code%length() <= vm%pc) call pc_error
opcode = iachar (vm%code%bytes(vm%pc))
vm%pc = vm%pc + 1
select case (opcode)
case (opcode_nop)
continue
case (opcode_halt)
done = .true.
case (opcode_add)
call alu_add (vm)
case (opcode_sub)
call alu_sub (vm)
case (opcode_mul)
call alu_mul (vm)
case (opcode_div)
call alu_div (vm)
case (opcode_mod)
call alu_mod (vm)
case (opcode_lt)
call alu_lt (vm)
case (opcode_gt)
call alu_gt (vm)
case (opcode_le)
call alu_le (vm)
case (opcode_ge)
call alu_ge (vm)
case (opcode_eq)
call alu_eq (vm)
case (opcode_ne)
call alu_ne (vm)
case (opcode_and)
call alu_and (vm)
case (opcode_or)
call alu_or (vm)
case (opcode_neg)
call alu_neg (vm)
case (opcode_not)
call alu_not (vm)
case (opcode_prtc)
call prtc (outp, vm)
case (opcode_prti)
call prti (outp, vm)
case (opcode_prts)
call prts (outp, vm)
case (opcode_fetch)
call fetch_int32 (vm)
case (opcode_store)
call store_int32 (vm)
case (opcode_push)
call push_int32 (vm)
case (opcode_jmp)
call jmp (vm)
case (opcode_jz)
call jz (vm)
case default
write (error_unit, '("VM opcode unrecognized: ", I0)') opcode
stop 1
end select
end do
end subroutine run_vm
 
subroutine push_int32 (vm)
type(vm_t), intent(inout) :: vm
 
!
! Push the 32-bit integer data at pc to the stack, then increment
! pc by 4.
!
 
if (ubound (vm%stack, 1) < vm%sp) then
write (error_unit, '("VM stack overflow")')
stop 1
end if
if (vm%code%length() <= vm%pc + 4) call pc_error
vm%stack(vm%sp:(vm%sp + 3)) = vm%code%bytes(vm%pc:(vm%pc + 3))
vm%sp = vm%sp + 4
vm%pc = vm%pc + 4
end subroutine push_int32
 
subroutine fetch_int32 (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: i
integer(kind = rik) :: x
 
if (vm%code%length() <= vm%pc + 4) call pc_error
call uint32_from_vm_bytes (i, vm%code%bytes, vm%pc)
vm%pc = vm%pc + 4
 
if (ubound (vm%data, 1) < i * 4) then
write (error_unit, '("VM data access error")')
stop 1
end if
call int32_from_vm_bytes (x, vm%data, i * 4)
 
if (ubound (vm%stack, 1) < vm%sp) then
write (error_unit, '("VM stack overflow")')
stop 1
end if
call int32_to_vm_bytes (x, vm%stack, vm%sp)
vm%sp = vm%sp + 4
end subroutine fetch_int32
 
subroutine store_int32 (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: i
integer(kind = rik) :: x
 
if (vm%code%length() <= vm%pc + 4) call pc_error
call uint32_from_vm_bytes (i, vm%code%bytes, vm%pc)
vm%pc = vm%pc + 4
 
call ensure_there_is_enough_stack_data (vm, 4_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 4)
vm%sp = vm%sp - 4
 
if (ubound (vm%data, 1) < i * 4) then
write (error_unit, '("VM data access error")')
stop 1
end if
call int32_to_vm_bytes (x, vm%data, i * 4)
end subroutine store_int32
 
subroutine jmp (vm)
type(vm_t), intent(inout) :: vm
 
!
! Add the 32-bit data at pc to pc itself.
!
 
integer(kind = rik) :: x
 
if (vm%code%length() <= vm%pc + 4) call pc_error
call int32_from_vm_bytes (x, vm%code%bytes, vm%pc)
vm%pc = vm%pc + x
end subroutine jmp
 
subroutine jz (vm)
type(vm_t), intent(inout) :: vm
 
!
! Conditionally add the 32-bit data at pc to pc itself.
!
 
integer(kind = rik) :: x
 
call ensure_there_is_enough_stack_data (vm, 4_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 4)
vm%sp = vm%sp - 4
if (x == 0) then
if (vm%code%length() <= vm%pc + 4) call pc_error
call int32_from_vm_bytes (x, vm%code%bytes, vm%pc)
vm%pc = vm%pc + x
else
vm%pc = vm%pc + 4
end if
end subroutine jz
 
subroutine alu_neg (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x
 
call ensure_there_is_enough_stack_data (vm, 4_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 4)
x = -x
call int32_to_vm_bytes (x, vm%stack, vm%sp - 4)
end subroutine alu_neg
 
subroutine alu_not (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x
 
call ensure_there_is_enough_stack_data (vm, 4_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 4)
x = bool2int (x == 0_rik)
call int32_to_vm_bytes (x, vm%stack, vm%sp - 4)
end subroutine alu_not
 
subroutine alu_add (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = x + y
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_add
 
subroutine alu_sub (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = x - y
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_sub
 
subroutine alu_mul (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = x * y
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_mul
 
subroutine alu_div (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = x / y ! This works like ‘/’ in C.
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_div
 
subroutine alu_mod (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = mod (x, y) ! This works like ‘%’ in C.
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_mod
 
subroutine alu_lt (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = bool2int (x < y)
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_lt
 
subroutine alu_gt (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = bool2int (x > y)
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_gt
 
subroutine alu_le (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = bool2int (x <= y)
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_le
 
subroutine alu_ge (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = bool2int (x >= y)
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_ge
 
subroutine alu_eq (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = bool2int (x == y)
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_eq
 
subroutine alu_ne (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = bool2int (x /= y)
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_ne
 
subroutine alu_and (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = bool2int (x /= 0 .and. y /= 0)
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_and
 
subroutine alu_or (vm)
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x, y, z
 
call ensure_there_is_enough_stack_data (vm, 8_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 8)
call int32_from_vm_bytes (y, vm%stack, vm%sp - 4)
z = bool2int (x /= 0 .or. y /= 0)
call int32_to_vm_bytes (z, vm%stack, vm%sp - 8)
vm%sp = vm%sp - 4
end subroutine alu_or
 
subroutine ensure_there_is_enough_stack_data (vm, n)
type(vm_t), intent(in) :: vm
integer(kind = rik), intent(in) :: n
 
if (vm%sp < n) then
write (error_unit, '("VM stack underflow")')
stop 1
end if
end subroutine ensure_there_is_enough_stack_data
 
subroutine prtc (outp, vm)
integer, intent(in) :: outp
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x
 
call ensure_there_is_enough_stack_data (vm, 4_rik)
call uint32_from_vm_bytes (x, vm%stack, vm%sp - 4)
write (outp, '(A1)', advance = 'no') char (x, kind = ck)
vm%sp = vm%sp - 4
end subroutine prtc
 
subroutine prti (outp, vm)
integer, intent(in) :: outp
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x
 
call ensure_there_is_enough_stack_data (vm, 4_rik)
call int32_from_vm_bytes (x, vm%stack, vm%sp - 4)
write (outp, '(I0)', advance = 'no') x
vm%sp = vm%sp - 4
end subroutine prti
 
subroutine prts (outp, vm)
integer, intent(in) :: outp
type(vm_t), intent(inout) :: vm
 
integer(kind = rik) :: x
integer(kind = rik) :: i, j
 
call ensure_there_is_enough_stack_data (vm, 4_rik)
call uint32_from_vm_bytes (x, vm%stack, vm%sp - 4)
if (ubound (vm%string_boundaries, 1) - 1 < x) then
write (error_unit, '("VM string boundary error")')
stop 1
end if
i = vm%string_boundaries(x)
j = vm%string_boundaries(x + 1)
write (outp, '(A)', advance = 'no') vm%strings((i + 1):j)
vm%sp = vm%sp - 4
end subroutine prts
 
subroutine pc_error
write (error_unit, '("VM program counter error")')
stop 1
end subroutine pc_error
 
end module vm_runner
 
program vm
use, intrinsic :: iso_fortran_env, only: input_unit
use, intrinsic :: iso_fortran_env, only: output_unit
use, intrinsic :: iso_fortran_env, only: error_unit
use, non_intrinsic :: compiler_type_kinds
use, non_intrinsic :: string_buffers
use, non_intrinsic :: vm_reader
use, non_intrinsic :: vm_runner
 
implicit none
 
integer, parameter :: inp_unit_no = 100
integer, parameter :: outp_unit_no = 101
 
integer :: arg_count
character(200) :: arg
integer :: inp
integer :: outp
 
arg_count = command_argument_count ()
if (3 <= arg_count) then
call print_usage
else
if (arg_count == 0) then
inp = input_unit
outp = output_unit
else if (arg_count == 1) then
call get_command_argument (1, arg)
inp = open_for_input (trim (arg))
outp = output_unit
else if (arg_count == 2) then
call get_command_argument (1, arg)
inp = open_for_input (trim (arg))
call get_command_argument (2, arg)
outp = open_for_output (trim (arg))
end if
 
block
type(strbuf_t) :: strbuf
type(vm_t) :: vm
 
call read_vm (inp, strbuf, vm)
call run_vm (outp, vm)
end block
end if
 
contains
 
function open_for_input (filename) result (unit_no)
character(*), intent(in) :: filename
integer :: unit_no
 
integer :: stat
 
open (unit = inp_unit_no, file = filename, status = 'old', &
& action = 'read', access = 'stream', form = 'unformatted', &
& iostat = stat)
if (stat /= 0) then
write (error_unit, '("Error: failed to open ", 1A, " for input")') filename
stop 1
end if
unit_no = inp_unit_no
end function open_for_input
 
function open_for_output (filename) result (unit_no)
character(*), intent(in) :: filename
integer :: unit_no
 
integer :: stat
 
open (unit = outp_unit_no, file = filename, action = 'write', iostat = stat)
if (stat /= 0) then
write (error_unit, '("Error: failed to open ", 1A, " for output")') filename
stop 1
end if
unit_no = outp_unit_no
end function open_for_output
 
subroutine print_usage
character(200) :: progname
 
call get_command_argument (0, progname)
write (output_unit, '("Usage: ", 1A, " [INPUT_FILE [OUTPUT_FILE]]")') &
& trim (progname)
end subroutine print_usage
end program vm</lang>
 
=={{header|Go}}==
Chemoelectric
1,448

edits

Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/271271"