[Bug fortran/43199] New: Internal error using fortran-2003 .mod file

[fmartinez at gmv dot com]

The generated m_string.mod from m_string.f03 generated with latest version of
gcc-fortran 4.5 generates an internal error when used in any other fortran
module through a use statement.

_____________________________________________________________________________

module m_string

!-------------------------------------------------------------------------------
! Copyright : Fran Martinez Fadrique
! Project   : FORTRAN
! Author    : Fran Martinez Fadrique
! Language  : Fortran 95
! Synopsis  : Dynamic character string
!-------------------------------------------------------------------------------

!---USE
statements--------------------------------------------------------------


!---End of use
statements-------------------------------------------------------

  implicit none

!---Public/Private
declarations-------------------------------------------------

  private
  public t_string

  public string, string_

!---End of public/private
declarations------------------------------------------

  character(len=130), parameter, private :: sccs_info = &
    '$Id: $'

!---Declaration of module
variables---------------------------------------------


! Time type
  type t_string

    private
      character, dimension(:), allocatable :: string      ! String buffer
      integer                              :: length = 0  ! String length
      integer                              :: size   = 0  ! Total buffer size

    contains

      generic :: index => string_index_s, string_index_c
      procedure, private :: string_index_s
      procedure, private :: string_index_c

      generic :: operator(+) => string_concat_string, &
                                string_concat_char
      generic :: operator(//) => string_concat_string, &
                                 string_concat_char
      procedure, private :: string_concat_string
      procedure, private :: string_concat_char

      generic :: operator(==) => string_equal_string, &
                                 string_equal_char
      procedure, private :: string_equal_string
      procedure, private :: string_equal_char

      generic :: operator(/=) => string_nonequal_string, &
                                 string_nonequal_char
      procedure, private :: string_nonequal_string
      procedure, private :: string_nonequal_char

      generic :: operator(>) => string_greater_string, &
                                string_greater_char
      generic :: lgt => string_greater_string, &
                        string_greater_char
      procedure, private :: string_greater_string
      procedure, private :: string_greater_char

      generic :: operator(<) => string_less_string, &
                                string_less_char
      generic :: llt => string_less_string, &
                        string_less_char
      procedure, private :: string_less_string
      procedure, private :: string_less_char

      generic :: operator(>=) => string_greater_equal_string, &
                                 string_greater_equal_char
      generic :: lge => string_greater_equal_string, &
                        string_greater_equal_char
      procedure, private :: string_greater_equal_string
      procedure, private :: string_greater_equal_char

      generic :: operator(<=) => string_less_equal_string, &
                                 string_less_equal_char
      generic :: lle => string_less_equal_string, &
                        string_less_equal_char
      procedure, private :: string_less_equal_string
      procedure, private :: string_less_equal_char

      procedure :: len => string_len
      procedure :: len_trim => string_len_trim
      procedure :: trim => string_trim
      procedure :: len_strip => string_len_strip
      procedure :: strip => string_strip
      procedure :: adjustl => string_adjustl
      procedure :: adjustr => string_adjustr
      procedure :: char => string_to_char
      procedure :: write => string_write
      procedure :: write_xml => string_write_xml
      procedure :: read => string_read

  end type t_string

! The blank character
  character, parameter :: blank = ' '

! Element assignement operator
  interface assignment(=)
    module procedure string_assign_from_char
    module procedure char_assign_from_string
  end interface

! Concatenation operations
  interface operator(+)
    module procedure char_concat_string
    module procedure char_concat_char
  end interface
  interface operator(//)
    module procedure char_concat_string
  end interface

! Element comparison operators lead by character instead of string
  interface operator(==)
    module procedure char_equal_string
  end interface
  interface operator(/=)
    module procedure char_nonequal_string
  end interface
  interface operator(>)
    module procedure char_greater_string
  end interface
  interface operator(>=)
    module procedure char_greater_equal_string
  end interface
  interface operator(<)
    module procedure char_less_string
  end interface
  interface operator(<=)
    module procedure char_less_equal_string
  end interface

! Aliases to make the type compatible with intrinsic character
! Read/write interafaces
  interface read
    module procedure string_read
  end interface read
  interface write
    module procedure string_write
  end interface write
  interface write_xml
    module procedure string_write_xml
  end interface write_xml

!---End of declaration of module
variables--------------------------------------

contains


! Constructor
elemental function string( c ) result(s)

! The character string to use as initialisation (optional)
  character(len=*), optional, intent(in)  :: c

! The string
  type(t_string) :: s


! Check input character string
  if( present(c) ) then

!   Initialise from input
    s = c

  else

!   Initialisation by default

  end if

end function string


! Destructor
elemental subroutine string_( s )

! The string
  type(t_string), intent(inout) :: s

! Deallocate memory
  if( allocated(s%string) ) then
    deallocate(s%string)
  end if
  s%size   = 0
  s%length = 0

end subroutine string_


! String length
elemental function string_len ( s ) result(res)

! The string
  class(t_string), intent(in) :: s

! The string length
  integer                    :: res

! Return the length
  res = s%length

end function string_len


! String length (traling blanks removed)
elemental function string_len_trim ( s ) result(res)

! The string
  class(t_string), intent(in) :: s

! The string length
  integer                    :: res

! Check lenth
  if( s%length == 0 ) then
    res = 0
  else
    do res = s%length, 1, -1
      if( s%string(res) /= blank ) exit
    end do
  end if

end function string_len_trim


! String length (traling leading and blanks removed)
elemental function string_len_strip ( s ) result(res)

! The string
  class(t_string), intent(in) :: s

! The string length
  integer                    :: res

! Compute length
  res = len_trim(adjustl(s%char()))

end function string_len_strip


! Remove string traling blanks
elemental function string_trim ( s ) result(res)

! The string
  class(t_string), intent(in) :: s

! The resulting character string
  type(t_string)             :: res

! Allocate return string
  res%length = s%len_trim()
  res%size   = res%length
  allocate( res%string(res%length) )

! Compute the trimmed string
  res%string(:res%length) = s%string(:res%length)

end function string_trim


! Remove string leading and traling blanks
elemental function string_strip ( s ) result(res)

! The string
  class(t_string), intent(in) :: s

! The resulting character string
  type(t_string)             :: res


! Allocate return string
  res%length = len_trim(adjustl(s%char()))
  res%size   = res%length
  allocate( res%string(res%length) )

! Compute the stripped string
  res%string(:res%length) = transfer( adjustl(s%char()), s%string )

end function string_strip


! Left justify string contents
elemental function string_adjustl ( s ) result(res)

! The string
  class(t_string), intent(in) :: s

! The resulting character string
  type(t_string)             :: res

! Compute the left justified string
  res = adjustl(s%char())

end function string_adjustl


! Right justify string contents
elemental function string_adjustr ( s ) result(res)

! The string
  class(t_string), intent(in) :: s

! The resulting character string
  type(t_string)             :: res

! Compute the right justified string
  res = adjustr(s%char())

end function string_adjustr


! Get the position of a substring in a string
elemental function string_index_s( s, subs, back ) result(res)

! The string
  class(t_string), intent(in) :: s

! The string searched
  type(t_string), intent(in) :: subs

! The search direction
  logical, optional,    intent(in) :: back

! The character position
  integer                          :: res

! Compute the position
  res = index( s%char(), subs%char(), back)

end function string_index_s


! Get the position of a substring in a string
elemental function string_index_c( s, subs, back ) result(res)

! The string
  class(t_string),       intent(in) :: s

! The string searched
  character(len=*),     intent(in) :: subs

! The search direction
  logical, optional,    intent(in) :: back

! The character position
  integer                          :: res

! Compute the position
  res = index(s%char(),subs,back)

end function string_index_c


! Return the string as character
pure function string_to_char ( s ) result(res)

! The string
  class(t_string), intent(in) :: s

! The resulting character string
  character(len=size(s%string)) :: res

! Return the character string
  res = transfer( s%string, res )

end function string_to_char


! Read a string from an open unit
subroutine string_read( s, unit, iostat, format )

! The string
  class(t_string),             intent(out) :: s

! The open file to read from
  integer,                    intent(in)  :: unit

! The read condition status
  integer, optional,          intent(out) :: iostat

! The read format (optional)
  character(len=*), optional, intent(in)  :: format

! Local storage
  character(len=1024) :: local
  integer :: lsize

! Check format
  if( present(format) ) then
    read(unit,format,iostat=iostat) local
    lsize = len(local)
  else
    read(unit,'(A1024)',iostat=iostat) local
    lsize = len_trim(local)
  end if

! Generate output string
  allocate( s%string(lsize) )
  s%string = transfer( local, s%string )

end subroutine string_read


! Write in XML
subroutine string_write_xml( s, unit, label )

! The string
  class(t_string),   intent(in) :: s

! The open file to write the element to
  integer,          intent(in) :: unit

! Envelope XML tag
  character(len=*), intent(in) :: label

! Write the vector envelope start tag
  write(unit,'(A)',advance='no') '<' // label // '>'

! Write the string
  call string_write( s, unit, advance='no' )

! Write the vector envelope end tag
  write(unit,'(A)') '</' // label // '>'

end subroutine string_write_xml


! Write in ASCII
subroutine string_write( s, unit, advance )

! The vector
  class(t_string),             intent(in) :: s

! The open file to write the element to
  integer,                    intent(in) :: unit

! Write a new line after the vector (true by default)
  character(len=*), optional, intent(in) :: advance


! Write the string
  write( unit, '(A)', advance='no' ) s%char()

! Check for newline at the end
  if( present(advance) ) then
    if( advance == 'YES' ) then
      write(unit,*)
    end if
  else
    write(6,*)
  end if

end subroutine string_write


! Assign operator (string from char)
elemental subroutine string_assign_from_char( left, right )

! The target string
  type(t_string),   intent(out) :: left

! The source string
  character(len=*), intent(in)  :: right

! Assign memory
  allocate(left%string(len(right)))
  left%string = blank

! Copy memory
  left%string = transfer( right, left%string )

! Copy structure information
  left%size   = len(right)
  left%length = len(right)

end subroutine string_assign_from_char


! Assign operator (char from string)
pure subroutine char_assign_from_string( left, right )

! The target string
  character(len=*), intent(out) :: left

! The source string
  type(t_string),                    intent(in)  :: right

! Copy memory
  left = ' '
  left(:right%length) = transfer( right%string(:right%length), left )

end subroutine char_assign_from_string


! Concatenation operations
elemental function string_concat_string( left, right ) result(res)

! The left string
  class(t_string), intent(in) :: left

! The right string
  type(t_string), intent(in) :: right

! The resulting string
  type(t_string) :: res

! Size of the resulting string
  integer :: size_l, size_r

! Check buffer sizes (minimise buffer grouth)
  size_l = left%len_trim()
  size_r = right%len_trim()

! Allocate resulting string
  allocate( res%string(size_l+size_r) )

! Compute the resulting string
  res%string(1:size_l)             = left%string
  res%string(size_l+1:size_l+size_r) = right%string
  res%length = size_l + size_r
  res%size = res%length

end function string_concat_string


! Concatenation operations
elemental function string_concat_char( left, right ) result(res)

! The left string
  class(t_string),   intent(in) :: left

! The right string
  character(len=*), intent(in) :: right

! The resulting string
  type(t_string) :: res

! Size of the resulting string
  integer :: size_l, size_r

! Check buffer sizes (minimise buffer grouth)
  size_l = left%len_trim()
  size_r = len(right)

! Allocate resulting string
  allocate( res%string(size_l+size_r) )

! Compute the resulting string
  res%string(1:size_l)             = left%string
  res%string(size_l+1:size_l+size_r) = transfer( right, res%string(1:size_r) )
  res%length = size_l + size_r
  res%size = res%length

end function string_concat_char


! Concatenation operations
elemental function char_concat_string( left, right ) result(res)

! The left string
  character(len=*), intent(in) :: left

! The right string
  type(t_string),   intent(in) :: right

! The resulting string
  type(t_string) :: res

! Size of the resulting string
  integer :: size_l, size_r

! Check buffer sizes (minimise buffer grouth)
  size_l = len(left)
  size_r = right%len_trim()

! Allocate resulting string
  allocate( res%string(size_l+size_r) )

! Compute the resulting string
  res%string(1:size_l)             = transfer( left, res%string(1:size_l) )
  res%string(size_l+1:size_l+size_r) = right%string(1:size_r)
  res%length = size_l + size_r
  res%size = res%length

end function char_concat_string


! Concatenation operations
elemental function char_concat_char( left, right ) result(res)

! The left string
  character(len=*),     intent(in) :: left

! The right string
  character(len=*),     intent(in) :: right

! The resulting string
  type(t_string) :: res

! Size of the resulting string
  integer :: size_l, size_r

! Check buffer sizes (minimise buffer grouth)
  size_l = len(left)
  size_r = len(right)

! Allocate resulting string
  allocate( res%string(size_l+size_r) )

! Compute the resulting string
  res%string(1:size_l)               = transfer( left, res%string(1:size_l) )
  res%string(size_l+1:size_l+size_r) = transfer( right, res%string(1:size_r) )
  res%length = size_l + size_r
  res%size = res%length

end function char_concat_char


! Equality comparison operator (string == string)
elemental function string_equal_string( left, right ) result(res)

! The left string
  class(t_string), intent(in) :: left

! The right string
  type(t_string), intent(in) :: right

! The comparison result
  logical                    :: res

! String lengths (traling blanks removed)
  integer size_l, size_r

! Compute lengths
  size_l = left%len_trim()
  size_r = right%len_trim()

! Compute equality
  if( size_l == size_r ) then
    res = all( left%string(1:size_l) == right%string(1:size_r) )
  else
    res = .false.
  end if

end function string_equal_string


! Equality comparison operator (string == character)
elemental function string_equal_char( left, right ) result(res)

! The left string
  class(t_string),   intent(in) :: left

! The right string
  character(len=*), intent(in) :: right

! The comparison result
  logical                      :: res

! String lengths (traling blanks removed)
  integer size_l, size_r

! Compute lengths
  size_l = left%len_trim()
  size_r = len_trim(right)

! Compute equality
  if( size_l == size_r ) then
    res = all( left%string(1:size_l) == right(1:size_r) )
  else
    res = .false.
  end if

end function string_equal_char


! Equality comparison operator (character == string)
elemental function char_equal_string( left, right ) result(res)

! The left string
  character(len=*), intent(in) :: left

! The right string
  type(t_string),   intent(in) :: right

! The comparison result
  logical                      :: res

! String lengths (traling blanks removed)
  integer size_l, size_r

! Compute lengths
  size_l = len_trim(left)
  size_r = right%len_trim()

! Compute equality
  if( size_l == size_r ) then
    res = left(1:size_l) == transfer( right%string(1:size_r), left )
  else
    res = .false.
  end if

end function char_equal_string


! Inequality comparison operator (string /= string)
elemental function string_nonequal_string( left, right ) result(res)

! The left string
  class(t_string), intent(in) :: left

! The right string
  type(t_string), intent(in) :: right

! The comparison result
  logical                    :: res

! String lengths (traling blanks removed)
  integer size_l, size_r

! Compute lengths
  size_l = left%len_trim()
  size_r = right%len_trim()

! Compute equality
  if( size_l == size_r ) then
    res = any( left%string(1:size_l) /= right%string(1:size_r) )
  else
    res = .true.
  end if

end function string_nonequal_string


! Inequality comparison operator (string /= character)
elemental function string_nonequal_char( left, right ) result(res)

! The left string
  class(t_string),   intent(in) :: left

! The right string
  character(len=*), intent(in) :: right

! The comparison result
  logical                      :: res

! String lengths (traling blanks removed)
  integer size_l, size_r

! Compute lengths
  size_l = left%len_trim()
  size_r = len_trim(right)

! Compute equality
  if( size_l == size_r ) then
    res = any( left%string(1:size_l) /= right(1:size_r) )
  else
    res = .true.
  end if

end function string_nonequal_char


! Inequality comparison operator (character /= string)
elemental function char_nonequal_string( left, right ) result(res)

! The left string
  character(len=*), intent(in) :: left

! The right string
  type(t_string),   intent(in) :: right

! The comparison result
  logical                      :: res

! String lengths (traling blanks removed)
  integer size_l, size_r

! Compute lengths
  size_l = len_trim(left)
  size_r = right%len_trim()

! Compute equality
  if( size_l == size_r ) then
    res = any( left(1:size_l) /= right%string(1:size_r) )
  else
    res = .true.
  end if

end function char_nonequal_string


! Comparison operator 'string > string'  
elemental function string_greater_string( left, right ) result(res)

! The left string
  class(t_string), intent(in) :: left

! The right string
  type(t_string), intent(in) :: right

! The comparison result
  logical                    :: res

! String lengths (traling blanks removed)
  integer size_l, size_r

! Compute lengths
  size_l = left%len_trim()
  size_r = right%len_trim()

! Compute comparison
  res = lgt( transfer( left%string,  repeat(' ',size_l) ),   &
             transfer( right%string, repeat(' ',size_r) ) )

end function string_greater_string


! Comparison operator 'string > character'  
elemental function string_greater_char( left, right ) result(res)

! The left string
  class(t_string), intent(in) :: left

! The right string
  character(len=*),     intent(in) :: right

! The comparison result
  logical                          :: res

! String lengths (traling blanks removed)
  integer size_l

! Compute lengths
  size_l = left%len_trim()

! Compute comparison
  res = lgt( transfer( left%string,  repeat(' ',size_l) ), right )

end function string_greater_char


! Comparison operator 'character > string'
elemental function char_greater_string( left, right ) result(res)

! The left string
  character(len=*), intent(in) :: left

! The right string
  type(t_string),   intent(in) :: right

! The comparison result
  logical                      :: res

! String lengths (traling blanks removed)
  integer size_r

! Compute lengths
  size_r = right%len_trim()

! Compute comparison
  res = lgt( left, transfer( right%string,  repeat(' ',size_r) ) )

end function char_greater_string


! Comparison operator 'string >= string'
elemental function string_greater_equal_string( left, right ) result(res)

! The left string
  class(t_string), intent(in) :: left

! The right string
  type(t_string), intent(in) :: right

! The comparison result
  logical                    :: res

! String lengths (traling blanks removed)
  integer size_l, size_r

! Compute lengths
  size_l = left%len_trim()
  size_r = right%len_trim()

! Compute comparison
  res = lge( transfer( left%string,  repeat(' ',size_l) ),   &
             transfer( right%string, repeat(' ',size_r) ) )

end function string_greater_equal_string


! Comparison operator 'string >= character'  
elemental function string_greater_equal_char( left, right ) result(res)

! The left string
  class(t_string),   intent(in) :: left

! The right string
  character(len=*), intent(in) :: right

! The comparison result
  logical                      :: res

! String lengths (traling blanks removed)
  integer size_l

! Compute lengths
  size_l = left%len_trim()

! Compute comparison
  res = lge( transfer( left%string,  repeat(' ',size_l) ), right )

end function string_greater_equal_char


! Comparison operator 'character >= string'
elemental function char_greater_equal_string( left, right ) result(res)

! The left string
  character(len=*), intent(in) :: left

! The right string
  type(t_string),   intent(in) :: right

! The comparison result
  logical                      :: res

! String lengths (traling blanks removed)
  integer size_r

! Compute lengths
  size_r = right%len_trim()

! Compute comparison
  res = lge( left, transfer( right%string,  repeat(' ',size_r) ) )

end function char_greater_equal_string


! Comparison operator 'string < string'
elemental function string_less_string( left, right ) result(res)

! The left string
  class(t_string), intent(in) :: left

! The right string
  type(t_string), intent(in) :: right

! The comparison result
  logical                    :: res

! String lengths (traling blanks removed)
  integer size_l, size_r

! Compute lengths
  size_l = left%len_trim()
  size_r = right%len_trim()

! Compute comparison
  res = llt( transfer( left%string,  repeat(' ',size_l) ),   &
             transfer( right%string, repeat(' ',size_r) ) )

end function string_less_string


! Comparison operator 'string < character'  
elemental function string_less_char( left, right ) result(res)

! The left string
  class(t_string),   intent(in) :: left

! The right string
  character(len=*), intent(in) :: right

! The comparison result
  logical                      :: res

! String lengths (traling blanks removed)
  integer size_l

! Compute lengths
  size_l = left%len_trim()

! Compute comparison
  res = llt( transfer( left%string,  repeat(' ',size_l) ), right )

end function string_less_char


! Comparison operator 'character < string'
elemental function char_less_string( left, right ) result(res)

! The left string
  character(len=*), intent(in) :: left

! The right string
  type(t_string),   intent(in) :: right

! The comparison result
  logical                      :: res

! String lengths (traling blanks removed)
  integer size_r

! Compute lengths
  size_r = right%len_trim()

! Compute comparison
  res = llt( left, transfer( right%string,  repeat(' ',size_r) ) )

end function char_less_string


! Comparison operator 'string <= string'
elemental function string_less_equal_string( left, right ) result(res)

! The left string
  class(t_string), intent(in) :: left

! The right string
  type(t_string), intent(in) :: right

! The comparison result
  logical                    :: res

! String lengths (traling blanks removed)
  integer size_l, size_r

! Compute lengths
  size_l = left%len_trim()
  size_r = right%len_trim()

! Compute comparison
  res = lle( transfer( left%string,  repeat(' ',size_l) ),   &
             transfer( right%string, repeat(' ',size_r) ) )

end function string_less_equal_string


! Comparison operator 'string <= character'  
elemental function string_less_equal_char( left, right ) result(res)

! The left string
  class(t_string),   intent(in) :: left

! The right string
  character(len=*), intent(in) :: right

! The comparison result
  logical                      :: res

! String lengths (traling blanks removed)
  integer size_l

! Compute lengths
  size_l = left%len_trim()

! Compute comparison
  res = lle( transfer( left%string,  repeat(' ',size_l) ), right )

end function string_less_equal_char


! Comparison operator 'character <= string'
elemental function char_less_equal_string( left, right ) result(res)

! The left string
  character(len=*), intent(in) :: left

! The right string
  type(t_string),   intent(in) :: right

! The comparison result
  logical                      :: res

! String lengths (traling blanks removed)
  integer size_r

! Compute lengths
  size_r = right%len_trim()

! Compute comparison
  res = lle( left, transfer( right%string,  repeat(' ',size_r) ) )

end function char_less_equal_string

end module m_string


-- 
           Summary: Internal error using fortran-2003 .mod file
           Product: gcc
           Version: 4.5.0
            Status: UNCONFIRMED
          Severity: blocker
          Priority: P3
         Component: fortran
        AssignedTo: unassigned at gcc dot gnu dot org
        ReportedBy: fmartinez at gmv dot com


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