Fortran: allow RESTRICT qualifier also for optional arguments [PR100988]
gcc/fortran/ChangeLog: PR fortran/100988 * gfortran.h (IS_PROC_POINTER): New macro. * trans-types.cc (gfc_sym_type): Use macro in determination if the restrict qualifier can be used for a dummy variable. Fix logic to allow the restrict qualifier also for optional arguments, and to not apply it to pointer or proc_pointer arguments. gcc/testsuite/ChangeLog: PR fortran/100988 * gfortran.dg/coarray_poly_6.f90: Adjust pattern. * gfortran.dg/coarray_poly_7.f90: Likewise. * gfortran.dg/coarray_poly_8.f90: Likewise. * gfortran.dg/missing_optional_dummy_6a.f90: Likewise. * gfortran.dg/pr100988.f90: New test. Co-authored-by: Tobias Burnus <tobias@codesourcery.com>
This commit is contained in:
Harald Anlauf
parent
1dad3df1e7
commit
9c3a880fee
7 changed files with 74 additions and 11 deletions
|
|
@ -4008,6 +4008,9 @@ bool gfc_may_be_finalized (gfc_typespec);
|
|||
#define IS_POINTER(sym) \
|
||||
(sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \
|
||||
? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer)
|
||||
#define IS_PROC_POINTER(sym) \
|
||||
(sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \
|
||||
? CLASS_DATA (sym)->attr.proc_pointer : sym->attr.proc_pointer)
|
||||
|
||||
/* frontend-passes.cc */
|
||||
|
||||
|
|
|
|||
|
|
@ -2327,8 +2327,8 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
|
|||
else
|
||||
byref = 0;
|
||||
|
||||
restricted = !sym->attr.target && !sym->attr.pointer
|
||||
&& !sym->attr.proc_pointer && !sym->attr.cray_pointee;
|
||||
restricted = (!sym->attr.target && !IS_POINTER (sym)
|
||||
&& !IS_PROC_POINTER (sym) && !sym->attr.cray_pointee);
|
||||
if (!restricted)
|
||||
type = gfc_nonrestricted_type (type);
|
||||
|
||||
|
|
@ -2384,11 +2384,10 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
|
|||
|| (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
|
||||
type = build_pointer_type (type);
|
||||
else
|
||||
{
|
||||
type = build_reference_type (type);
|
||||
if (restricted)
|
||||
type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
|
||||
}
|
||||
type = build_reference_type (type);
|
||||
|
||||
if (restricted)
|
||||
type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
|
||||
}
|
||||
|
||||
return (type);
|
||||
|
|
|
|||
|
|
@ -16,6 +16,6 @@ contains
|
|||
end subroutine foo
|
||||
end
|
||||
! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_0_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_0_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_0_1t \\* restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } }
|
||||
|
|
|
|||
|
|
@ -16,6 +16,6 @@ contains
|
|||
end subroutine foo
|
||||
end
|
||||
! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } }
|
||||
|
|
|
|||
|
|
@ -16,6 +16,6 @@ contains
|
|||
end subroutine foo
|
||||
end
|
||||
! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } }
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ contains
|
|||
|
||||
end program test
|
||||
|
||||
! { dg-final { scan-tree-dump-times "scalar2 \\(slr1" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "scalar2 \\(.* slr1" 1 "original" } }
|
||||
|
||||
! { dg-final { scan-tree-dump-times "= es1 != 0B" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } }
|
||||
|
|
|
|||
61
gcc/testsuite/gfortran.dg/pr100988.f90
Normal file
61
gcc/testsuite/gfortran.dg/pr100988.f90
Normal file
|
|
@ -0,0 +1,61 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "-fdump-tree-original" }
|
||||
! PR fortran/100988 - RESTRICT was missing for optional arguments
|
||||
|
||||
! There should be restrict qualifiers for a AND b: (4 cases)
|
||||
subroutine plain (a, b)
|
||||
integer :: a, b
|
||||
optional :: b
|
||||
end subroutine
|
||||
|
||||
subroutine alloc (a, b)
|
||||
integer :: a, b
|
||||
allocatable :: a, b
|
||||
optional :: b
|
||||
end subroutine
|
||||
|
||||
subroutine upoly (a, b)
|
||||
class(*) :: a, b
|
||||
optional :: b
|
||||
end subroutine
|
||||
|
||||
subroutine upoly_a (a, b)
|
||||
class(*) :: a, b
|
||||
allocatable :: a, b
|
||||
optional :: b
|
||||
end subroutine
|
||||
|
||||
! { dg-final { scan-tree-dump "plain .* restrict a, .* restrict b\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "alloc .* restrict a, .* restrict b\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "upoly .* restrict a, .* restrict b\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "upoly_a .* restrict a, .* restrict b\\)" "original" } }
|
||||
|
||||
! There should be no restrict qualifiers for the below 4 cases:
|
||||
subroutine ptr (a, b)
|
||||
integer :: a, b
|
||||
pointer :: a, b
|
||||
optional :: b
|
||||
end subroutine
|
||||
|
||||
subroutine tgt (a, b)
|
||||
integer :: a, b
|
||||
target :: a, b
|
||||
optional :: b
|
||||
end subroutine
|
||||
|
||||
subroutine upoly_p (a, b)
|
||||
class(*) :: a, b
|
||||
pointer :: a, b
|
||||
optional :: b
|
||||
end subroutine
|
||||
|
||||
subroutine upoly_t (a, b)
|
||||
class(*) :: a, b
|
||||
target :: a, b
|
||||
optional :: b
|
||||
end subroutine
|
||||
|
||||
! { dg-final { scan-tree-dump-not "ptr .* restrict " "original" } }
|
||||
! { dg-final { scan-tree-dump-not "tgt .* restrict " "original" } }
|
||||
! { dg-final { scan-tree-dump-not "upoly_p .* restrict " "original" } }
|
||||
! { dg-final { scan-tree-dump-not "upoly_t .* restrict " "original" } }
|
||||
Loading…
Add table
Reference in a new issue