Compiler/virtual machine interpreter: Difference between revisions
Content added Content deleted
m (→{{header|J}}) |
|||
Line 1,574: | Line 1,574: | ||
BEGIN C@A+ CELLS OPS + @ EXECUTE AGAIN ; |
BEGIN C@A+ CELLS OPS + @ EXECUTE AGAIN ; |
||
>HEADER >BYTECODE RUN</lang> |
>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}}== |
=={{header|Go}}== |