[Bug fortran/40440] New: [4.5.0 Regression] Garbage or segmentation fault in allocatable array derived type structures

[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]

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

[Bug fortran/40440] [4.5.0 Regression] Garbage or segmentation fault in allocatable array derived type structures

[kargl at gcc dot gnu dot org]

------- Comment #1 from kargl at gcc dot gnu dot org  2009-06-14 22:14 -------
Please add your code as an attachment.

The severity of fortran bugs are never major unless the bug
breaks bootstrap.  Adjusted severity to normal.


-- 

kargl at gcc dot gnu dot org changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
           Severity|major                       |normal


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] [4.5.0 Regression] Garbage or segmentation fault in allocatable array derived type structures

[juergen dot reuter at desy dot de]

------- Comment #2 from juergen dot reuter at desy dot de  2009-06-14 22:18 -------
Created an attachment (id=17996)
 --> (http://gcc.gnu.org/bugzilla/attachment.cgi?id=17996&action=view)
contains modules iso_varying_string, ifiles, syntax_rules and main test program

COmplete code for the test case including the module iso_varying_string


-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] [4.4/4.5 Regression] Garbage or segmentation fault in allocatable array derived type structures

[burnus at gcc dot gnu dot org]

------- Comment #3 from burnus at gcc dot gnu dot org  2009-06-15 08:52 -------
(In reply to comment #2)
> COmplete code for the test case including the module iso_varying_string

Works with: gfortran 4.3.3, ifort 11, sunf95, NAG f95 5.1 (w/o flush
statements)
Fails (abort) with gfortran 4.4.1/4.5

Valgrind shows several uninitialized accesses (gfortran 4.3.3, 4.4, and 4.5),
but no errors with NAG f95 or ifort. Interestingly, it runs through with
valgrind + gfortran 4.5, which means that it could be no regression and working
in 4.3.3 only by chance.

valgrind finds essentially the following two errors with gfortran 4.5:

 Invalid read of size 1
    at 0x4091FC: __iso_varying_string_MOD_char_auto (foo.f90:868)
    by 0x40B73F: __syntax_rules_MOD_monitor_syntax_rules (foo.f90:3450)
    by 0x40B8F5: __syntax_rules_MOD_syntax_get_rule_ptr (foo.f90:3431)
    by 0x40C242: set_children.6490 (foo.f90:3410)
    by 0x40C933: __syntax_rules_MOD_set_rule_contents (foo.f90:3366)
    by 0x40E9E5: __syntax_rules_MOD_syntax_init_from_ifile (foo.f90:3287)
    by 0x412C6E: MAIN__ (foo.f90:3472)

 Use of uninitialised value of size 8
    at 0x40C261: set_children.6490 (foo.f90:3410)
    by 0x40C933: __syntax_rules_MOD_set_rule_contents (foo.f90:3366)
    by 0x40E9E5: __syntax_rules_MOD_syntax_init_from_ifile (foo.f90:3287)
    by 0x412C6E: MAIN__ (foo.f90:3472)
    by 0x412D09: main (foo.f90:3462)


-- 

burnus at gcc dot gnu dot org changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
           Keywords|                            |wrong-code
      Known to fail|                            |4.4.1 4.5.0
      Known to work|                            |4.3.3
            Summary|[4.5.0 Regression] Garbage  |[4.4/4.5 Regression] Garbage
                   |or segmentation fault in    |or segmentation fault in
                   |allocatable array derived   |allocatable array derived
                   |type structures             |type structures
   Target Milestone|---                         |4.4.1


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] [4.4/4.5 Regression] Garbage or segmentation fault in allocatable array derived type structures

[burnus at gcc dot gnu dot org]

------- Comment #4 from burnus at gcc dot gnu dot org  2009-06-15 12:16 -------
Note: syntax_get_rule_ptr is defined as:

  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

and "syntax_rule_set_sub" is defined as follows where "sub" is the relevant
argument:

  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

If one looks at the dump for the following line in set_rule_contents

            call syntax_rule_set_sub (rule, i, syntax_get_rule_ptr (syntax, &
                  lexeme_get_contents (lexeme(i+3))))

one finds:

  integer(kind=8) S.297;
  struct varying_string D.6550;
  D.6550 = lexeme_get_contents (&(*lexeme)[(integer(kind=8)) (i + 3) + -1]);
  syntax_rule_set_sub ((struct syntax_rule_t *) rule, &i,
         syntax_get_rule_ptr ((struct syntax_t *) syntax, &D.6550));

which looks OK. But then it continues:

  if (syntax_get_rule_ptr ((struct syntax_t *) syntax, 
                           &D.6550)->keyword.chars.data != 0B)
    __builtin_free (syntax_get_rule_ptr ((struct syntax_t *) syntax,
                                         &D.6550)->keyword.chars.data);
  syntax_get_rule_ptr ((struct syntax_t *) syntax,
                       &D.6550)->keyword.chars.data = 0B;
  if (syntax_get_rule_ptr ((struct syntax_t *) syntax,
                           &D.6550)->separator.chars.data != 0B)
     __builtin_free (syntax_get_rule_ptr ((struct syntax_t *) syntax,
                                          &D.6550)->separator.chars.data);
  syntax_get_rule_ptr ((struct syntax_t *) syntax,
                       &D.6550)->separator.chars.data = 0B;
  S.297 = 0;
  while (1)
    {
       if (S.297 > 1) goto L.27;
       if (syntax_get_rule_ptr ((struct syntax_t *) syntax, 
                                &D.6550)->delimiter[S.297].chars.data != 0B)
         __builtin_free (syntax_get_rule_ptr ((struct syntax_t *) syntax,
                                     &D.6550)->delimiter[S.297].chars.data);
       syntax_get_rule_ptr ((struct syntax_t *) syntax,
                            &D.6550)->delimiter[S.297].chars.data = 0B;
       S.297 = S.297 + 1;
    }
  L.27:;
  if (syntax_get_rule_ptr ((struct syntax_t *) syntax,
                           &D.6550)->child.data != 0B)
     __builtin_free (syntax_get_rule_ptr ((struct syntax_t *) syntax,
                                          &D.6550)->child.data);
  syntax_get_rule_ptr ((struct syntax_t *) syntax, &D.6550)->child.data = 0B;
  if (D.6550.chars.data != 0B)
    __builtin_free (D.6550.chars.data);
  D.6550.chars.data = 0B;


Thus the problem seems to be that "syntax_get_rule_ptr" is treated as variable
and not as function call.


-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[burnus at gcc dot gnu dot org]

------- Comment #5 from burnus at gcc dot gnu dot org  2009-06-15 13:09 -------
Juergen: Thanks for the report, but it is not a regression - it might not crash
with 4.3 (or your 4.4) but I think that's just by chance.

Paul, I think also this bug touches code for which you have the expertise.

The problem is the automatic deallocation of an allocatable component. The DT
with this component is returned by a function but treated as variable and not
as function. The crucial part is that the return value is a pointer! If I don't
use a pointer, the dump looks as follows:

    D.1558 = func ();
    sub (&D.1558);
    if (D.1558.a.data != 0B)
        __builtin_free (D.1558.a.data);
    D.1558.a.data = 0B;

with POINTER:

  sub (func ());
  if (func ()->a.data != 0B)
      __builtin_free (func ()->a.data);
  func ()->a.data = 0B;

Testcase:
!--------------------------------------------
  implicit none
  type t
    integer, allocatable :: A(:)
  end type t
  call sub(func())
contains
  function func()
    type(t),pointer :: func
    integer :: i = 0
    if (i /= 0) call abort()
    i = i + 1
  end function func
  subroutine sub(a)
    type(t), intent(IN),target :: a
  end subroutine sub
end


-- 

burnus at gcc dot gnu dot org changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
                 CC|                            |pault at gcc dot gnu dot
                   |                            |org, burnus at gcc dot gnu
                   |                            |dot org
             Status|UNCONFIRMED                 |NEW
     Ever Confirmed|0                           |1
   GCC host triplet|both MAC OS X Darwin 9.7.0  |
                   |and Linux Debian Edge       |
      Known to fail|4.4.1 4.5.0                 |4.4.1 4.5.0 4.3.3
      Known to work|4.3.3                       |
   Last reconfirmed|0000-00-00 00:00:00         |2009-06-15 13:09:45
               date|                            |
            Summary|[4.4/4.5 Regression] Garbage|Automatic deallocation
                   |or segmentation fault in    |component of DT function
                   |allocatable array derived   |return value
                   |type structures             |


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[pault at gcc dot gnu dot org]

------- Comment #6 from pault at gcc dot gnu dot org  2009-06-18 09:44 -------
(In reply to comment #5)
> Juergen: Thanks for the report, but it is not a regression - it might not crash
> with 4.3 (or your 4.4) but I think that's just by chance.
> 
> Paul, I think also this bug touches code for which you have the expertise.
> 
> The problem is the automatic deallocation of an allocatable component. The DT
> with this component is returned by a function but treated as variable and not
> as function. The crucial part is that the return value is a pointer! If I 

Yeeees.... there is a bug there somewhere. I shall have to think this through.
I am not sure that your testcase should be allowed at all!  I am not sure that
I understand what it means.

Paul


-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[juergen dot reuter at desy dot de]

------- Comment #7 from juergen dot reuter at desy dot de  2009-06-18 13:33 -------
(In reply to comment #6)
> (In reply to comment #5)

 The crucial part is that the return value is a pointer! If I 
> 
> Yeeees.... there is a bug there somewhere. I shall have to think this through.
> I am not sure that your testcase should be allowed at all!  I am not sure that
> I understand what it means.
> 
> Paul

Dear Paul,
if you need any help please let me know. It might also be possible that we
wrote
some code contradicting conventions, which would be valuable to know. I'm still
convinced that this is a problem of the compiler, since it works with the NAG
and Intel compilers.



-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[burnus at gcc dot gnu dot org]

------- Comment #8 from burnus at gcc dot gnu dot org  2009-06-18 14:45 -------
> I am not sure that your testcase should be allowed at all!  I am not sure that
> I understand what it means.

I think it is valid and not different from:

  integer, pointer :: ptr
  allocate(ptr)
  ptr = 5
  call f(ptr)

where you don't pass the pointer "ptr" to "f" but the target of pointer "f".


My example is invalid, however, as I never set the return value. Add
  allocate(func)
if you want. That should make it valid as one now has a pointer target. But it
shouldn't matter regarding the bug. (The not-needed "target" attribute can also
be removed.)


Regarding the big program:

  function f(tgt)
    integer,target :: tgt
    f => tgt
  end function f

I am not sure that using "tgt" as return value is valid; I think as soon as one
leaves "f", the "tgt" dummy ceases to exist, which would make it invalid. But I
might be wrong and it is valid. In practice, it should work if the actual
argument is either in static memory or one uses the pointer while the target is
still on the stack (or on the heap).
(If one wants to check the validity, one needs to read all about pointers,
targets and argument association - and maybe scope - in the standard.)


-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[burnus at gcc dot gnu dot org]

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain, Size: 1809 bytes --]



------- Comment #9 from burnus at gcc dot gnu dot org  2009-06-18 15:17 -------
(In reply to comment #7)
> I'm still convinced that this is a problem of the compiler, since it works with the
> NAG and Intel compilers.

Well, compilers can have all bugs - and not all invalid programs can be
diagnosed as such by a compiler.

In any case, I believe gfortran has a bug (cf. comment 5 and comment 8).


(In reply to comment #8)
> Regarding the big program:
[...]

I think the big program is valid (at least with this regard) as the following
applies.

"If the dummy argument has the TARGET attribute, does not have the VALUE
attribute, and is
 either a scalar or an assumed-shape array, and the corresponding actual
argument has the
 TARGET attribute but is not an array section with a vector subscript then
 (1) Any pointers associated with the actual argument become associated with
the
     corresponding dummy argument on invocation of the procedure and
 (2) When execution of the procedure completes, any pointers that do not become
undefined
     (16.4.2.1.3) and are associated with the dummy argument remain associated
with the
     actual argument." [F2003, 12.4.1.2 Actual arguments associated with dummy
data objects]


And in "16.4.2.1.3 Events that cause the association status of pointers to
become undefined". Relevant would be for instance:

"(4) Execution of a RETURN or END statement causes the pointer’s target to
become undefined
     (item (3) of 16.5.6),"

which is never the case for the PROGRAM; additionally, the SAVE preserves it
even longer [(3) in 16.5.6]:

"Variables become undefined as follows: [...]
 (3) When execution of an instance of a subprogram completes,
     (a) its unsaved local variables become undefined,"


-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[pault at gcc dot gnu dot org]

------- Comment #10 from pault at gcc dot gnu dot org  2009-06-18 20:51 -------
(In reply to comment #8)
> > I am not sure that your testcase should be allowed at all!  I am not sure that
> > I understand what it means.
> 
> I think it is valid and not different from:

Yes, I understood after a bit of dyslexia about it :-(

Since the function result is a pointer, it is an ultimate component and, I
think, the deallocation of the allocatable components should not be attempted.

If you agree with me, I'll make it so.  Otherwise, it'll need a temporary.

Cheers

Paul


-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[burnus at gcc dot gnu dot org]

------- Comment #11 from burnus at gcc dot gnu dot org  2009-06-18 21:15 -------
(In reply to comment #10)
> Yes, I understood after a bit of dyslexia about it :-(
> 
> Since the function result is a pointer, it is an ultimate component and, I
> think, the deallocation of the allocatable components should not be attempted.

I agree that no deallocation should happen. (Sorry for claiming so before.)


-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[pault at gcc dot gnu dot org]

------- Comment #12 from pault at gcc dot gnu dot org  2009-06-19 00:20 -------
Adding at trans-expr.c:2740

        && !(e->symtree && e->symtree->n.sym->attr.pointer)

eliminates the problem in the reduced testcase and allows the original testcase
to run correctly.  This has not been regtested yet - even if it introduces
regressions, it will be a question of getting the condition right. Notice that
pointer variables need to be excluded from deallocation of allocatable
components too.

My tree is sourced from a more recent version of svn than is available on the
system that I am using - hence the lack of a diff.

It's mine :-)

Cheers

Paul


-- 

pault at gcc dot gnu dot org changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
         AssignedTo|unassigned at gcc dot gnu   |pault at gcc dot gnu dot org
                   |dot org                     |
             Status|NEW                         |ASSIGNED
   Last reconfirmed|2009-06-15 13:09:45         |2009-06-19 00:20:01
               date|                            |


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[pault at gcc dot gnu dot org]

------- Comment #13 from pault at gcc dot gnu dot org  2009-06-19 21:58 -------
Subject: Bug 40440

Author: pault
Date: Fri Jun 19 21:58:27 2009
New Revision: 148731

URL: http://gcc.gnu.org/viewcvs?root=gcc&view=rev&rev=148731
Log:
2009-06-19  Paul Thomas  <pault@gcc.gnu.org>

        PR fortran/40440
        * trans-expr.c (gfc_conv_procedure_call): Do not deallocate
        allocatable components if the argument is a pointer.

2009-06-19  Paul Thomas  <pault@gcc.gnu.org>

        PR fortran/40440
        * gfortran.dg/alloc_comp_result_2.f90: New test.

Added:
    trunk/gcc/testsuite/gfortran.dg/alloc_comp_result_2.f90
Modified:
    trunk/gcc/fortran/ChangeLog
    trunk/gcc/fortran/trans-expr.c
    trunk/gcc/testsuite/ChangeLog


-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[pault at gcc dot gnu dot org]

------- Comment #14 from pault at gcc dot gnu dot org  2009-07-09 19:28 -------
Subject: Bug 40440

Author: pault
Date: Thu Jul  9 19:28:20 2009
New Revision: 149431

URL: http://gcc.gnu.org/viewcvs?root=gcc&view=rev&rev=149431
Log:
2009-07-09  Paul Thomas  <pault@gcc.gnu.org>

        PR fortran/40440
        * trans-expr.c (gfc_conv_procedure_call): Do not deallocate
        allocatable components if the argument is a pointer.

2009-07-09  Paul Thomas  <pault@gcc.gnu.org>

        PR fortran/40440
        * gfortran.dg/alloc_comp_result_2.f90: New test.

Added:
    branches/gcc-4_4-branch/gcc/testsuite/gfortran.dg/alloc_comp_result_2.f90
Modified:
    branches/gcc-4_4-branch/gcc/fortran/ChangeLog
    branches/gcc-4_4-branch/gcc/fortran/trans-expr.c
    branches/gcc-4_4-branch/gcc/testsuite/ChangeLog


-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[pault at gcc dot gnu dot org]

------- Comment #15 from pault at gcc dot gnu dot org  2009-07-09 19:29 -------
Fixed on trunk and 4.4

Thanks for the patch

Paul


-- 

pault at gcc dot gnu dot org changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
             Status|ASSIGNED                    |RESOLVED
         Resolution|                            |FIXED


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[pault at gcc dot gnu dot org]

------- Comment #16 from pault at gcc dot gnu dot org  2009-10-11 12:20 -------
Subject: Bug 40440

Author: pault
Date: Sun Oct 11 12:20:09 2009
New Revision: 152640

URL: http://gcc.gnu.org/viewcvs?root=gcc&view=rev&rev=152640
Log:
2009-10-11  Paul Thomas  <pault@gcc.gnu.org>

        PR fortran/40440
        * decl.c (hash_value): New function.
        (gfc_match_derived_decl): Call it.

2009-10-11  Paul Thomas  <pault@gcc.gnu.org>

        PR fortran/40440
        * gfortran.dg/class_4a.f03: New test with class_4b,c and d.f03.
        * gfortran.dg/class_4b.f03: As above.
        * gfortran.dg/class_4c.f03: As above.
        * gfortran.dg/class_4d.f03: As above.

Added:
    trunk/gcc/testsuite/gfortran.dg/class_4a.f03
    trunk/gcc/testsuite/gfortran.dg/class_4b.f03
    trunk/gcc/testsuite/gfortran.dg/class_4c.f03
    trunk/gcc/testsuite/gfortran.dg/class_4d.f03
Modified:
    trunk/gcc/fortran/ChangeLog
    trunk/gcc/fortran/decl.c
    trunk/gcc/testsuite/ChangeLog


-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440

[Bug fortran/40440] Automatic deallocation component of DT function return value

[pault at gcc dot gnu dot org]

------- Comment #17 from pault at gcc dot gnu dot org  2009-10-11 12:26 -------
(In reply to comment #16)

Sorry - that was fingers trouble on my part - wrong PR.

Paul


-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=40440