1548 lines
49 KiB
FortranFixed
1548 lines
49 KiB
FortranFixed
|
!!!
|
|||
|
|
!!! An implementation of the Rosetta Code parser task:
|
|||
|
|
!!! https://rosettacode.org/wiki/Compiler/syntax_analyzer
|
|||
|
|
!!!
|
|||
|
|
!!! The implementation is based on the published pseudocode.
|
|||
|
|
!!!
|
|||
|
|
|
|||
|
|
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
|
|||
|
|
end module compiler_type_kinds
|
|||
|
|
|
|||
|
|
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
|
|||
|
|
|
|||
|
|
implicit none
|
|||
|
|
private
|
|||
|
|
|
|||
|
|
public :: strbuf_t
|
|||
|
|
|
|||
|
|
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
|
|||
|
|
|
|||
|
|
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 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
|
|||
|
|
|
|||
|
|
subroutine strbuf_t_ensure_storage (strbuf, length_needed)
|
|||
|
|
class(strbuf_t), intent(inout) :: strbuf
|
|||
|
|
integer(kind = nk), intent(in) :: length_needed
|
|||
|
|
|
|||
|
|
integer(kind = nk) :: new_size
|
|||
|
|
type(strbuf_t) :: new_strbuf
|
|||
|
|
|
|||
|
|
if (.not. allocated (strbuf%chars)) then
|
|||
|
|
! Initialize a new strbuf%chars array.
|
|||
|
|
new_size = new_storage_size (length_needed)
|
|||
|
|
allocate (strbuf%chars(1:new_size))
|
|||
|
|
else if (ubound (strbuf%chars, 1) < length_needed) then
|
|||
|
|
! Allocate a new strbuf%chars array, larger than the current
|
|||
|
|
! one, but containing the same characters.
|
|||
|
|
new_size = new_storage_size (length_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
|
|||
|
|
|
|||
|
|
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 lexer_token_facts
|
|||
|
|
implicit none
|
|||
|
|
private
|
|||
|
|
|
|||
|
|
integer, parameter, public :: tk_EOI = 0
|
|||
|
|
integer, parameter, public :: tk_Mul = 1
|
|||
|
|
integer, parameter, public :: tk_Div = 2
|
|||
|
|
integer, parameter, public :: tk_Mod = 3
|
|||
|
|
integer, parameter, public :: tk_Add = 4
|
|||
|
|
integer, parameter, public :: tk_Sub = 5
|
|||
|
|
integer, parameter, public :: tk_Negate = 6
|
|||
|
|
integer, parameter, public :: tk_Not = 7
|
|||
|
|
integer, parameter, public :: tk_Lss = 8
|
|||
|
|
integer, parameter, public :: tk_Leq = 9
|
|||
|
|
integer, parameter, public :: tk_Gtr = 10
|
|||
|
|
integer, parameter, public :: tk_Geq = 11
|
|||
|
|
integer, parameter, public :: tk_Eq = 12
|
|||
|
|
integer, parameter, public :: tk_Neq = 13
|
|||
|
|
integer, parameter, public :: tk_Assign = 14
|
|||
|
|
integer, parameter, public :: tk_And = 15
|
|||
|
|
integer, parameter, public :: tk_Or = 16
|
|||
|
|
integer, parameter, public :: tk_If = 17
|
|||
|
|
integer, parameter, public :: tk_Else = 18
|
|||
|
|
integer, parameter, public :: tk_While = 19
|
|||
|
|
integer, parameter, public :: tk_Print = 20
|
|||
|
|
integer, parameter, public :: tk_Putc = 21
|
|||
|
|
integer, parameter, public :: tk_Lparen = 22
|
|||
|
|
integer, parameter, public :: tk_Rparen = 23
|
|||
|
|
integer, parameter, public :: tk_Lbrace = 24
|
|||
|
|
integer, parameter, public :: tk_Rbrace = 25
|
|||
|
|
integer, parameter, public :: tk_Semi = 26
|
|||
|
|
integer, parameter, public :: tk_Comma = 27
|
|||
|
|
integer, parameter, public :: tk_Ident = 28
|
|||
|
|
integer, parameter, public :: tk_Integer = 29
|
|||
|
|
integer, parameter, public :: tk_String = 30
|
|||
|
|
integer, parameter, public :: tk_Positive = 31
|
|||
|
|
|
|||
|
|
character(16), parameter, public :: lexer_token_string(0:31) = &
|
|||
|
|
(/ "EOI ", &
|
|||
|
|
& "* ", &
|
|||
|
|
& "/ ", &
|
|||
|
|
& "% ", &
|
|||
|
|
& "+ ", &
|
|||
|
|
& "- ", &
|
|||
|
|
& "- ", &
|
|||
|
|
& "! ", &
|
|||
|
|
& "< ", &
|
|||
|
|
& "<= ", &
|
|||
|
|
& "> ", &
|
|||
|
|
& ">= ", &
|
|||
|
|
& "== ", &
|
|||
|
|
& "!= ", &
|
|||
|
|
& "= ", &
|
|||
|
|
& "&& ", &
|
|||
|
|
& "|| ", &
|
|||
|
|
& "if ", &
|
|||
|
|
& "else ", &
|
|||
|
|
& "while ", &
|
|||
|
|
& "print ", &
|
|||
|
|
& "putc ", &
|
|||
|
|
& "( ", &
|
|||
|
|
& ") ", &
|
|||
|
|
& "{ ", &
|
|||
|
|
& "} ", &
|
|||
|
|
& "; ", &
|
|||
|
|
& ", ", &
|
|||
|
|
& "Ident ", &
|
|||
|
|
& "Integer literal ", &
|
|||
|
|
& "String literal ", &
|
|||
|
|
& "+ " /)
|
|||
|
|
|
|||
|
|
integer, parameter, public :: lexer_token_arity(0:31) = &
|
|||
|
|
& (/ -1, & ! EOI
|
|||
|
|
& 2, 2, 2, 2, 2, & ! * / % + -
|
|||
|
|
& 1, 1, & ! negate !
|
|||
|
|
& 2, 2, 2, 2, 2, 2, & ! < <= > >= == !=
|
|||
|
|
& -1, & ! =
|
|||
|
|
& 2, 2, & ! && ||
|
|||
|
|
& -1, -1, -1, -1, -1, & !
|
|||
|
|
& -1, -1, -1, -1, -1, & !
|
|||
|
|
& -1, -1, -1, -1, & !
|
|||
|
|
& 1 /) ! positive
|
|||
|
|
|
|||
|
|
integer, parameter, public :: lexer_token_precedence(0:31) = &
|
|||
|
|
& (/ -1, & ! EOI
|
|||
|
|
& 13, 13, 13, & ! * / %
|
|||
|
|
& 12, 12, & ! + -
|
|||
|
|
& 14, 14, & ! negate !
|
|||
|
|
& 10, 10, 10, 10, & ! < <= > >=
|
|||
|
|
& 9, 9, & ! == !=
|
|||
|
|
& -1, & ! =
|
|||
|
|
& 5, & ! &&
|
|||
|
|
& 4, & ! ||
|
|||
|
|
& -1, -1, -1, -1, -1, & !
|
|||
|
|
& -1, -1, -1, -1, -1, & !
|
|||
|
|
& -1, -1, -1, -1, & !
|
|||
|
|
& 14 /) ! positive
|
|||
|
|
|
|||
|
|
integer, parameter, public :: left_associative = 0
|
|||
|
|
integer, parameter, public :: right_associative = 1
|
|||
|
|
|
|||
|
|
! All current operators are left associative. (The values in the
|
|||
|
|
! array for things that are not operators are unimportant.)
|
|||
|
|
integer, parameter, public :: lexer_token_associativity(0:31) = left_associative
|
|||
|
|
|
|||
|
|
end module lexer_token_facts
|
|||
|
|
|
|||
|
|
module reading_of_lexer_tokens
|
|||
|
|
use, intrinsic :: iso_fortran_env, only: error_unit
|
|||
|
|
use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
|
|||
|
|
use, non_intrinsic :: string_buffers
|
|||
|
|
use, non_intrinsic :: reading_one_line_from_a_stream
|
|||
|
|
use, non_intrinsic :: lexer_token_facts
|
|||
|
|
|
|||
|
|
implicit none
|
|||
|
|
private
|
|||
|
|
|
|||
|
|
public :: lexer_token_t
|
|||
|
|
public :: get_lexer_token
|
|||
|
|
|
|||
|
|
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_' '
|
|||
|
|
|
|||
|
|
type :: lexer_token_t
|
|||
|
|
integer :: token_no = -(huge (1))
|
|||
|
|
character(:, kind = ck), allocatable :: val
|
|||
|
|
integer(nk) :: line_no = -(huge (1_nk))
|
|||
|
|
integer(nk) :: column_no = -(huge (1_nk))
|
|||
|
|
end type lexer_token_t
|
|||
|
|
|
|||
|
|
contains
|
|||
|
|
|
|||
|
|
subroutine get_lexer_token (unit_no, lex_line_no, eof, token)
|
|||
|
|
!
|
|||
|
|
! Lines that are empty or contain only whitespace are tolerated.
|
|||
|
|
!
|
|||
|
|
! Also tolerated are comment lines, whose first character is a
|
|||
|
|
! '!'. It is convenient for debugging to be able to comment out
|
|||
|
|
! lines.
|
|||
|
|
!
|
|||
|
|
! A last line be without a newline is *not* tolerated, unless it
|
|||
|
|
! contains only whitespace.
|
|||
|
|
!
|
|||
|
|
! Letting there be some whitespace is partly for the sake of
|
|||
|
|
! reading cut-and-paste from a browser display.
|
|||
|
|
!
|
|||
|
|
integer, intent(in) :: unit_no
|
|||
|
|
integer(kind = nk), intent(inout) :: lex_line_no
|
|||
|
|
logical, intent(out) :: eof
|
|||
|
|
type(lexer_token_t), intent(out) :: token
|
|||
|
|
|
|||
|
|
type(strbuf_t) :: strbuf
|
|||
|
|
logical :: no_newline
|
|||
|
|
logical :: input_found
|
|||
|
|
|
|||
|
|
! Let a negative setting initialize the line number.
|
|||
|
|
lex_line_no = max (0_nk, lex_line_no)
|
|||
|
|
|
|||
|
|
strbuf = ''
|
|||
|
|
eof = .false.
|
|||
|
|
input_found = .false.
|
|||
|
|
do while (.not. eof .and. .not. input_found)
|
|||
|
|
call get_line_from_stream (unit_no, eof, no_newline, strbuf)
|
|||
|
|
if (eof) then
|
|||
|
|
if (no_newline) then
|
|||
|
|
lex_line_no = lex_line_no + 1
|
|||
|
|
if (.not. strbuf_is_all_whitespace (strbuf)) then
|
|||
|
|
call start_error_message (lex_line_no)
|
|||
|
|
write (error_unit, '("lexer line ends without a newline")')
|
|||
|
|
stop 1
|
|||
|
|
end if
|
|||
|
|
end if
|
|||
|
|
else
|
|||
|
|
lex_line_no = lex_line_no + 1
|
|||
|
|
input_found = .true.
|
|||
|
|
if (strbuf_is_all_whitespace (strbuf)) then
|
|||
|
|
! A blank line.
|
|||
|
|
input_found = .false.
|
|||
|
|
else if (0 < strbuf%length()) then
|
|||
|
|
if (strbuf%chars(1) == ck_'!') then
|
|||
|
|
! A comment line.
|
|||
|
|
input_found = .false.
|
|||
|
|
end if
|
|||
|
|
end if
|
|||
|
|
end if
|
|||
|
|
end do
|
|||
|
|
|
|||
|
|
token = lexer_token_t ()
|
|||
|
|
if (.not. eof) then
|
|||
|
|
token = strbuf_to_token (lex_line_no, strbuf)
|
|||
|
|
end if
|
|||
|
|
end subroutine get_lexer_token
|
|||
|
|
|
|||
|
|
function strbuf_to_token (lex_line_no, strbuf) result (token)
|
|||
|
|
integer(kind = nk), intent(in) :: lex_line_no
|
|||
|
|
class(strbuf_t), intent(in) :: strbuf
|
|||
|
|
type(lexer_token_t) :: token
|
|||
|
|
|
|||
|
|
character(:, kind = ck), allocatable :: line_no
|
|||
|
|
character(:, kind = ck), allocatable :: column_no
|
|||
|
|
character(:, kind = ck), allocatable :: token_name
|
|||
|
|
character(:, kind = ck), allocatable :: val_string
|
|||
|
|
integer :: stat
|
|||
|
|
integer(kind = nk) :: n
|
|||
|
|
|
|||
|
|
call split_line (lex_line_no, strbuf, line_no, column_no, token_name, val_string)
|
|||
|
|
|
|||
|
|
read (line_no, *, iostat = stat) token%line_no
|
|||
|
|
if (stat /= 0) then
|
|||
|
|
call start_error_message (lex_line_no)
|
|||
|
|
write (error_unit, '("line number field is unreadable or too large")')
|
|||
|
|
stop 1
|
|||
|
|
end if
|
|||
|
|
|
|||
|
|
read (column_no, *, iostat = stat) token%column_no
|
|||
|
|
if (stat /= 0) then
|
|||
|
|
call start_error_message (lex_line_no)
|
|||
|
|
write (error_unit, '("column number field is unreadable or too large")')
|
|||
|
|
stop 1
|
|||
|
|
end if
|
|||
|
|
|
|||
|
|
token%token_no = token_name_to_token_no (lex_line_no, token_name)
|
|||
|
|
|
|||
|
|
select case (token%token_no)
|
|||
|
|
case (tk_Ident)
|
|||
|
|
! I do no checking of identifier names.
|
|||
|
|
allocate (token%val, source = val_string)
|
|||
|
|
case (tk_Integer)
|
|||
|
|
call check_is_all_digits (lex_line_no, val_string)
|
|||
|
|
allocate (token%val, source = val_string)
|
|||
|
|
case (tk_String)
|
|||
|
|
n = len (val_string, kind = nk)
|
|||
|
|
if (n < 2) then
|
|||
|
|
call string_literal_missing_or_no_good
|
|||
|
|
else if (val_string(1:1) /= ck_'"' .or. val_string(n:n) /= ck_'"') then
|
|||
|
|
call string_literal_missing_or_no_good
|
|||
|
|
else
|
|||
|
|
allocate (token%val, source = val_string)
|
|||
|
|
end if
|
|||
|
|
case default
|
|||
|
|
if (len (val_string, kind = nk) /= 0) then
|
|||
|
|
call start_error_message (lex_line_no)
|
|||
|
|
write (error_unit, '("token should not have a value")')
|
|||
|
|
stop 1
|
|||
|
|
end if
|
|||
|
|
end select
|
|||
|
|
|
|||
|
|
contains
|
|||
|
|
|
|||
|
|
subroutine string_literal_missing_or_no_good
|
|||
|
|
call start_error_message (lex_line_no)
|
|||
|
|
write (error_unit, '("""String"" token requires a string literal")')
|
|||
|
|
stop 1
|
|||
|
|
end subroutine string_literal_missing_or_no_good
|
|||
|
|
|
|||
|
|
end function strbuf_to_token
|
|||
|
|
|
|||
|
|
subroutine split_line (lex_line_no, strbuf, line_no, column_no, token_name, val_string)
|
|||
|
|
integer(kind = nk), intent(in) :: lex_line_no
|
|||
|
|
class(strbuf_t), intent(in) :: strbuf
|
|||
|
|
character(:, kind = ck), allocatable, intent(out) :: line_no
|
|||
|
|
character(:, kind = ck), allocatable, intent(out) :: column_no
|
|||
|
|
character(:, kind = ck), allocatable, intent(out) :: token_name
|
|||
|
|
character(:, kind = ck), allocatable, intent(out) :: val_string
|
|||
|
|
|
|||
|
|
integer(kind = nk) :: i, j
|
|||
|
|
|
|||
|
|
i = skip_whitespace (strbuf, 1_nk)
|
|||
|
|
j = skip_non_whitespace (strbuf, i)
|
|||
|
|
line_no = strbuf%to_unicode(i, j - 1)
|
|||
|
|
call check_is_all_digits (lex_line_no, line_no)
|
|||
|
|
|
|||
|
|
i = skip_whitespace (strbuf, j)
|
|||
|
|
j = skip_non_whitespace (strbuf, i)
|
|||
|
|
column_no = strbuf%to_unicode(i, j - 1)
|
|||
|
|
call check_is_all_digits (lex_line_no, column_no)
|
|||
|
|
|
|||
|
|
i = skip_whitespace (strbuf, j)
|
|||
|
|
j = skip_non_whitespace (strbuf, i)
|
|||
|
|
token_name = strbuf%to_unicode(i, j - 1)
|
|||
|
|
|
|||
|
|
i = skip_whitespace (strbuf, j)
|
|||
|
|
if (strbuf%length() < i) then
|
|||
|
|
val_string = ck_''
|
|||
|
|
else if (strbuf%chars(i) == ck_'"') then
|
|||
|
|
j = skip_whitespace_backwards (strbuf, strbuf%length())
|
|||
|
|
if (strbuf%chars(j) == ck_'"') then
|
|||
|
|
val_string = strbuf%to_unicode(i, j)
|
|||
|
|
else
|
|||
|
|
call start_error_message (lex_line_no)
|
|||
|
|
write (error_unit, '("string literal does not end in a double quote")')
|
|||
|
|
stop 1
|
|||
|
|
end if
|
|||
|
|
else
|
|||
|
|
j = skip_non_whitespace (strbuf, i)
|
|||
|
|
val_string = strbuf%to_unicode(i, j - 1)
|
|||
|
|
i = skip_whitespace (strbuf, j)
|
|||
|
|
if (i <= strbuf%length()) then
|
|||
|
|
call start_error_message (lex_line_no)
|
|||
|
|
write (error_unit, '("token line contains unexpected text")')
|
|||
|
|
stop 1
|
|||
|
|
end if
|
|||
|
|
end if
|
|||
|
|
end subroutine split_line
|
|||
|
|
|
|||
|
|
function token_name_to_token_no (lex_line_no, token_name) result (token_no)
|
|||
|
|
integer(kind = nk), intent(in) :: lex_line_no
|
|||
|
|
character(*, kind = ck), intent(in) :: token_name
|
|||
|
|
integer :: token_no
|
|||
|
|
|
|||
|
|
!!
|
|||
|
|
!! This implementation is not optimized in any way, unless the
|
|||
|
|
!! Fortran compiler can optimize the SELECT CASE.
|
|||
|
|
!!
|
|||
|
|
|
|||
|
|
select case (token_name)
|
|||
|
|
case (ck_"End_of_input")
|
|||
|
|
token_no = tk_EOI
|
|||
|
|
case (ck_"Op_multiply")
|
|||
|
|
token_no = tk_Mul
|
|||
|
|
case (ck_"Op_divide")
|
|||
|
|
token_no = tk_Div
|
|||
|
|
case (ck_"Op_mod")
|
|||
|
|
token_no = tk_Mod
|
|||
|
|
case (ck_"Op_add")
|
|||
|
|
token_no = tk_Add
|
|||
|
|
case (ck_"Op_subtract")
|
|||
|
|
token_no = tk_Sub
|
|||
|
|
case (ck_"Op_negate")
|
|||
|
|
token_no = tk_Negate
|
|||
|
|
case (ck_"Op_not")
|
|||
|
|
token_no = tk_Not
|
|||
|
|
case (ck_"Op_less")
|
|||
|
|
token_no = tk_Lss
|
|||
|
|
case (ck_"Op_lessequal ")
|
|||
|
|
token_no = tk_Leq
|
|||
|
|
case (ck_"Op_greater")
|
|||
|
|
token_no = tk_Gtr
|
|||
|
|
case (ck_"Op_greaterequal")
|
|||
|
|
token_no = tk_Geq
|
|||
|
|
case (ck_"Op_equal")
|
|||
|
|
token_no = tk_Eq
|
|||
|
|
case (ck_"Op_notequal")
|
|||
|
|
token_no = tk_Neq
|
|||
|
|
case (ck_"Op_assign")
|
|||
|
|
token_no = tk_Assign
|
|||
|
|
case (ck_"Op_and")
|
|||
|
|
token_no = tk_And
|
|||
|
|
case (ck_"Op_or")
|
|||
|
|
token_no = tk_Or
|
|||
|
|
case (ck_"Keyword_if")
|
|||
|
|
token_no = tk_If
|
|||
|
|
case (ck_"Keyword_else")
|
|||
|
|
token_no = tk_Else
|
|||
|
|
case (ck_"Keyword_while")
|
|||
|
|
token_no = tk_While
|
|||
|
|
case (ck_"Keyword_print")
|
|||
|
|
token_no = tk_Print
|
|||
|
|
case (ck_"Keyword_putc")
|
|||
|
|
token_no = tk_Putc
|
|||
|
|
case (ck_"LeftParen")
|
|||
|
|
token_no = tk_Lparen
|
|||
|
|
case (ck_"RightParen")
|
|||
|
|
token_no = tk_Rparen
|
|||
|
|
case (ck_"LeftBrace")
|
|||
|
|
token_no = tk_Lbrace
|
|||
|
|
case (ck_"RightBrace")
|
|||
|
|
token_no = tk_Rbrace
|
|||
|
|
case (ck_"Semicolon")
|
|||
|
|
token_no = tk_Semi
|
|||
|
|
case (ck_"Comma")
|
|||
|
|
token_no = tk_Comma
|
|||
|
|
case (ck_"Identifier")
|
|||
|
|
token_no = tk_Ident
|
|||
|
|
case (ck_"Integer")
|
|||
|
|
token_no = tk_Integer
|
|||
|
|
case (ck_"String")
|
|||
|
|
token_no = tk_String
|
|||
|
|
case default
|
|||
|
|
call start_error_message (lex_line_no)
|
|||
|
|
write (error_unit, '("unrecognized token name: ", A)') token_name
|
|||
|
|
stop 1
|
|||
|
|
end select
|
|||
|
|
end function token_name_to_token_no
|
|||
|
|
|
|||
|
|
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
|
|||
|
|
|
|||
|
|
elemental function strbuf_is_all_whitespace (strbuf) result (bool)
|
|||
|
|
class(strbuf_t), intent(in) :: strbuf
|
|||
|
|
logical :: bool
|
|||
|
|
|
|||
|
|
integer(kind = nk) :: n
|
|||
|
|
integer(kind = nk) :: i
|
|||
|
|
|
|||
|
|
n = strbuf%length()
|
|||
|
|
if (n == 0) then
|
|||
|
|
bool = .true.
|
|||
|
|
else
|
|||
|
|
i = 1
|
|||
|
|
bool = .true.
|
|||
|
|
do while (bool .and. i /= n + 1)
|
|||
|
|
bool = isspace (strbuf%chars(i))
|
|||
|
|
i = i + 1
|
|||
|
|
end do
|
|||
|
|
end if
|
|||
|
|
end function strbuf_is_all_whitespace
|
|||
|
|
|
|||
|
|
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
|
|||
|
|
|
|||
|
|
elemental function isdigit (ch) result (bool)
|
|||
|
|
character(1, kind = ck), intent(in) :: ch
|
|||
|
|
logical :: bool
|
|||
|
|
|
|||
|
|
integer(kind = ick), parameter :: zero = ichar (ck_'0', kind = ick)
|
|||
|
|
integer(kind = ick), parameter :: nine = ichar (ck_'9', kind = ick)
|
|||
|
|
|
|||
|
|
integer(kind = ick) :: i_ch
|
|||
|
|
|
|||
|
|
i_ch = ichar (ch, kind = ick)
|
|||
|
|
bool = (zero <= i_ch .and. i_ch <= nine)
|
|||
|
|
end function isdigit
|
|||
|
|
|
|||
|
|
subroutine check_is_all_digits (lex_line_no, str)
|
|||
|
|
integer(kind = nk), intent(in) :: lex_line_no
|
|||
|
|
character(*, kind = ck), intent(in) :: str
|
|||
|
|
|
|||
|
|
integer(kind = nk) :: n
|
|||
|
|
integer(kind = nk) :: i
|
|||
|
|
|
|||
|
|
n = len (str, kind = nk)
|
|||
|
|
if (n == 0_nk) then
|
|||
|
|
call start_error_message (lex_line_no)
|
|||
|
|
write (error_unit, '("a required field is missing")')
|
|||
|
|
stop 1
|
|||
|
|
else
|
|||
|
|
do i = 1, n
|
|||
|
|
if (.not. isdigit (str(i:i))) then
|
|||
|
|
call start_error_message (lex_line_no)
|
|||
|
|
write (error_unit, '("a numeric field contains a non-digit")')
|
|||
|
|
stop 1
|
|||
|
|
end if
|
|||
|
|
end do
|
|||
|
|
end if
|
|||
|
|
end subroutine check_is_all_digits
|
|||
|
|
|
|||
|
|
subroutine start_error_message (lex_line_no)
|
|||
|
|
integer(kind = nk), intent(in) :: lex_line_no
|
|||
|
|
|
|||
|
|
write (error_unit, '("Token stream error at line ", I0, ": ")', advance = 'no') &
|
|||
|
|
& lex_line_no
|
|||
|
|
end subroutine start_error_message
|
|||
|
|
|
|||
|
|
end module reading_of_lexer_tokens
|
|||
|
|
|
|||
|
|
module syntactic_analysis
|
|||
|
|
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
|
|||
|
|
use, non_intrinsic :: string_buffers
|
|||
|
|
use, non_intrinsic :: lexer_token_facts
|
|||
|
|
use, non_intrinsic :: reading_of_lexer_tokens
|
|||
|
|
|
|||
|
|
implicit none
|
|||
|
|
private
|
|||
|
|
|
|||
|
|
public :: ast_node_t
|
|||
|
|
public :: ast_t
|
|||
|
|
public :: parse_token_stream
|
|||
|
|
public :: output_ast_flattened
|
|||
|
|
|
|||
|
|
integer, parameter, public :: tk_start_of_statement = -1
|
|||
|
|
integer, parameter, public :: tk_primary = -2
|
|||
|
|
|
|||
|
|
integer, parameter :: node_Identifier = 1
|
|||
|
|
integer, parameter :: node_String = 2
|
|||
|
|
integer, parameter :: node_Integer = 3
|
|||
|
|
integer, parameter :: node_Sequence = 4
|
|||
|
|
integer, parameter :: node_If = 5
|
|||
|
|
integer, parameter :: node_Prtc = 6
|
|||
|
|
integer, parameter :: node_Prts = 7
|
|||
|
|
integer, parameter :: node_Prti = 8
|
|||
|
|
integer, parameter :: node_While = 9
|
|||
|
|
integer, parameter :: node_Assign = 10
|
|||
|
|
integer, parameter :: node_Negate = 11
|
|||
|
|
integer, parameter :: node_Not = 12
|
|||
|
|
integer, parameter :: node_Multiply = 13
|
|||
|
|
integer, parameter :: node_Divide = 14
|
|||
|
|
integer, parameter :: node_Mod = 15
|
|||
|
|
integer, parameter :: node_Add = 16
|
|||
|
|
integer, parameter :: node_Subtract = 17
|
|||
|
|
integer, parameter :: node_Less = 18
|
|||
|
|
integer, parameter :: node_LessEqual = 19
|
|||
|
|
integer, parameter :: node_Greater = 20
|
|||
|
|
integer, parameter :: node_GreaterEqual = 21
|
|||
|
|
integer, parameter :: node_Equal = 22
|
|||
|
|
integer, parameter :: node_NotEqual = 23
|
|||
|
|
integer, parameter :: node_And = 24
|
|||
|
|
integer, parameter :: node_Or = 25
|
|||
|
|
|
|||
|
|
character(16), parameter :: node_variety_string(1:25) = &
|
|||
|
|
(/ "Identifier ", &
|
|||
|
|
& "String ", &
|
|||
|
|
& "Integer ", &
|
|||
|
|
& "Sequence ", &
|
|||
|
|
& "If ", &
|
|||
|
|
& "Prtc ", &
|
|||
|
|
& "Prts ", &
|
|||
|
|
& "Prti ", &
|
|||
|
|
& "While ", &
|
|||
|
|
& "Assign ", &
|
|||
|
|
& "Negate ", &
|
|||
|
|
& "Not ", &
|
|||
|
|
& "Multiply ", &
|
|||
|
|
& "Divide ", &
|
|||
|
|
& "Mod ", &
|
|||
|
|
& "Add ", &
|
|||
|
|
& "Subtract ", &
|
|||
|
|
& "Less ", &
|
|||
|
|
& "LessEqual ", &
|
|||
|
|
& "Greater ", &
|
|||
|
|
& "GreaterEqual ", &
|
|||
|
|
& "Equal ", &
|
|||
|
|
& "NotEqual ", &
|
|||
|
|
& "And ", &
|
|||
|
|
& "Or " /)
|
|||
|
|
|
|||
|
|
type :: ast_node_t
|
|||
|
|
integer :: node_variety
|
|||
|
|
character(:, kind = ck), allocatable :: val
|
|||
|
|
type(ast_node_t), pointer :: left => null ()
|
|||
|
|
type(ast_node_t), pointer :: right => null ()
|
|||
|
|
contains
|
|||
|
|
procedure, pass :: assign => ast_node_t_assign
|
|||
|
|
generic :: assignment(=) => assign
|
|||
|
|
final :: ast_node_t_finalize
|
|||
|
|
end type ast_node_t
|
|||
|
|
|
|||
|
|
! ast_t phases.
|
|||
|
|
integer, parameter :: building = 1
|
|||
|
|
integer, parameter :: completed = 2
|
|||
|
|
|
|||
|
|
type :: ast_t
|
|||
|
|
!
|
|||
|
|
! This type is used to build the subtrees, as well as for the
|
|||
|
|
! completed AST. The difference is in the setting of ‘phase’.
|
|||
|
|
!
|
|||
|
|
type(ast_node_t), pointer :: node => null ()
|
|||
|
|
integer, private :: phase = building
|
|||
|
|
contains
|
|||
|
|
procedure, pass :: assign => ast_t_assign
|
|||
|
|
generic :: assignment(=) => assign
|
|||
|
|
final :: ast_t_finalize
|
|||
|
|
end type ast_t
|
|||
|
|
|
|||
|
|
type(ast_t), parameter :: ast_nil = ast_t (null ())
|
|||
|
|
|
|||
|
|
contains
|
|||
|
|
|
|||
|
|
recursive subroutine ast_node_t_assign (node, other)
|
|||
|
|
class(ast_node_t), intent(out) :: node
|
|||
|
|
class(*), intent(in) :: other
|
|||
|
|
|
|||
|
|
select type (other)
|
|||
|
|
class is (ast_node_t)
|
|||
|
|
node%node_variety = other%node_variety
|
|||
|
|
if (allocated (other%val)) allocate (node%val, source = other%val)
|
|||
|
|
if (associated (other%left)) allocate (node%left, source = other%left)
|
|||
|
|
if (associated (other%right)) allocate (node%right, source = other%right)
|
|||
|
|
class default
|
|||
|
|
! This branch should never be reached.
|
|||
|
|
error stop
|
|||
|
|
end select
|
|||
|
|
end subroutine ast_node_t_assign
|
|||
|
|
|
|||
|
|
recursive subroutine ast_node_t_finalize (node)
|
|||
|
|
type(ast_node_t), intent(inout) :: node
|
|||
|
|
|
|||
|
|
if (associated (node%left)) deallocate (node%left)
|
|||
|
|
if (associated (node%right)) deallocate (node%right)
|
|||
|
|
end subroutine ast_node_t_finalize
|
|||
|
|
|
|||
|
|
recursive subroutine ast_t_assign (ast, other)
|
|||
|
|
class(ast_t), intent(out) :: ast
|
|||
|
|
class(*), intent(in) :: other
|
|||
|
|
|
|||
|
|
select type (other)
|
|||
|
|
class is (ast_t)
|
|||
|
|
if (associated (other%node)) allocate (ast%node, source = other%node)
|
|||
|
|
!
|
|||
|
|
! Whether it is better to set phase to ‘building’ or to set it
|
|||
|
|
! to ‘other%phase’ is unclear to me. Probably ‘building’ is the
|
|||
|
|
! better choice. Which variable controls memory recovery is
|
|||
|
|
! clear and unchanging, in that case: it is the original,
|
|||
|
|
! ‘other’, that does.
|
|||
|
|
!
|
|||
|
|
ast%phase = building
|
|||
|
|
class default
|
|||
|
|
! This should not happen.
|
|||
|
|
error stop
|
|||
|
|
end select
|
|||
|
|
end subroutine ast_t_assign
|
|||
|
|
|
|||
|
|
subroutine ast_t_finalize (ast)
|
|||
|
|
type(ast_t), intent(inout) :: ast
|
|||
|
|
|
|||
|
|
!
|
|||
|
|
! When we are building the tree, the tree’s nodes should not be
|
|||
|
|
! deallocated when the ast_t variable temporarily holding them
|
|||
|
|
! goes out of scope.
|
|||
|
|
!
|
|||
|
|
! However, once the AST is completed, we do want the memory
|
|||
|
|
! recovered when the variable goes out of scope.
|
|||
|
|
!
|
|||
|
|
! (Elsewhere I have written a primitive garbage collector for
|
|||
|
|
! Fortran programs, but in this case it would be a lot of overhead
|
|||
|
|
! for little gain. In fact, we could reasonably just let the
|
|||
|
|
! memory leak, in this program.
|
|||
|
|
!
|
|||
|
|
! Fortran runtimes *are* allowed by the standard to have garbage
|
|||
|
|
! collectors built in. To my knowledge, at the time of this
|
|||
|
|
! writing, only NAG Fortran has a garbage collector option.)
|
|||
|
|
!
|
|||
|
|
|
|||
|
|
if (ast%phase == completed) then
|
|||
|
|
if (associated (ast%node)) deallocate (ast%node)
|
|||
|
|
end if
|
|||
|
|
end subroutine ast_t_finalize
|
|||
|
|
|
|||
|
|
function parse_token_stream (unit_no) result (ast)
|
|||
|
|
integer, intent(in) :: unit_no
|
|||
|
|
type(ast_t) :: ast
|
|||
|
|
|
|||
|
|
integer(kind = nk) :: lex_line_no
|
|||
|
|
type(ast_t) :: statement
|
|||
|
|
type(lexer_token_t) :: token
|
|||
|
|
|
|||
|
|
lex_line_no = -1_nk
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call parse_statement (unit_no, lex_line_no, token, statement)
|
|||
|
|
ast = make_internal_node (node_Sequence, ast, statement)
|
|||
|
|
do while (token%token_no /= tk_EOI)
|
|||
|
|
call parse_statement (unit_no, lex_line_no, token, statement)
|
|||
|
|
ast = make_internal_node (node_Sequence, ast, statement)
|
|||
|
|
end do
|
|||
|
|
ast%phase = completed
|
|||
|
|
end function parse_token_stream
|
|||
|
|
|
|||
|
|
recursive subroutine parse_statement (unit_no, lex_line_no, token, ast)
|
|||
|
|
integer, intent(in) :: unit_no
|
|||
|
|
integer(kind = nk), intent(inout) :: lex_line_no
|
|||
|
|
type(lexer_token_t), intent(inout) :: token
|
|||
|
|
type(ast_t), intent(out) :: ast
|
|||
|
|
|
|||
|
|
ast = ast_nil
|
|||
|
|
|
|||
|
|
select case (token%token_no)
|
|||
|
|
case (tk_If)
|
|||
|
|
call parse_ifelse_construct
|
|||
|
|
case (tk_Putc)
|
|||
|
|
call parse_putc
|
|||
|
|
case (tk_Print)
|
|||
|
|
call parse_print
|
|||
|
|
case (tk_Semi)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
case (tk_Ident)
|
|||
|
|
call parse_identifier
|
|||
|
|
case (tk_While)
|
|||
|
|
call parse_while_construct
|
|||
|
|
case (tk_Lbrace)
|
|||
|
|
call parse_lbrace_construct
|
|||
|
|
case (tk_EOI)
|
|||
|
|
continue
|
|||
|
|
case default
|
|||
|
|
call syntax_error_message ("", tk_start_of_statement, token)
|
|||
|
|
stop 1
|
|||
|
|
end select
|
|||
|
|
|
|||
|
|
contains
|
|||
|
|
|
|||
|
|
recursive subroutine parse_ifelse_construct
|
|||
|
|
type(ast_t) :: predicate
|
|||
|
|
type(ast_t) :: statement_for_predicate_true
|
|||
|
|
type(ast_t) :: statement_for_predicate_false
|
|||
|
|
|
|||
|
|
call expect_token ("If", tk_If, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call parse_parenthesized_expression (unit_no, lex_line_no, token, predicate)
|
|||
|
|
call parse_statement (unit_no, lex_line_no, token, statement_for_predicate_true)
|
|||
|
|
if (token%token_no == tk_Else) then
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call parse_statement (unit_no, lex_line_no, token, statement_for_predicate_false)
|
|||
|
|
ast = make_internal_node (node_If, statement_for_predicate_true, &
|
|||
|
|
& statement_for_predicate_false)
|
|||
|
|
else
|
|||
|
|
ast = make_internal_node (node_If, statement_for_predicate_true, ast_nil)
|
|||
|
|
end if
|
|||
|
|
ast = make_internal_node (node_If, predicate, ast)
|
|||
|
|
end subroutine parse_ifelse_construct
|
|||
|
|
|
|||
|
|
recursive subroutine parse_putc
|
|||
|
|
type(ast_t) :: arguments
|
|||
|
|
|
|||
|
|
call expect_token ("Putc", tk_Putc, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call parse_parenthesized_expression (unit_no, lex_line_no, token, arguments)
|
|||
|
|
ast = make_internal_node (node_Prtc, arguments, ast_nil)
|
|||
|
|
call expect_token ("Putc", tk_Semi, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
end subroutine parse_putc
|
|||
|
|
|
|||
|
|
recursive subroutine parse_print
|
|||
|
|
logical :: done
|
|||
|
|
type(ast_t) :: arg
|
|||
|
|
type(ast_t) :: printer
|
|||
|
|
|
|||
|
|
call expect_token ("Print", tk_Print, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call expect_token ("Print", tk_Lparen, token)
|
|||
|
|
done = .false.
|
|||
|
|
do while (.not. done)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
select case (token%token_no)
|
|||
|
|
case (tk_String)
|
|||
|
|
arg = make_leaf_node (node_String, token%val)
|
|||
|
|
printer = make_internal_node (node_Prts, arg, ast_nil)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
case default
|
|||
|
|
call parse_expression (unit_no, 0, lex_line_no, token, arg)
|
|||
|
|
printer = make_internal_node (node_Prti, arg, ast_nil)
|
|||
|
|
end select
|
|||
|
|
ast = make_internal_node (node_Sequence, ast, printer)
|
|||
|
|
done = (token%token_no /= tk_Comma)
|
|||
|
|
end do
|
|||
|
|
call expect_token ("Print", tk_Rparen, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call expect_token ("Print", tk_Semi, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
end subroutine parse_print
|
|||
|
|
|
|||
|
|
recursive subroutine parse_identifier
|
|||
|
|
type(ast_t) :: left_side
|
|||
|
|
type(ast_t) :: right_side
|
|||
|
|
|
|||
|
|
left_side = make_leaf_node (node_Identifier, token%val)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call expect_token ("assign", tk_Assign, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call parse_expression (unit_no, 0, lex_line_no, token, right_side)
|
|||
|
|
ast = make_internal_node (node_Assign, left_side, right_side)
|
|||
|
|
call expect_token ("assign", tk_Semi, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
end subroutine parse_identifier
|
|||
|
|
|
|||
|
|
recursive subroutine parse_while_construct
|
|||
|
|
type(ast_t) :: predicate
|
|||
|
|
type(ast_t) :: statement_to_be_repeated
|
|||
|
|
|
|||
|
|
call expect_token ("While", tk_While, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call parse_parenthesized_expression (unit_no, lex_line_no, token, predicate)
|
|||
|
|
call parse_statement (unit_no, lex_line_no, token, statement_to_be_repeated)
|
|||
|
|
ast = make_internal_node (node_While, predicate, statement_to_be_repeated)
|
|||
|
|
end subroutine parse_while_construct
|
|||
|
|
|
|||
|
|
recursive subroutine parse_lbrace_construct
|
|||
|
|
type(ast_t) :: statement
|
|||
|
|
|
|||
|
|
call expect_token ("Lbrace", tk_Lbrace, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
do while (token%token_no /= tk_Rbrace .and. token%token_no /= tk_EOI)
|
|||
|
|
call parse_statement (unit_no, lex_line_no, token, statement)
|
|||
|
|
ast = make_internal_node (node_Sequence, ast, statement)
|
|||
|
|
end do
|
|||
|
|
call expect_token ("Lbrace", tk_Rbrace, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
end subroutine parse_lbrace_construct
|
|||
|
|
|
|||
|
|
end subroutine parse_statement
|
|||
|
|
|
|||
|
|
recursive subroutine parse_expression (unit_no, p, lex_line_no, token, ast)
|
|||
|
|
integer, intent(in) :: unit_no
|
|||
|
|
integer, intent(in) :: p
|
|||
|
|
integer(kind = nk), intent(inout) :: lex_line_no
|
|||
|
|
type(lexer_token_t), intent(inout) :: token
|
|||
|
|
type(ast_t), intent(out) :: ast
|
|||
|
|
|
|||
|
|
integer :: precedence
|
|||
|
|
type(ast_t) :: expression
|
|||
|
|
|
|||
|
|
select case (token%token_no)
|
|||
|
|
case (tk_Lparen)
|
|||
|
|
call parse_parenthesized_expression (unit_no, lex_line_no, token, ast)
|
|||
|
|
case (tk_Sub)
|
|||
|
|
token%token_no = tk_Negate
|
|||
|
|
precedence = lexer_token_precedence(token%token_no)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call parse_expression (unit_no, precedence, lex_line_no, token, expression)
|
|||
|
|
ast = make_internal_node (node_Negate, expression, ast_nil)
|
|||
|
|
case (tk_Add)
|
|||
|
|
token%token_no = tk_Positive
|
|||
|
|
precedence = lexer_token_precedence(token%token_no)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call parse_expression (unit_no, precedence, lex_line_no, token, expression)
|
|||
|
|
ast = expression
|
|||
|
|
case (tk_Not)
|
|||
|
|
precedence = lexer_token_precedence(token%token_no)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call parse_expression (unit_no, precedence, lex_line_no, token, expression)
|
|||
|
|
ast = make_internal_node (node_Not, expression, ast_nil)
|
|||
|
|
case (tk_Ident)
|
|||
|
|
ast = make_leaf_node (node_Identifier, token%val)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
case (tk_Integer)
|
|||
|
|
ast = make_leaf_node (node_Integer, token%val)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
case default
|
|||
|
|
call syntax_error_message ("", tk_primary, token)
|
|||
|
|
stop 1
|
|||
|
|
end select
|
|||
|
|
|
|||
|
|
do while (lexer_token_arity(token%token_no) == 2 .and. &
|
|||
|
|
& p <= lexer_token_precedence(token%token_no))
|
|||
|
|
block
|
|||
|
|
type(ast_t) :: right_expression
|
|||
|
|
integer :: q
|
|||
|
|
integer :: node_variety
|
|||
|
|
|
|||
|
|
if (lexer_token_associativity(token%token_no) == right_associative) then
|
|||
|
|
q = lexer_token_precedence(token%token_no)
|
|||
|
|
else
|
|||
|
|
q = lexer_token_precedence(token%token_no) + 1
|
|||
|
|
end if
|
|||
|
|
node_variety = binary_operator_node_variety (token%token_no)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call parse_expression (unit_no, q, lex_line_no, token, right_expression)
|
|||
|
|
ast = make_internal_node (node_variety, ast, right_expression)
|
|||
|
|
end block
|
|||
|
|
end do
|
|||
|
|
end subroutine parse_expression
|
|||
|
|
|
|||
|
|
recursive subroutine parse_parenthesized_expression (unit_no, lex_line_no, token, ast)
|
|||
|
|
integer, intent(in) :: unit_no
|
|||
|
|
integer(kind = nk), intent(inout) :: lex_line_no
|
|||
|
|
type(lexer_token_t), intent(inout) :: token
|
|||
|
|
type(ast_t), intent(out) :: ast
|
|||
|
|
|
|||
|
|
call expect_token ("paren_expr", tk_Lparen, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
call parse_expression (unit_no, 0, lex_line_no, token, ast)
|
|||
|
|
call expect_token ("paren_expr", tk_Rparen, token)
|
|||
|
|
call get_token (unit_no, lex_line_no, token)
|
|||
|
|
end subroutine parse_parenthesized_expression
|
|||
|
|
|
|||
|
|
elemental function binary_operator_node_variety (token_no) result (node_variety)
|
|||
|
|
integer, intent(in) :: token_no
|
|||
|
|
integer :: node_variety
|
|||
|
|
|
|||
|
|
select case (token_no)
|
|||
|
|
case (tk_Mul)
|
|||
|
|
node_variety = node_Multiply
|
|||
|
|
case (tk_Div)
|
|||
|
|
node_variety = node_Divide
|
|||
|
|
case (tk_Mod)
|
|||
|
|
node_variety = node_Mod
|
|||
|
|
case (tk_Add)
|
|||
|
|
node_variety = node_Add
|
|||
|
|
case (tk_Sub)
|
|||
|
|
node_variety = node_Subtract
|
|||
|
|
case (tk_Lss)
|
|||
|
|
node_variety = node_Less
|
|||
|
|
case (tk_Leq)
|
|||
|
|
node_variety = node_LessEqual
|
|||
|
|
case (tk_Gtr)
|
|||
|
|
node_variety = node_Greater
|
|||
|
|
case (tk_Geq)
|
|||
|
|
node_variety = node_GreaterEqual
|
|||
|
|
case (tk_Eq)
|
|||
|
|
node_variety = node_Equal
|
|||
|
|
case (tk_Neq)
|
|||
|
|
node_variety = node_NotEqual
|
|||
|
|
case (tk_And)
|
|||
|
|
node_variety = node_And
|
|||
|
|
case (tk_Or)
|
|||
|
|
node_variety = node_Or
|
|||
|
|
case default
|
|||
|
|
! This branch should never be reached.
|
|||
|
|
error stop
|
|||
|
|
end select
|
|||
|
|
end function binary_operator_node_variety
|
|||
|
|
|
|||
|
|
function make_internal_node (node_variety, left, right) result (ast)
|
|||
|
|
integer, intent(in) :: node_variety
|
|||
|
|
class(ast_t), intent(in) :: left, right
|
|||
|
|
type(ast_t) :: ast
|
|||
|
|
|
|||
|
|
type(ast_node_t), pointer :: node
|
|||
|
|
|
|||
|
|
allocate (node)
|
|||
|
|
node%node_variety = node_variety
|
|||
|
|
node%left => left%node
|
|||
|
|
node%right => right%node
|
|||
|
|
ast%node => node
|
|||
|
|
end function make_internal_node
|
|||
|
|
|
|||
|
|
function make_leaf_node (node_variety, val) result (ast)
|
|||
|
|
integer, intent(in) :: node_variety
|
|||
|
|
character(*, kind = ck), intent(in) :: val
|
|||
|
|
type(ast_t) :: ast
|
|||
|
|
|
|||
|
|
type(ast_node_t), pointer :: node
|
|||
|
|
|
|||
|
|
allocate (node)
|
|||
|
|
node%node_variety = node_variety
|
|||
|
|
node%val = val
|
|||
|
|
ast%node => node
|
|||
|
|
end function make_leaf_node
|
|||
|
|
|
|||
|
|
subroutine get_token (unit_no, lex_line_no, token)
|
|||
|
|
integer, intent(in) :: unit_no
|
|||
|
|
integer(kind = nk), intent(inout) :: lex_line_no
|
|||
|
|
type(lexer_token_t), intent(out) :: token
|
|||
|
|
|
|||
|
|
logical :: eof
|
|||
|
|
|
|||
|
|
call get_lexer_token (unit_no, lex_line_no, eof, token)
|
|||
|
|
if (eof) then
|
|||
|
|
write (error_unit, '("Parser error: the stream of input tokens is incomplete")')
|
|||
|
|
stop 1
|
|||
|
|
end if
|
|||
|
|
end subroutine get_token
|
|||
|
|
|
|||
|
|
subroutine expect_token (message, token_no, token)
|
|||
|
|
character(*), intent(in) :: message
|
|||
|
|
integer, intent (in) :: token_no
|
|||
|
|
class(lexer_token_t), intent(in) :: token
|
|||
|
|
|
|||
|
|
if (token%token_no /= token_no) then
|
|||
|
|
call syntax_error_message (message, token_no, token)
|
|||
|
|
stop 1
|
|||
|
|
end if
|
|||
|
|
end subroutine expect_token
|
|||
|
|
|
|||
|
|
subroutine syntax_error_message (message, expected_token_no, token)
|
|||
|
|
character(*), intent(in) :: message
|
|||
|
|
integer, intent(in) :: expected_token_no
|
|||
|
|
class(lexer_token_t), intent(in) :: token
|
|||
|
|
|
|||
|
|
! Write a message to an output unit dedicated to printing
|
|||
|
|
! errors. The message could, of course, be more detailed than what
|
|||
|
|
! we are doing here.
|
|||
|
|
write (error_unit, '("Syntax error at ", I0, ".", I0)') &
|
|||
|
|
& token%line_no, token%column_no
|
|||
|
|
|
|||
|
|
!
|
|||
|
|
! For the sake of the exercise, also write, to output_unit, a
|
|||
|
|
! message in the style of the C reference program.
|
|||
|
|
!
|
|||
|
|
write (output_unit, '("(", I0, ", ", I0, ") error: ")', advance = 'no') &
|
|||
|
|
& token%line_no, token%column_no
|
|||
|
|
select case (expected_token_no)
|
|||
|
|
case (tk_start_of_statement)
|
|||
|
|
write (output_unit, '("expecting start of statement, found ''", 1A, "''")') &
|
|||
|
|
& trim (lexer_token_string(token%token_no))
|
|||
|
|
case (tk_primary)
|
|||
|
|
write (output_unit, '("Expecting a primary, found ''", 1A, "''")') &
|
|||
|
|
& trim (lexer_token_string(token%token_no))
|
|||
|
|
case default
|
|||
|
|
write (output_unit, '(1A, ": Expecting ''", 1A, "'', found ''", 1A, "''")') &
|
|||
|
|
& trim (message), trim (lexer_token_string(expected_token_no)), &
|
|||
|
|
& trim (lexer_token_string(token%token_no))
|
|||
|
|
end select
|
|||
|
|
end subroutine syntax_error_message
|
|||
|
|
|
|||
|
|
subroutine output_ast_flattened (unit_no, ast)
|
|||
|
|
integer, intent(in) :: unit_no
|
|||
|
|
type(ast_t), intent(in) :: ast
|
|||
|
|
|
|||
|
|
call output_ast_node_flattened (unit_no, ast%node)
|
|||
|
|
end subroutine output_ast_flattened
|
|||
|
|
|
|||
|
|
recursive subroutine output_ast_node_flattened (unit_no, node)
|
|||
|
|
integer, intent(in) :: unit_no
|
|||
|
|
type(ast_node_t), pointer, intent(in) :: node
|
|||
|
|
|
|||
|
|
if (.not. associated (node)) then
|
|||
|
|
write (unit_no, '(";")')
|
|||
|
|
else
|
|||
|
|
if (allocated (node%val)) then
|
|||
|
|
write (unit_no, '(1A16, 2X, 1A)') &
|
|||
|
|
& node_variety_string(node%node_variety), node%val
|
|||
|
|
else
|
|||
|
|
write (unit_no, '(1A)') &
|
|||
|
|
& trim (node_variety_string(node%node_variety))
|
|||
|
|
call output_ast_node_flattened (unit_no, node%left)
|
|||
|
|
call output_ast_node_flattened (unit_no, node%right)
|
|||
|
|
end if
|
|||
|
|
end if
|
|||
|
|
end subroutine output_ast_node_flattened
|
|||
|
|
|
|||
|
|
end module syntactic_analysis
|
|||
|
|
|
|||
|
|
program parse
|
|||
|
|
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 :: syntactic_analysis
|
|||
|
|
|
|||
|
|
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(ast_t) :: ast
|
|||
|
|
|
|||
|
|
ast = parse_token_stream (inp)
|
|||
|
|
call output_ast_flattened (outp, ast)
|
|||
|
|
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 parse
|