OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fortran: improve check of pointer initialization in DATA statements 

gcc/fortran/ChangeLog:

	PR fortran/77693
	* data.cc (gfc_assign_data_value): If a variable in a data
	statement has the POINTER attribute, check for allowed initial
	data target that is compatible with pointer assignment.
	* gfortran.h (IS_POINTER): New macro.

gcc/testsuite/ChangeLog:

	PR fortran/77693
	* gfortran.dg/data_pointer_2.f90: New test.
This commit is contained in:
Harald Anlauf 2022-02-09 21:54:29 +01:00
parent 1f96b5eeef
commit e49508ac6b
3 changed files with 28 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/fortran/data.cc
View File

@ -618,6 +618,10 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
gfc_convert_type (expr, &lvalue->ts, 0);
}
if (IS_POINTER (symbol)
&& !gfc_check_pointer_assign (lvalue, rvalue, false, true))
return false;
if (last_con == NULL)
symbol->value = expr;
else

3
gcc/fortran/gfortran.h
View File

@ -3897,6 +3897,9 @@ bool gfc_is_finalizable (gfc_symbol *, gfc_expr **);
&& CLASS_DATA (sym) \
&& CLASS_DATA (sym)->attr.dimension \
&& !CLASS_DATA (sym)->attr.class_pointer)
#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)
/* frontend-passes.cc */

21
gcc/testsuite/gfortran.dg/data_pointer_2.f90 Normal file
View File

@ -0,0 +1,21 @@
! { dg-do compile }
! { dg-options "-O -g" }
! PR fortran/77693 - ICE in rtl_for_decl_init
! Contributed by G.Steinmetz
program p
implicit none
complex, target :: y = (1.,2.)
complex, target :: z(2) = (3.,4.)
complex, pointer :: a => y
complex, pointer :: b => z(1)
complex, pointer :: c, d, e
data c /NULL()/ ! Valid
data d /y/ ! Valid
data e /(1.,2.)/ ! { dg-error "Pointer assignment target" }
if (associated (a)) print *, a% re
if (associated (b)) print *, b% im
if (associated (c)) print *, c% re
if (associated (d)) print *, d% im
if (associated (e)) print *, e% re
end