[Bug fortran/40440] New: [4.5.0 Regression] Garbage or segmentation fault in allocatable array derived type structures
juergen dot reuter at desy dot de
gcc-bugzilla@gcc.gnu.org
Sun Jun 14 21:50:00 GMT 2009
In derived type structures which are themselves array-valued garbage is stored
and can produce segmentation faults. The behaviour seems erratic and not really
reproduceable. The code makes use of the module iso_varying_string.f90
which can be found here (putting it in below would have exceeded the limit of
64 kb for the description): http://www.fortran.com/iso_varying_string.f95. Just
compile the example below including iso_varying_string.o with 4.5.0 and run
the binary. It shows where you should get garbage when using 4.5.0.
I tried a stack trace and got this:
Program received signal SIGABRT, Aborted.
0x00002b51812c4ed5 in raise () from /lib/libc.so.6
Program received signal SIGABRT, Aborted.
0x00002b166f232ed5 in raise () from /lib/libc.so.6
#0 0x00002b166f232ed5 in raise () from /lib/libc.so.6
#1 0x00002b166f2343f3 in abort () from /lib/libc.so.6
#2 0x00002b166f26f3a8 in __libc_message () from /lib/libc.so.6
#3 0x00002b166f274948 in malloc_printerr () from /lib/libc.so.6
#4 0x00002b166f276a56 in free () from /lib/libc.so.6
#5 0x000000000040d380 in set_children.2047 () at syntax_rules.f90:752
#6 0x0000000000000000 in ?? ()
The output with gfortran 4.3.1 and 4.4.0 is perfectly regular.
CODE EXAMPLE:
module ifiles
use iso_varying_string, string_t => varying_string !NODEP!
implicit none
private
public :: ifile_t
public :: ifile_append
public :: ifile_get_length
public :: line_p
public :: line_init
public :: line_get_string_advance
type :: line_entry_t
private
type(line_entry_t), pointer :: previous => null ()
type(line_entry_t), pointer :: next => null ()
type(string_t) :: string
integer :: index
end type line_entry_t
type :: ifile_t
private
type(line_entry_t), pointer :: first => null ()
type(line_entry_t), pointer :: last => null ()
integer :: n_lines = 0
end type ifile_t
type :: line_p
private
type(line_entry_t), pointer :: p => null ()
end type line_p
interface ifile_append
module procedure ifile_append_from_string
module procedure ifile_append_from_char
end interface
contains
subroutine line_entry_create (line, string)
type(line_entry_t), pointer :: line
type(string_t), intent(in) :: string
allocate (line)
line%string = string
end subroutine line_entry_create
subroutine ifile_append_from_string (ifile, string)
type(ifile_t), intent(inout) :: ifile
type(string_t), intent(in) :: string
type(line_entry_t), pointer :: current
call line_entry_create (current, string)
current%index = ifile%n_lines + 1
if (associated (ifile%last)) then
current%previous => ifile%last
ifile%last%next => current
else
ifile%first => current
end if
ifile%last => current
ifile%n_lines = current%index
end subroutine ifile_append_from_string
subroutine ifile_append_from_char (ifile, char)
type(ifile_t), intent(inout) :: ifile
character(*), intent(in) :: char
call ifile_append_from_string (ifile, var_str (trim (char)))
end subroutine ifile_append_from_char
function ifile_get_length (ifile) result (length)
integer :: length
type(ifile_t), intent(in) :: ifile
length = ifile%n_lines
end function ifile_get_length
subroutine line_init (line, ifile, back)
type(line_p), intent(inout) :: line
type(ifile_t), intent(in) :: ifile
logical, intent(in), optional :: back
if (present (back)) then
if (back) then
line%p => ifile%last
else
line%p => ifile%first
end if
else
line%p => ifile%first
end if
end subroutine line_init
subroutine line_advance (line)
type(line_p), intent(inout) :: line
if (associated (line%p)) line%p => line%p%next
end subroutine line_advance
function line_get_string_advance (line) result (string)
type(string_t) :: string
type(line_p), intent(inout) :: line
if (associated (line%p)) then
string = line%p%string
call line_advance (line)
else
string = ""
end if
end function line_get_string_advance
end module ifiles
module syntax_rules
use iso_fortran_env, only: STDERR => ERROR_UNIT
use iso_varying_string, string_t => varying_string
use ifiles, only: line_p, line_init, line_get_string_advance
use ifiles, only: ifile_t, ifile_get_length
implicit none
private
character, parameter, public :: BLANK = ' ', TAB = achar(9)
character, parameter, public :: CR = achar(13), LF = achar(10)
character(*), parameter, public :: WHITESPACE_CHARS = BLANK// TAB // CR // LF
character(*), parameter, public :: LCLETTERS = "abcdefghijklmnopqrstuvwxyz"
character(*), parameter, public :: UCLETTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
character(*), parameter, public :: DIGITS = "0123456789"
character(*), parameter, public :: UNQUOTED =
"(),|_"//LCLETTERS//UCLETTERS//DIGITS
public :: S_UNKNOWN
public :: S_KEYWORD
public :: S_SEQUENCE
public :: syntax_t
public :: syntax_init
public :: syntax_get_rule_ptr
public :: stream_t
public :: lexer_t
public :: syntax_rule_t
integer, parameter :: S_UNKNOWN = 0, S_KEYWORD = 6, S_SEQUENCE = 7
integer, parameter :: T_KEYWORD = 1
integer, parameter :: T_IDENTIFIER = 2, T_QUOTED = 3, T_NUMERIC = 4
integer, parameter :: EMPTY = 0, WHITESPACE = 10
integer, parameter :: NO_MATCH = 11, IO_ERROR = 12, OVERFLOW = 13
integer, parameter :: UNMATCHED_QUOTE = 14
type :: stream_t
type(string_t), pointer :: filename => null ()
integer, pointer :: unit => null ()
type(string_t), pointer :: string => null ()
type(ifile_t), pointer :: ifile => null ()
type(line_p), pointer :: line => null ()
end type stream_t
type :: keyword_entry_t
private
type(string_t) :: string
type(keyword_entry_t), pointer :: next => null ()
end type keyword_entry_t
type :: keyword_list_t
private
type(keyword_entry_t), pointer :: first => null ()
type(keyword_entry_t), pointer :: last => null ()
end type keyword_list_t
type :: template_t
private
integer :: type
character(256) :: charset1, charset2
integer :: len1, len2
end type template_t
type :: lexer_setup_t
private
type(template_t), dimension(:), allocatable :: tt
integer, dimension(:), allocatable :: type
type(keyword_list_t), pointer :: keyword_list => null ()
end type lexer_setup_t
type :: lexeme_t
private
integer :: type = 0
type(string_t) :: s
integer :: b = 0, e = 0
end type lexeme_t
type :: lexer_t
private
type(lexer_setup_t) :: setup
type(lexeme_t) :: lexeme
type(string_t) :: line_buffer
integer :: current_line
integer :: current_column
integer :: previous_column
type(string_t) :: buffer
end type lexer_t
type :: rule_p
private
type(syntax_rule_t), pointer :: p => null ()
end type rule_p
type :: syntax_rule_t
private
integer :: type = S_UNKNOWN
logical :: used = .false.
type(string_t) :: keyword
type(string_t) :: separator
type(string_t), dimension(2) :: delimiter
type(rule_p), dimension(:), allocatable :: child
character(1) :: modifier = ""
logical :: opt = .false., rep = .false.
end type syntax_rule_t
type :: syntax_t
private
type(syntax_rule_t), dimension(:), allocatable :: rule
type(keyword_list_t) :: keyword_list
end type syntax_t
interface syntax_init
module procedure syntax_init_from_ifile
end interface
interface stream_init
module procedure stream_init_string
end interface
contains
subroutine stream_get_record (stream, string, iostat)
type(stream_t), intent(inout) :: stream
type(string_t), intent(out) :: string
integer, intent(out) :: iostat
if (associated (stream%unit)) then
call get (stream%unit, string, iostat=iostat)
if (iostat == -2) iostat = 0
else if (associated (stream%string)) then
if (len (stream%string) /= 0) then
string = stream%string
stream%string = ""
iostat = 0
else
iostat = -1
end if
else
write (STDERR, *) " Attempt to read from uninitialized input stream"
flush (STDERR)
stop
end if
end subroutine stream_get_record
pure function template_whitespace (chars) result (tt)
character(*), intent(in) :: chars
type(template_t) :: tt
tt = template_t (WHITESPACE, chars, "", len (chars), 0)
end function template_whitespace
pure function template_quoted (chars1, chars2) result (tt)
character(*), intent(in) :: chars1, chars2
type(template_t) :: tt
tt = template_t (T_QUOTED, chars1, chars2, len (chars1), len (chars2))
end function template_quoted
pure function template_numeric (chars) result (tt)
character(*), intent(in) :: chars
type(template_t) :: tt
tt = template_t (T_NUMERIC, chars, "", len (chars), 0)
end function template_numeric
pure function template_identifier (chars1, chars2) result (tt)
character(*), intent(in) :: chars1, chars2
type(template_t) :: tt
tt = template_t (T_IDENTIFIER, chars1, chars2, len(chars1), len(chars2))
end function template_identifier
function lexeme_is_break (t) result (break)
logical :: break
type(lexeme_t), intent(in) :: t
select case (t%type)
case (-1, IO_ERROR, OVERFLOW, NO_MATCH)
break = .true.
case default
break = .false.
end select
end function lexeme_is_break
subroutine lexeme_set (t, keyword_list, s, range, type)
type(lexeme_t), intent(out) :: t
type(keyword_list_t), pointer :: keyword_list
type(string_t), intent(in) :: s
integer, dimension(2), intent(in) :: range
integer, intent(in) :: type
t%type = type
if (type == T_IDENTIFIER) then
if (associated (keyword_list)) then
if (keyword_list_contains (keyword_list, s)) t%type = T_KEYWORD
end if
end if
t%s = s
t%b = range(1)
t%e = range(2)
end subroutine lexeme_set
subroutine stream_init_string (stream, string)
type(stream_t), intent(out) :: stream
type(string_t), intent(in) :: string
allocate (stream%string)
stream%string = string
end subroutine stream_init_string
subroutine stream_final (stream)
type(stream_t), intent(inout) :: stream
if (associated (stream%filename)) then
close (stream%unit)
deallocate (stream%unit)
deallocate (stream%filename)
else if (associated (stream%unit)) then
deallocate (stream%unit)
else if (associated (stream%string)) then
deallocate (stream%string)
end if
end subroutine stream_final
subroutine lexeme_clear (t)
type(lexeme_t), intent(out) :: t
t%type = 0
t%s = ""
end subroutine lexeme_clear
subroutine lexer_clear (lexer)
type(lexer_t), intent(inout) :: lexer
call lexeme_clear (lexer%lexeme)
lexer%line_buffer = ""
lexer%current_line = 0
lexer%current_column = 0
lexer%previous_column = 0
lexer%buffer = ""
end subroutine lexer_clear
function lexeme_get_string (t) result (s)
type(string_t) :: s
type(lexeme_t), intent(in) :: t
s = t%s
end function lexeme_get_string
function lexeme_get_contents (t) result (s)
type(string_t) :: s
type(lexeme_t), intent(in) :: t
s = extract (t%s, t%b, t%e)
write (STDERR, *) "lexeme_get_contents -> ", char (s)
flush (STDERR)
end function lexeme_get_contents
subroutine lexer_setup_final (setup)
type(lexer_setup_t), intent(inout) :: setup
deallocate (setup%tt, setup%type)
setup%keyword_list => null ()
end subroutine lexer_setup_final
subroutine keyword_list_add (keylist, string)
type(keyword_list_t), intent(inout) :: keylist
type(string_t), intent(in) :: string
type(keyword_entry_t), pointer :: k_entry_new
if (.not. keyword_list_contains (keylist, string)) then
allocate (k_entry_new)
k_entry_new%string = string
if (associated (keylist%first)) then
keylist%last%next => k_entry_new
else
keylist%first => k_entry_new
end if
keylist%last => k_entry_new
end if
end subroutine keyword_list_add
function keyword_list_contains (keylist, string) result (found)
type(keyword_list_t), intent(in) :: keylist
type(string_t), intent(in) :: string
logical :: found
found = .false.
call check_rec (keylist%first)
contains
recursive subroutine check_rec (k_entry)
type(keyword_entry_t), pointer :: k_entry
if (associated (k_entry)) then
if (k_entry%string /= string) then
call check_rec (k_entry%next)
else
found = .true.
end if
end if
end subroutine check_rec
end function keyword_list_contains
subroutine lex (lexeme, lexer, stream)
type(lexeme_t), intent(out) :: lexeme
type(lexer_t), intent(inout) :: lexer
type(stream_t), intent(inout) :: stream
integer :: iostat1, iostat2
integer :: pos
integer, dimension(2) :: range
integer :: template_index, type
GET_LEXEME: do while (lexeme_get_type (lexer%lexeme) == 0)
if (len (lexer%buffer) /= 0) then
iostat1 = 0
else
call lexer_read_line (lexer, stream, iostat1)
end if
select case (iostat1)
case (0)
MATCH_BUFFER: do
call match (lexer%setup%tt, char (lexer%buffer), &
pos, range, template_index)
if (pos >= 0) then
type = lexer%setup%type(template_index)
exit MATCH_BUFFER
else
pos = 0
call lexer_read_line (lexer, stream, iostat2)
select case (iostat2)
case (-1); type = UNMATCHED_QUOTE; exit MATCH_BUFFER
case (1); type = IO_ERROR; exit MATCH_BUFFER
case (2); type = OVERFLOW; exit MATCH_BUFFER
end select
end if
end do MATCH_BUFFER
case (-1); type = -1
case (1); type = IO_ERROR
case (2); type = OVERFLOW
end select
call lexeme_set (lexer%lexeme, lexer%setup%keyword_list, &
extract (lexer%buffer, finish=pos), range, type)
lexer%buffer = remove (lexer%buffer, finish=pos)
lexer%previous_column = max (lexer%current_column, 0)
lexer%current_column = lexer%current_column + pos
end do GET_LEXEME
lexeme = lexer%lexeme
call lexeme_clear (lexer%lexeme)
end subroutine lex
function lexeme_get_type (t) result (type)
integer :: type
type(lexeme_t), intent(in) :: t
type = t%type
end function lexeme_get_type
subroutine lexer_setup_init (setup, &
comment_chars, quote_chars, quote_match, &
single_chars, special_class, &
keyword_list)
type(lexer_setup_t), intent(inout) :: setup
character(*), intent(in) :: comment_chars
character(*), intent(in) :: quote_chars, quote_match
character(*), intent(in) :: single_chars
character(*), dimension(:), intent(in) :: special_class
type(keyword_list_t), pointer :: keyword_list
integer :: n, i
n = 1 + len (comment_chars) + len (quote_chars) + 1 &
+ len (single_chars) + size (special_class) + 1
write (STDERR, *) "n :", n
flush (STDERR)
allocate (setup%tt(n))
allocate (setup%type(0:n))
n = 0
setup%type(n) = NO_MATCH
n = n + 1
setup%tt(n) = template_whitespace (WHITESPACE_CHARS)
setup%type(n) = EMPTY
forall (i = 1:len(comment_chars))
setup%tt(n+i) = template_quoted (comment_chars(i:i), LF)
setup%type(n+i) = EMPTY
end forall
n = n + len (comment_chars)
forall (i = 1:len(quote_chars))
setup%tt(n+i) = template_quoted (quote_chars(i:i), quote_match(i:i))
setup%type(n+i) = T_QUOTED
end forall
n = n + len (quote_chars)
setup%tt(n+1) = template_numeric ("EeDd")
setup%type(n+1) = T_NUMERIC
n = n + 1
forall (i = 1:len (single_chars))
setup%tt(n+i) = template_identifier (single_chars(i:i), "")
setup%type(n+i) = T_IDENTIFIER
end forall
n = n + len (single_chars)
forall (i = 1:size (special_class))
setup%tt(n+i) = template_identifier &
(trim (special_class(i)), trim (special_class(i)))
setup%type(n+i) = T_IDENTIFIER
end forall
n = n + size (special_class)
setup%tt(n+1) = template_identifier &
(LCLETTERS//UCLETTERS, LCLETTERS//DIGITS//"_"//UCLETTERS)
setup%type(n+1) = T_IDENTIFIER
n = n + 1
if (n /= size (setup%tt)) then
write (STDERR, *) "Size mismatch in lexer setup"
flush (STDERR)
endif
setup%keyword_list => keyword_list
end subroutine lexer_setup_init
subroutine lexer_init (lexer, &
comment_chars, quote_chars, quote_match, &
single_chars, special_class, &
keyword_list)
type(lexer_t), intent(inout) :: lexer
character(*), intent(in) :: comment_chars
character(*), intent(in) :: quote_chars, quote_match
character(*), intent(in) :: single_chars
character(*), dimension(:), intent(in) :: special_class
type(keyword_list_t), pointer :: keyword_list
call lexer_setup_init (lexer%setup, &
comment_chars = comment_chars, &
quote_chars = quote_chars, &
quote_match = quote_match, &
single_chars = single_chars, &
special_class = special_class, &
keyword_list = keyword_list)
call lexer_clear (lexer)
end subroutine lexer_init
subroutine lexer_read_line (lexer, stream, iostat)
type(lexer_t), intent(inout) :: lexer
type(stream_t), intent(inout) :: stream
integer, intent(out) :: iostat
call stream_get_record (stream, lexer%line_buffer, iostat)
lexer%current_line = lexer%current_line + 1
if (iostat == 0) then
lexer%buffer = lexer%buffer // lexer%line_buffer // LF
end if
end subroutine lexer_read_line
subroutine match_numeric (tt, s, n)
type(template_t), intent(in) :: tt
character(*), intent(in) :: s
integer, intent(out) :: n
integer :: i, n0
character(10), parameter :: digits = "0123456789"
character(2), parameter :: signs = "-+"
n = verify (s, digits) - 1
if (n < 0) then
n = 0
return
else if (s(n+1:n+1) == ".") then
i = verify (s(n+2:), digits) - 1
if (i < 0) then
n = len (s)
return
else if (i > 0 .or. n > 0) then
n = n + 1 + i
end if
end if
n0 = n
if (n > 0) then
if (verify (s(n+1:n+1), tt%charset1(1:tt%len1)) == 0) then
n = n + 1
if (verify (s(n+1:n+1), signs) == 0) n = n + 1
i = verify (s(n+1:), digits) - 1
if (i < 0) then
n = len (s)
else if (i == 0) then
n = n0
else
n = n + i
end if
end if
end if
end subroutine match_numeric
subroutine match_identifier (tt, s, n)
type(template_t), intent(in) :: tt
character(*), intent(in) :: s
integer, intent(out) :: n
if (verify (s(1:1), tt%charset1(1:tt%len1)) == 0) then
n = verify (s(2:), tt%charset2(1:tt%len2))
if (n == 0) n = len (s)
else
n = 0
end if
end subroutine match_identifier
subroutine match_template (tt, s, n, range)
type(template_t), intent(in) :: tt
character(*), intent(in) :: s
integer, intent(out) :: n
integer, dimension(2), intent(out) :: range
select case (tt%type)
case (WHITESPACE)
call match_whitespace (tt, s, n)
range = 0
case (T_IDENTIFIER)
call match_identifier (tt, s, n)
range(1) = 1
range(2) = len_trim (s)
case (T_QUOTED)
call match_quoted (tt, s, n, range)
case (T_NUMERIC)
call match_numeric (tt, s, n)
range(1) = 1
range(2) = len_trim (s)
case default
write (STDERR, *) "Invalid lexeme template encountered"
flush (STDERR)
stop
end select
end subroutine match_template
subroutine match_quoted (tt, s, n, range)
type(template_t), intent(in) :: tt
character(*), intent(in) :: s
integer, intent(out) :: n
integer, dimension(2), intent(out) :: range
character(tt%len1) :: ch1
character(tt%len2) :: ch2
integer :: i
ch1 = tt%charset1
if (s(1:tt%len1) == ch1) then
ch2 = tt%charset2
do i = tt%len1 + 1, len (s) - tt%len2 + 1
if (s(i:i+tt%len2-1) == ch2) then
n = i + tt%len2 - 1
range(1) = tt%len1 + 1
range(2) = i - 1
return
end if
end do
n = -1
range = 0
else
n = 0
range = 0
end if
end subroutine match_quoted
subroutine match (tt, s, n, range, ii)
type(template_t), dimension(:), intent(in) :: tt
character(*), intent(in) :: s
integer, intent(out) :: n
integer, dimension(2), intent(out) :: range
integer, intent(out) :: ii
integer :: i
do i = 1, size (tt)
call match_template (tt(i), s, n, range)
if (n /= 0) then
ii = i
return
end if
end do
n = 0
ii = 0
end subroutine match
subroutine match_whitespace (tt, s, n)
type(template_t), intent(in) :: tt
character(*), intent(in) :: s
integer, intent(out) :: n
n = verify (s, tt%charset1(1:tt%len1)) - 1
if (n < 0) n = len (s)
end subroutine match_whitespace
elemental function rule_is_associated (rp) result (ok)
logical :: ok
type (rule_p), intent(in) :: rp
ok = associated (rp%p)
end function rule_is_associated
subroutine syntax_rule_init (rule, key, type)
type(syntax_rule_t), intent(inout) :: rule
type(string_t), intent(in) :: key
integer, intent(in) :: type
rule%keyword = key
rule%type = type
end subroutine syntax_rule_init
function is_modifier (string) result (ok)
logical :: ok
type(string_t), intent(in) :: string
select case (char (string))
case (" ", "?", "*", "+"); ok = .true.
case default; ok = .false.
end select
end function is_modifier
subroutine syntax_rule_set_sub (rule, i, sub)
type(syntax_rule_t), intent(inout) :: rule
integer, intent(in) :: i
type(syntax_rule_t), intent(in), target :: sub
write (STDERR, *) "entering syntax_rule_set_sub, i = ", i
flush (STDERR)
rule%child(i)%p => sub
write (STDERR, *) "exiting syntax_rule_set_sub"
flush (STDERR)
return
end subroutine syntax_rule_set_sub
subroutine syntax_init_from_ifile (syntax, ifile)
type(syntax_t), intent(out), target :: syntax
type(ifile_t), intent(in) :: ifile
type(lexer_t) :: lexer
type(line_p) :: line
type(string_t) :: string
integer :: n_token
integer :: i
call lexer_init (lexer, &
comment_chars = "", &
quote_chars = "<'""", &
quote_match = ">'""", &
single_chars = "*+|=,()", &
special_class = (/ "." /), &
keyword_list = null ())
allocate (syntax%rule (ifile_get_length (ifile)))
call line_init (line, ifile)
do i = 1, size (syntax%rule)
string = line_get_string_advance (line)
call set_rule_type_and_key (syntax%rule(i), string, lexer)
end do
call line_init (line, ifile)
write (STDERR, *) "size syntax rule", size (syntax%rule)
flush (STDERR)
do i = 1, size (syntax%rule)
write (STDERR, *) "### Loop index i:", i, "of ", size(syntax%rule)
flush (STDERR)
string = line_get_string_advance (line)
write (STDERR, *) "string ", char(string), " ###"
flush (STDERR)
write (STDERR, *) "do loop syntax rule, string:", i, syntax%rule(i)%type
flush (STDERR)
select case (syntax%rule(i)%type)
case (S_SEQUENCE)
n_token = get_n_token (string, lexer)
write (STDERR, *) "ntoken = ", n_token
flush (STDERR)
call set_rule_contents &
(syntax%rule(i), syntax, n_token, string, lexer)
end select
write (STDERR, *) "after the select"
flush (STDERR)
end do
end subroutine syntax_init_from_ifile
subroutine set_rule_type_and_key (rule, string, lexer)
type(syntax_rule_t), intent(inout) :: rule
type(string_t), intent(in) :: string
type(lexer_t), intent(inout) :: lexer
type(stream_t) :: stream
type(lexeme_t) :: lexeme
type(string_t) :: key
character(2) :: type
call lexer_clear (lexer)
call stream_init (stream, string)
call lex (lexeme, lexer, stream)
type = lexeme_get_string (lexeme)
call lex (lexeme, lexer, stream)
key = lexeme_get_contents (lexeme)
call stream_final (stream)
if (trim (key) /= "") then
select case (type)
case ("KE"); call syntax_rule_init (rule, key, S_KEYWORD)
case ("SE"); call syntax_rule_init (rule, key, S_SEQUENCE)
case default
write (STDERR, *) " Syntax definition: unknown type '" // type // "'"
flush (STDERR)
stop
end select
else
write (STDERR, *) char (string)
flush (STDERR)
write (STDERR, *) " Syntax definition: empty rule key"
flush (STDERR)
stop
end if
end subroutine set_rule_type_and_key
function get_n_token (string, lexer) result (n)
integer :: n
type(string_t), intent(in) :: string
type(lexer_t), intent(inout) :: lexer
type(stream_t) :: stream
type(lexeme_t) :: lexeme
integer :: i
call stream_init (stream, string)
call lexer_clear (lexer)
i = 0
do
call lex (lexeme, lexer, stream)
if (lexeme_is_break (lexeme)) exit
i = i + 1
end do
n = i
call stream_final (stream)
end function get_n_token
subroutine set_rule_contents (rule, syntax, n_token, string, lexer)
type(syntax_rule_t), intent(inout) :: rule
type(syntax_t), intent(in), target :: syntax
integer, intent(in) :: n_token
type(string_t), intent(in) :: string
type(lexer_t), intent(inout) :: lexer
type(stream_t) :: stream
type(lexeme_t), dimension(n_token) :: lexeme
integer :: i, n_children
write (STDERR, *) "entering set_rule_contents, n_token = ", n_token
flush (STDERR)
call lexer_clear (lexer)
call stream_init (stream, string)
do i = 1, n_token
call lex (lexeme(i), lexer, stream)
end do
call stream_final (stream)
n_children = get_n_children ()
write (STDERR, *) "n_children = ", n_children
flush (STDERR)
if (n_children > 0) call set_children
write (STDERR, *) "exiting set_rule_contents"
flush (STDERR)
contains
function get_n_children () result (n)
integer :: n
select case (rule%type)
case (S_SEQUENCE)
write (STDERR, *) "in select case of get_n_children: S_SEQUENCE"
flush (STDERR)
if (is_modifier (lexeme_get_string (lexeme(n_token)))) then
write (STDERR, *) "unexpected is_modifier"
flush (STDERR)
stop
else
if (n_token <= 3) then
write (STDERR, *) "Broken rule"
flush (STDERR)
end if
n = n_token - 3
write (STDERR, *) "children, token (n<=3)", n, n_token
flush (STDERR)
end if
end select
end function get_n_children
subroutine set_children
write (STDERR, *) "entering set_children, n_children = ", n_children
flush (STDERR)
allocate (rule%child(n_children))
write (STDERR, *) "allocated rule%child"
flush (STDERR)
do i = 1, size (lexeme)
write (STDERR, *) "lexeme(", i, ") = ", char(lexeme(i)%s)
flush (STDERR)
end do
select case (rule%type)
case (S_SEQUENCE)
do i = 1, n_children
call monitor_syntax_rules (syntax)
write (STDERR, *) "before syntax_rule_set_sub, i = ", i
flush (STDERR)
call syntax_rule_set_sub (rule, i, syntax_get_rule_ptr (syntax, &
lexeme_get_contents (lexeme(i+3))))
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!! WHY DO WE NEVER GET HERE ??? syntax_rule_set_sub claims to exit !!!
!!!! WHY IS syntax_get_rule_ptr CALLED MULTIPLE TIMES ???
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
write (STDERR, *) "after syntax_rule_set_sub", i
flush (STDERR)
end do
end select
write (STDERR, *) "exiting set_children"
flush (STDERR)
end subroutine set_children
end subroutine set_rule_contents
function syntax_get_rule_ptr (syntax, key) result (rule)
type(syntax_rule_t), pointer :: rule
type(syntax_t), intent(in), target :: syntax
type(string_t), intent(in) :: key
integer :: i
write (STDERR, *) "entering syntax_get_rule_ptr, size(syntax%rule) = ",
size(syntax%rule)
flush (STDERR)
call monitor_syntax_rules (syntax)
do i = 1, size (syntax%rule)
if (syntax%rule(i)%keyword == key) then
rule => syntax%rule(i)
write (STDERR, *) "exiting syntax_get_rule_ptr"
flush (STDERR)
return
end if
end do
write (STDERR, *) " Syntax table: Rule " // char (key) // " not found"
flush (STDERR)
end function syntax_get_rule_ptr
subroutine monitor_syntax_rules (syntax)
type(syntax_t), intent(in), target :: syntax
integer :: i
write (STDERR, *) "entering monitor_syntax_rules, size(syntax%rule) = ",
size(syntax%rule)
flush (STDERR)
do i = 1, size (syntax%rule)
write (STDERR, *) "syntax%rule(", i, ")%keyword = ",
char(syntax%rule(i)%keyword), &
" (this will become garbage, eventually ...)"
flush (STDERR)
end do
write (STDERR, *) "exiting monitor_syntax_rules"
flush (STDERR)
end subroutine monitor_syntax_rules
end module syntax_rules
program main
use iso_fortran_env, only: STDERR => ERROR_UNIT
use ifiles
use syntax_rules
type(ifile_t) :: ifile
type(syntax_t), target, save :: syntax_model_file
write (STDERR, *) "Starting to load ifile"
flush (STDERR)
call ifile_append (ifile, "SEQ aaaaaaaaaa = bbbbbbbbbb")
call ifile_append (ifile, "KEY bbbbbbbbbb")
write (STDERR, *) "Starting to interpret ifile"
flush (STDERR)
call syntax_init (syntax_model_file, ifile)
write (STDERR, *) "Test finished"
flush (STDERR)
end program main
--
Summary: [4.5.0 Regression] Garbage or segmentation fault in
allocatable array derived type structures
Product: gcc
Version: 4.5.0
Status: UNCONFIRMED
Severity: major
Priority: P3
Component: fortran
AssignedTo: unassigned at gcc dot gnu dot org
ReportedBy: juergen dot reuter at desy dot de
GCC host triplet: both MAC OS X Darwin 9.7.0 and Linux Debian Edge
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440
More information about the Gcc-bugs
mailing list