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
