From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 19678 invoked by alias); 14 Jun 2009 21:50:02 -0000 Received: (qmail 19576 invoked by uid 48); 14 Jun 2009 21:49:46 -0000 Date: Sun, 14 Jun 2009 21:50:00 -0000 Subject: [Bug fortran/40440] New: [4.5.0 Regression] Garbage or segmentation fault in allocatable array derived type structures X-Bugzilla-Reason: CC Message-ID: Reply-To: gcc-bugzilla@gcc.gnu.org To: gcc-bugs@gcc.gnu.org From: "juergen dot reuter at desy dot de" Mailing-List: contact gcc-bugs-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-bugs-owner@gcc.gnu.org X-SW-Source: 2009-06/txt/msg00896.txt.bz2 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