Fortran] PR91640 – Fix call to contiguous dummy
PR fortran/91640 * trans-expr.c (gfc_conv_procedure_call): Avoid copy-out for nonvariable arguments to contiguous dummy args. Avoid re-checking whether fsym is NULL. PR fortran/91640 * gfortran.dg/contiguous_10.f90: New. From-SVN: r279879
This commit is contained in:
parent
c0c4eaae49
commit
9b9623194b
@ -1,3 +1,10 @@
|
||||
2020-01-04 Tobias Burnus <tobias@codesourcery.com>
|
||||
|
||||
PR fortran/91640
|
||||
* trans-expr.c (gfc_conv_procedure_call): Avoid copy-out for nonvariable
|
||||
arguments to contiguous dummy args. Avoid re-checking whether fsym is
|
||||
NULL.
|
||||
|
||||
2020-01-03 Tobias Burnus <tobias@codesourcery.com>
|
||||
|
||||
* trans-openmp.c (gfc_omp_check_optional_argument): Always return a
|
||||
|
@ -6178,7 +6178,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
|
||||
fsym && fsym->attr.pointer);
|
||||
|
||||
else if (gfc_is_class_array_ref (e, NULL)
|
||||
&& fsym && fsym->ts.type == BT_DERIVED)
|
||||
&& fsym && fsym->ts.type == BT_DERIVED)
|
||||
/* The actual argument is a component reference to an
|
||||
array of derived types. In this case, the argument
|
||||
is converted to a temporary, which is passed and then
|
||||
@ -6187,26 +6187,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
|
||||
the same as the declared type, copy-in/copy-out does
|
||||
not occur. */
|
||||
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
|
||||
fsym ? fsym->attr.intent : INTENT_INOUT,
|
||||
fsym && fsym->attr.pointer);
|
||||
fsym->attr.intent,
|
||||
fsym->attr.pointer);
|
||||
|
||||
else if (gfc_is_class_array_function (e)
|
||||
&& fsym && fsym->ts.type == BT_DERIVED)
|
||||
&& fsym && fsym->ts.type == BT_DERIVED)
|
||||
/* See previous comment. For function actual argument,
|
||||
the write out is not needed so the intent is set as
|
||||
intent in. */
|
||||
{
|
||||
e->must_finalize = 1;
|
||||
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
|
||||
INTENT_IN,
|
||||
fsym && fsym->attr.pointer);
|
||||
INTENT_IN, fsym->attr.pointer);
|
||||
}
|
||||
else if (fsym && fsym->attr.contiguous
|
||||
&& !gfc_is_simply_contiguous (e, false, true))
|
||||
&& !gfc_is_simply_contiguous (e, false, true)
|
||||
&& gfc_expr_is_variable (e))
|
||||
{
|
||||
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
|
||||
fsym ? fsym->attr.intent : INTENT_INOUT,
|
||||
fsym && fsym->attr.pointer);
|
||||
fsym->attr.intent,
|
||||
fsym->attr.pointer);
|
||||
}
|
||||
else
|
||||
gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
|
||||
|
@ -1,3 +1,8 @@
|
||||
2020-01-04 Tobias Burnus <tobias@codesourcery.com>
|
||||
|
||||
PR fortran/91640
|
||||
* gfortran.dg/contiguous_10.f90: New.
|
||||
|
||||
2020-01-03 Iain Sandoe <iain@sandoe.co.uk>
|
||||
|
||||
* gcc.target/i386/avx512bw-pr92686-vpcmp-intelasm-1.c: Require
|
||||
|
69
gcc/testsuite/gfortran.dg/contiguous_10.f90
Normal file
69
gcc/testsuite/gfortran.dg/contiguous_10.f90
Normal file
@ -0,0 +1,69 @@
|
||||
! { dg-do run }
|
||||
! { dg-additional-options "-fdump-tree-original" }
|
||||
!
|
||||
! PR fortran/91640
|
||||
!
|
||||
! Based on G. Steinmetz's test case
|
||||
!
|
||||
program p
|
||||
implicit none (type, external)
|
||||
real, target :: z(3) = 1.0
|
||||
real :: res(3)
|
||||
real, pointer :: xxx(:)
|
||||
|
||||
res = 42.0
|
||||
call sub (-z, res)
|
||||
if (any (abs (res - (-1.0)) > epsilon(res))) stop 1
|
||||
if (any (abs (z - 1.0) > epsilon(z))) stop 2
|
||||
|
||||
res = 43.0
|
||||
call sub (z*2.0, res)
|
||||
if (any (abs (res - 2.0) > epsilon(res))) stop 3
|
||||
if (any (abs (z - 1.0) > epsilon(z))) stop 4
|
||||
|
||||
res = 44.0
|
||||
call sub(get_var(), res)
|
||||
if (any (abs (res - 1.0) > epsilon(res))) stop 5
|
||||
if (any (abs (z - 1.0) > epsilon(z))) stop 6
|
||||
|
||||
call double(get_var())
|
||||
if (any (abs (z - 2.0) > epsilon(z))) stop 7
|
||||
|
||||
call double(get_var_cont())
|
||||
if (any (abs (z - 4.0) > epsilon(z))) stop 8
|
||||
|
||||
! For cross check for copy-out:
|
||||
xxx => z
|
||||
if (any (abs (z - 4.0) > epsilon(z))) stop 10
|
||||
if (any (abs (xxx - 4.0) > epsilon(z))) stop 11
|
||||
call double (xxx)
|
||||
if (any (abs (z - 8.0) > epsilon(z))) stop 12
|
||||
if (any (abs (xxx - 8.0) > epsilon(z))) stop 13
|
||||
|
||||
contains
|
||||
subroutine sub (x, res)
|
||||
real, contiguous :: x(:)
|
||||
real :: res(3)
|
||||
res = x
|
||||
end
|
||||
subroutine double (x)
|
||||
real, contiguous :: x(:)
|
||||
x = x * 2.0
|
||||
end
|
||||
function get_var()
|
||||
real, pointer :: get_var(:)
|
||||
get_var => z
|
||||
end
|
||||
function get_var_cont()
|
||||
real, pointer, contiguous :: get_var_cont(:)
|
||||
get_var_cont => z
|
||||
end
|
||||
end
|
||||
|
||||
! only 'xxx' should have a copy out:
|
||||
! { dg-final { scan-tree-dump-times "D\\.\[0-9\].* = .*atmp\\.\[0-9\]*\\.data" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "D\\.\[0-9\].*xxx\\.span.* = .*atmp\\.\[0-9\]*\\.data" 1 "original" } }
|
||||
|
||||
! Only once 'z... = ' – for: static real(kind=4) z[3] = {[0 ... 2]=1.0e+0};
|
||||
! but don't match '(si)ze'
|
||||
! { dg-final { scan-tree-dump-times "z\[^e\].* = " 1 "original" } }
|
Loading…
Reference in New Issue
Block a user