Skip to content

R
riscv-gcc-1
Commit 0348d6fd by Richard Sandiford Committed by Richard Sandiford
Options

re PR fortran/15326 ([4.0 only] ICE with assumed length character strings) 

	PR fortran/15326
	* trans-array.c (gfc_add_loop_ss_code): Set ss->string_length in
	the GFC_SS_FUNCTION case too.
	* trans-expr.c (gfc_conv_function_val): Allow symbols to be bound
	to function pointers as well as function decls.
	(gfc_interface_sym_mapping, gfc_interface_mapping): New structures.
	(gfc_init_interface_mapping, gfc_free_interface_mapping)
	(gfc_get_interface_mapping_charlen, gfc_get_interface_mapping_array)
	(gfc_set_interface_mapping_bounds, gfc_add_interface_mapping)
	(gfc_finish_interface_mapping, gfc_apply_interface_mapping_to_cons)
	(gfc_apply_interface_mapping_to_ref)
	(gfc_apply_interface_mapping_to_expr)
	(gfc_apply_interface_mapping): New functions.
	(gfc_conv_function_call): Evaluate the arguments before working
	out where the result should go.  Make the null pointer case provide
	the string length in parmse.string_length.  Cope with non-constant
	string lengths, using the above functions to evaluate such lengths.
	Use a temporary typespec; don't assign to sym->cl->backend_decl.
	Don't assign to se->string_length when returning a cached array
	descriptor.

From-SVN: r104040
parent 5c9186ce
Showing with 744 additions and 0 deletions
gcc/fortran/ChangeLog
2005-09-08 Richard Sandiford <richard@codesourcery.com>
PR fortran/15326
* trans-array.c (gfc_add_loop_ss_code): Set ss->string_length in
the GFC_SS_FUNCTION case too.
* trans-expr.c (gfc_conv_function_val): Allow symbols to be bound
to function pointers as well as function decls.
(gfc_interface_sym_mapping, gfc_interface_mapping): New structures.
(gfc_init_interface_mapping, gfc_free_interface_mapping)
(gfc_get_interface_mapping_charlen, gfc_get_interface_mapping_array)
(gfc_set_interface_mapping_bounds, gfc_add_interface_mapping)
(gfc_finish_interface_mapping, gfc_apply_interface_mapping_to_cons)
(gfc_apply_interface_mapping_to_ref)
(gfc_apply_interface_mapping_to_expr)
(gfc_apply_interface_mapping): New functions.
(gfc_conv_function_call): Evaluate the arguments before working
out where the result should go. Make the null pointer case provide
the string length in parmse.string_length. Cope with non-constant
string lengths, using the above functions to evaluate such lengths.
Use a temporary typespec; don't assign to sym->cl->backend_decl.
Don't assign to se->string_length when returning a cached array
descriptor.
2005-09-08 Richard Sandiford <richard@codesourcery.com>
PR fortran/19928
* trans-array.c (gfc_conv_array_ref): Call gfc_advance_se_ss_chain
after handling scalarized references. Make "indexse" inherit from
......
gcc/fortran/trans-array.c
......@@ -1233,6 +1233,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
gfc_conv_expr (&se, ss->expr);
gfc_add_block_to_block (&loop->pre, &se.pre);
gfc_add_block_to_block (&loop->post, &se.post);
ss->string_length = se.string_length;
break;
case GFC_SS_CONSTRUCTOR:
......
gcc/testsuite/ChangeLog
2005-09-08 Richard Sandiford <richard@codesourcery.com>
PR fortran/15326
* gfortran.dg/char_result_1.f90,
* gfortran.dg/char_result_2.f90,
* gfortran.dg/char_result_3.f90,
* gfortran.dg/char_result_4.f90,
* gfortran.dg/char_result_5.f90,
* gfortran.dg/char_result_6.f90,
* gfortran.dg/char_result_7.f90,
* gfortran.dg/char_result_8.f90: New tests.
2005-09-08 Richard Sandiford <richard@codesourcery.com>
PR fortran/19928
* gfortran.dg/pr19928-1.f90, gfortran.dg/pr19928-2.f90: New tests.
gcc/testsuite/gfortran.dg/char_result_1.f90 0 → 100644
! Related to PR 15326. Try calling string functions whose lengths depend
! on the lengths of other strings.
! { dg-do run }
pure function double (string)
character (len = *), intent (in) :: string
character (len = len (string) * 2) :: double
double = string // string
end function double
function f1 (string)
character (len = *) :: string
character (len = len (string)) :: f1
f1 = ''
end function f1
function f2 (string1, string2)
character (len = *) :: string1
character (len = len (string1) - 20) :: string2
character (len = len (string1) + len (string2) / 2) :: f2
f2 = ''
end function f2
program main
implicit none
interface
pure function double (string)
character (len = *), intent (in) :: string
character (len = len (string) * 2) :: double
end function double
function f1 (string)
character (len = *) :: string
character (len = len (string)) :: f1
end function f1
function f2 (string1, string2)
character (len = *) :: string1
character (len = len (string1) - 20) :: string2
character (len = len (string1) + len (string2) / 2) :: f2
end function f2
end interface
integer :: a
character (len = 80), target :: text
character (len = 70), pointer :: textp
a = 42
textp => text
call test (f1 (text), 80)
call test (f2 (text, text), 110)
call test (f3 (text), 115)
call test (f4 (text), 192)
call test (f5 (text), 160)
call test (f6 (text), 39)
call test (f1 (textp), 70)
call test (f2 (textp, text), 95)
call test (f3 (textp), 105)
call test (f4 (textp), 192)
call test (f5 (textp), 140)
call test (f6 (textp), 29)
call indirect (textp)
contains
function f3 (string)
integer, parameter :: l1 = 30
character (len = *) :: string
character (len = len (string) + l1 + 5) :: f3
f3 = ''
end function f3
function f4 (string)
character (len = len (text) - 10) :: string
character (len = len (string) + len (text) + a) :: f4
f4 = ''
end function f4
function f5 (string)
character (len = *) :: string
character (len = len (double (string))) :: f5
f5 = ''
end function f5
function f6 (string)
character (len = *) :: string
character (len = len (string (a:))) :: f6
f6 = ''
end function f6
subroutine indirect (text2)
character (len = *) :: text2
call test (f1 (text), 80)
call test (f2 (text, text), 110)
call test (f3 (text), 115)
call test (f4 (text), 192)
call test (f5 (text), 160)
call test (f6 (text), 39)
call test (f1 (text2), 70)
call test (f2 (text2, text2), 95)
call test (f3 (text2), 105)
call test (f4 (text2), 192)
call test (f5 (text2), 140)
call test (f6 (text2), 29)
end subroutine indirect
subroutine test (string, length)
character (len = *) :: string
integer, intent (in) :: length
if (len (string) .ne. length) call abort
end subroutine test
end program main
gcc/testsuite/gfortran.dg/char_result_2.f90 0 → 100644
! Like char_result_1.f90, but the string arguments are pointers.
! { dg-do run }
pure function double (string)
character (len = *), intent (in) :: string
character (len = len (string) * 2) :: double
double = string // string
end function double
function f1 (string)
character (len = *), pointer :: string
character (len = len (string)) :: f1
f1 = ''
end function f1
function f2 (string1, string2)
character (len = *), pointer :: string1
character (len = len (string1) - 20), pointer :: string2
character (len = len (string1) + len (string2) / 2) :: f2
f2 = ''
end function f2
program main
implicit none
interface
pure function double (string)
character (len = *), intent (in) :: string
character (len = len (string) * 2) :: double
end function double
function f1 (string)
character (len = *), pointer :: string
character (len = len (string)) :: f1
end function f1
function f2 (string1, string2)
character (len = *), pointer :: string1
character (len = len (string1) - 20), pointer :: string2
character (len = len (string1) + len (string2) / 2) :: f2
end function f2
end interface
integer :: a
character (len = 80), target :: text
character (len = 70), pointer :: textp
a = 42
textp => text
call test (f1 (textp), 70)
call test (f2 (textp, textp), 95)
call test (f3 (textp), 105)
call test (f4 (textp), 192)
call test (f5 (textp), 140)
call test (f6 (textp), 29)
call indirect (textp)
contains
function f3 (string)
integer, parameter :: l1 = 30
character (len = *), pointer :: string
character (len = len (string) + l1 + 5) :: f3
f3 = ''
end function f3
function f4 (string)
character (len = len (text) - 10), pointer :: string
character (len = len (string) + len (text) + a) :: f4
f4 = ''
end function f4
function f5 (string)
character (len = *), pointer :: string
character (len = len (double (string))) :: f5
f5 = ''
end function f5
function f6 (string)
character (len = *), pointer :: string
character (len = len (string (a:))) :: f6
f6 = ''
end function f6
subroutine indirect (textp2)
character (len = 50), pointer :: textp2
call test (f1 (textp), 70)
call test (f2 (textp, textp), 95)
call test (f3 (textp), 105)
call test (f4 (textp), 192)
call test (f5 (textp), 140)
call test (f6 (textp), 29)
call test (f1 (textp2), 50)
call test (f2 (textp2, textp), 65)
call test (f3 (textp2), 85)
call test (f4 (textp2), 192)
call test (f5 (textp2), 100)
call test (f6 (textp2), 9)
end subroutine indirect
subroutine test (string, length)
character (len = *) :: string
integer, intent (in) :: length
if (len (string) .ne. length) call abort
end subroutine test
end program main
gcc/testsuite/gfortran.dg/char_result_3.f90 0 → 100644
! Related to PR 15326. Try calling string functions whose lengths involve
! some sort of array calculation.
! { dg-do run }
pure elemental function double (x)
integer, intent (in) :: x
integer :: double
double = x * 2
end function double
program main
implicit none
interface
pure elemental function double (x)
integer, intent (in) :: x
integer :: double
end function double
end interface
integer, dimension (100:104), target :: a
integer, dimension (:), pointer :: ap
integer :: i, lower
a = (/ (i + 5, i = 0, 4) /)
ap => a
lower = 11
call test (f1 (a), 35)
call test (f1 (ap), 35)
call test (f1 ((/ 5, 10, 50 /)), 65)
call test (f1 (a (101:103)), 21)
call test (f2 (a), 115)
call test (f2 (ap), 115)
call test (f2 ((/ 5, 10, 50 /)), 119)
call test (f2 (a (101:103)), 116)
call test (f3 (a), 60)
call test (f3 (ap), 60)
call test (f3 ((/ 5, 10, 50 /)), 120)
call test (f3 (a (101:103)), 30)
call test (f4 (a, 13, 1), 21)
call test (f4 (ap, 13, 2), 14)
call test (f4 ((/ 5, 10, 50 /), 12, 1), 60)
call test (f4 (a (101:103), 12, 1), 15)
contains
function f1 (array)
integer, dimension (10:) :: array
character (len = sum (array)) :: f1
f1 = ''
end function f1
function f2 (array)
integer, dimension (10:) :: array
character (len = array (11) + a (104) + 100) :: f2
f2 = ''
end function f2
function f3 (array)
integer, dimension (:) :: array
character (len = sum (double (array (2:)))) :: f3
f3 = ''
end function f3
function f4 (array, upper, stride)
integer, dimension (10:) :: array
integer :: upper, stride
character (len = sum (array (lower:upper:stride))) :: f4
f4 = ''
end function f4
subroutine test (string, length)
character (len = *) :: string
integer, intent (in) :: length
if (len (string) .ne. length) call abort
end subroutine test
end program main
gcc/testsuite/gfortran.dg/char_result_4.f90 0 → 100644
! Like char_result_3.f90, but the array arguments are pointers.
! { dg-do run }
pure elemental function double (x)
integer, intent (in) :: x
integer :: double
double = x * 2
end function double
program main
implicit none
interface
pure elemental function double (x)
integer, intent (in) :: x
integer :: double
end function double
end interface
integer, dimension (100:104), target :: a
integer, dimension (:), pointer :: ap
integer :: i, lower
a = (/ (i + 5, i = 0, 4) /)
ap => a
lower = 1
call test (f1 (ap), 35)
call test (f2 (ap), 115)
call test (f3 (ap), 60)
call test (f4 (ap, 5, 2), 21)
contains
function f1 (array)
integer, dimension (:), pointer :: array
character (len = sum (array)) :: f1
f1 = ''
end function f1
function f2 (array)
integer, dimension (:), pointer :: array
character (len = array (2) + a (104) + 100) :: f2
f2 = ''
end function f2
function f3 (array)
integer, dimension (:), pointer :: array
character (len = sum (double (array (2:)))) :: f3
f3 = ''
end function f3
function f4 (array, upper, stride)
integer, dimension (:), pointer :: array
integer :: upper, stride
character (len = sum (array (lower:upper:stride))) :: f4
f4 = ''
end function f4
subroutine test (string, length)
character (len = *) :: string
integer, intent (in) :: length
if (len (string) .ne. length) call abort
end subroutine test
end program main
gcc/testsuite/gfortran.dg/char_result_5.f90 0 → 100644
! Related to PR 15326. Test calls to string functions whose lengths
! depend on various types of scalar value.
! { dg-do run }
pure function select (selector, iftrue, iffalse)
logical, intent (in) :: selector
integer, intent (in) :: iftrue, iffalse
integer :: select
if (selector) then
select = iftrue
else
select = iffalse
end if
end function select
program main
implicit none
interface
pure function select (selector, iftrue, iffalse)
logical, intent (in) :: selector
integer, intent (in) :: iftrue, iffalse
integer :: select
end function select
end interface
type pair
integer :: left, right
end type pair
integer, target :: i
integer, pointer :: ip
real, target :: r
real, pointer :: rp
logical, target :: l
logical, pointer :: lp
complex, target :: c
complex, pointer :: cp
character, target :: ch
character, pointer :: chp
type (pair), target :: p
type (pair), pointer :: pp
character (len = 10) :: dig
i = 100
r = 50.5
l = .true.
c = (10.9, 11.2)
ch = '1'
p%left = 40
p%right = 50
ip => i
rp => r
lp => l
cp => c
chp => ch
pp => p
dig = '1234567890'
call test (f1 (i), 200)
call test (f1 (ip), 200)
call test (f1 (-30), 60)
call test (f1 (i / (-4)), 50)
call test (f2 (r), 100)
call test (f2 (rp), 100)
call test (f2 (70.1), 140)
call test (f2 (r / 4), 24)
call test (f2 (real (i)), 200)
call test (f3 (l), 50)
call test (f3 (lp), 50)
call test (f3 (.false.), 55)
call test (f3 (i < 30), 55)
call test (f4 (c), 10)
call test (f4 (cp), 10)
call test (f4 (cmplx (60.0, r)), 60)
call test (f4 (cmplx (r, 1.0)), 50)
call test (f5 (ch), 11)
call test (f5 (chp), 11)
call test (f5 ('23'), 12)
call test (f5 (dig (3:)), 13)
call test (f5 (dig (10:)), 10)
call test (f6 (p), 145)
call test (f6 (pp), 145)
call test (f6 (pair (20, 10)), 85)
call test (f6 (pair (i / 2, 1)), 106)
contains
function f1 (i)
integer :: i
character (len = abs (i) * 2) :: f1
f1 = ''
end function f1
function f2 (r)
real :: r
character (len = floor (r) * 2) :: f2
f2 = ''
end function f2
function f3 (l)
logical :: l
character (len = select (l, 50, 55)) :: f3
f3 = ''
end function f3
function f4 (c)
complex :: c
character (len = int (c)) :: f4
f4 = ''
end function f4
function f5 (c)
character :: c
character (len = scan ('123456789', c) + 10) :: f5
f5 = ''
end function f5
function f6 (p)
type (pair) :: p
integer :: i
character (len = sum ((/ p%left, p%right, (i, i = 1, 10) /))) :: f6
f6 = ''
end function f6
subroutine test (string, length)
character (len = *) :: string
integer, intent (in) :: length
if (len (string) .ne. length) call abort
end subroutine test
end program main
gcc/testsuite/gfortran.dg/char_result_6.f90 0 → 100644
! Like char_result_5.f90, but the function arguments are pointers to scalars.
! { dg-do run }
pure function select (selector, iftrue, iffalse)
logical, intent (in) :: selector
integer, intent (in) :: iftrue, iffalse
integer :: select
if (selector) then
select = iftrue
else
select = iffalse
end if
end function select
program main
implicit none
interface
pure function select (selector, iftrue, iffalse)
logical, intent (in) :: selector
integer, intent (in) :: iftrue, iffalse
integer :: select
end function select
end interface
type pair
integer :: left, right
end type pair
integer, target :: i
integer, pointer :: ip
real, target :: r
real, pointer :: rp
logical, target :: l
logical, pointer :: lp
complex, target :: c
complex, pointer :: cp
character, target :: ch
character, pointer :: chp
type (pair), target :: p
type (pair), pointer :: pp
i = 100
r = 50.5
l = .true.
c = (10.9, 11.2)
ch = '1'
p%left = 40
p%right = 50
ip => i
rp => r
lp => l
cp => c
chp => ch
pp => p
call test (f1 (ip), 200)
call test (f2 (rp), 100)
call test (f3 (lp), 50)
call test (f4 (cp), 10)
call test (f5 (chp), 11)
call test (f6 (pp), 145)
contains
function f1 (i)
integer, pointer :: i
character (len = abs (i) * 2) :: f1
f1 = ''
end function f1
function f2 (r)
real, pointer :: r
character (len = floor (r) * 2) :: f2
f2 = ''
end function f2
function f3 (l)
logical, pointer :: l
character (len = select (l, 50, 55)) :: f3
f3 = ''
end function f3
function f4 (c)
complex, pointer :: c
character (len = int (c)) :: f4
f4 = ''
end function f4
function f5 (c)
character, pointer :: c
character (len = scan ('123456789', c) + 10) :: f5
f5 = ''
end function f5
function f6 (p)
type (pair), pointer :: p
integer :: i
character (len = sum ((/ p%left, p%right, (i, i = 1, 10) /))) :: f6
f6 = ''
end function f6
subroutine test (string, length)
character (len = *) :: string
integer, intent (in) :: length
if (len (string) .ne. length) call abort
end subroutine test
end program main
gcc/testsuite/gfortran.dg/char_result_7.f90 0 → 100644
! Related to PR 15326. Try calling string functions whose lengths depend
! on a dummy procedure.
! { dg-do run }
integer pure function double (x)
integer, intent (in) :: x
double = x * 2
end function double
program main
implicit none
interface
integer pure function double (x)
integer, intent (in) :: x
end function double
end interface
call test (f1 (double, 100), 200)
call test (f2 (double, 70), 140)
call indirect (double)
contains
function f1 (fn, i)
integer :: i
interface
integer pure function fn (x)
integer, intent (in) :: x
end function fn
end interface
character (len = fn (i)) :: f1
f1 = ''
end function f1
function f2 (fn, i)
integer :: i, fn
character (len = fn (i)) :: f2
f2 = ''
end function f2
subroutine indirect (fn)
interface
integer pure function fn (x)
integer, intent (in) :: x
end function fn
end interface
call test (f1 (fn, 100), 200)
call test (f2 (fn, 70), 140)
end subroutine indirect
subroutine test (string, length)
character (len = *) :: string
integer, intent (in) :: length
if (len (string) .ne. length) call abort
end subroutine test
end program main
gcc/testsuite/gfortran.dg/char_result_8.f90 0 → 100644
! Related to PR 15326. Compare functions that return string pointers with
! functions that return strings.
! { dg-do run }
program main
implicit none
character (len = 100), target :: string
call test (f1 (), 30)
call test (f2 (50), 50)
call test (f3 (), 30)
call test (f4 (70), 70)
call indirect (100)
contains
function f1
character (len = 30) :: f1
f1 = ''
end function f1
function f2 (i)
integer :: i
character (len = i) :: f2
f2 = ''
end function f2
function f3
character (len = 30), pointer :: f3
f3 => string
end function f3
function f4 (i)
integer :: i
character (len = i), pointer :: f4
f4 => string
end function f4
subroutine indirect (i)
integer :: i
call test (f1 (), 30)
call test (f2 (i), i)
call test (f3 (), 30)
call test (f4 (i), i)
end subroutine indirect
subroutine test (string, length)
character (len = *) :: string
integer, intent (in) :: length
if (len (string) .ne. length) call abort
end subroutine test
end program main
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment