procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: fix CLASS attribute handling [PR106856]

Browse source 
gcc/fortran/ChangeLog:

	PR fortran/106856
	* class.cc (gfc_build_class_symbol): Handle update of attributes of
	existing class container.
	(gfc_find_derived_vtab): Fix several memory leaks.
	(find_intrinsic_vtab): Ditto.
	* decl.cc (attr_decl1): Manage update of symbol attributes from
	CLASS attributes.
	* primary.cc (gfc_variable_attr): OPTIONAL shall not be taken or
	updated from the class container.
	* symbol.cc (free_old_symbol): Adjust management of symbol versions
	to not prematurely free array specs while working on the declation
	of CLASS variables.

gcc/testsuite/ChangeLog:

	PR fortran/106856
	* gfortran.dg/interface_41.f90: Remove dg-pattern from valid testcase.
	* gfortran.dg/class_74.f90: New test.
	* gfortran.dg/class_75.f90: New test.

Co-authored-by: Tobias Burnus  <tobias@codesourcery.com>
This commit is contained in:
Harald Anlauf 2023-03-02 22:37:14 +01:00
parent ca27d765f1
commit 6aa1f40a32
7 changed files with 229 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
gcc/fortran/class.cc
View file

@ -638,6 +638,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
{
char tname[GFC_MAX_SYMBOL_LEN+1];
char *name;
gfc_typespec *orig_ts = ts;
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
@ -646,9 +647,21 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gcc_assert (as);
if (attr->class_ok)
/* Class container has already been built. */
/* Class container has already been built with same name. */
if (attr->class_ok
&& ts->u.derived->components->attr.dimension >= attr->dimension
&& ts->u.derived->components->attr.codimension >= attr->codimension
&& ts->u.derived->components->attr.class_pointer >= attr->pointer
&& ts->u.derived->components->attr.allocatable >= attr->allocatable)
return true;
if (attr->class_ok)
{
attr->dimension |= ts->u.derived->components->attr.dimension;
attr->codimension |= ts->u.derived->components->attr.codimension;
attr->pointer |= ts->u.derived->components->attr.class_pointer;
attr->allocatable |= ts->u.derived->components->attr.allocatable;
ts = &ts->u.derived->components->ts;
}
attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
|| attr->select_type_temporary || attr->associate_var;
@ -790,7 +803,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
}
fclass->attr.is_class = 1;
ts->u.derived = fclass;
orig_ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
(*as) = NULL;
free (name);
@ -2344,6 +2357,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
free (name);
name = xasprintf ("__vtype_%s", tname);
gfc_find_symbol (name, ns, 0, &vtype);
@ -2447,6 +2461,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
else
{
/* Construct default initialization variable. */
free (name);
name = xasprintf ("__def_init_%s", tname);
gfc_get_symbol (name, ns, &def_init);
def_init->attr.target = 1;
@ -2480,6 +2495,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
free (name);
name = xasprintf ("__copy_%s", tname);
gfc_get_symbol (name, sub_ns, &copy);
sub_ns->proc_name = copy;
@ -2558,6 +2574,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
free (name);
name = xasprintf ("__deallocate_%s", tname);
gfc_get_symbol (name, sub_ns, &dealloc);
sub_ns->proc_name = dealloc;
@ -2723,6 +2740,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
free (name);
name = xasprintf ("__vtype_%s", tname);
gfc_find_symbol (name, ns, 0, &vtype);
@ -2801,6 +2819,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1;
free (name);
if (ts->type != BT_CHARACTER)
name = xasprintf ("__copy_%s", tname);
else

56
gcc/fortran/decl.cc
View file

@ -8740,45 +8740,23 @@ attr_decl1 (void)
}
}
/* Update symbol table. DIMENSION attribute is set in
gfc_set_array_spec(). For CLASS variables, this must be applied
to the first component, or '_data' field. */
if (sym->ts.type == BT_CLASS
&& sym->ts.u.derived
&& sym->ts.u.derived->attr.is_class)
{
/* gfc_set_array_spec sets sym->attr not CLASS_DATA(sym)->attr. Check
for duplicate attribute here. */
if (CLASS_DATA(sym)->attr.dimension == 1 && as)
{
gfc_error ("Duplicate DIMENSION attribute at %C");
m = MATCH_ERROR;
goto cleanup;
}
if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, &current_attr, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
}
sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer;
sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable;
sym->attr.dimension = CLASS_DATA(sym)->attr.dimension;
sym->attr.codimension = CLASS_DATA(sym)->attr.codimension;
if (CLASS_DATA (sym)->as)
sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
}
else
{
if (current_attr.dimension == 0 && current_attr.codimension == 0
&& !gfc_copy_attr (&sym->attr, &current_attr, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
}
}
if (sym->ts.type == BT_CLASS
&& !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
if (current_attr.dimension == 0 && current_attr.codimension == 0
&& !gfc_copy_attr (&sym->attr, &current_attr, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
}
if (!gfc_set_array_spec (sym, as, &var_locus))
{
m = MATCH_ERROR;
@ -8807,6 +8785,24 @@ attr_decl1 (void)
goto cleanup;
}
if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class
&& !as && !current_attr.pointer && !current_attr.allocatable
&& !current_attr.external)
{
sym->attr.pointer = 0;
sym->attr.allocatable = 0;
sym->attr.dimension = 0;
sym->attr.codimension = 0;
gfc_free_array_spec (sym->as);
sym->as = NULL;
}
else if (sym->ts.type == BT_CLASS
&& !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
{
m = MATCH_ERROR;
goto cleanup;
}
add_hidden_procptr_result (sym);
return MATCH_YES;

1
gcc/fortran/primary.cc
View file

@ -2640,7 +2640,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
codimension = CLASS_DATA (sym)->attr.codimension;
pointer = CLASS_DATA (sym)->attr.class_pointer;
allocatable = CLASS_DATA (sym)->attr.allocatable;
optional |= CLASS_DATA (sym)->attr.optional;
}
else
{

6
gcc/fortran/symbol.cc
View file

@ -3761,7 +3761,11 @@ free_old_symbol (gfc_symbol *sym)
if (sym->old_symbol == NULL)
return;
if (sym->old_symbol->as != sym->as)
if (sym->old_symbol->as != NULL
&& sym->old_symbol->as != sym->as
&& !(sym->ts.type == BT_CLASS
&& sym->ts.u.derived->attr.is_class
&& sym->old_symbol->as == CLASS_DATA (sym)->as))
gfc_free_array_spec (sym->old_symbol->as);
if (sym->old_symbol->value != sym->value)

151
gcc/testsuite/gfortran.dg/class_74.f90 Normal file
View file

@ -0,0 +1,151 @@
! { dg-do compile }
! { dg-additional-options "-fcoarray=single" }
!
! PR fortran/106856
!
! Contributed by G. Steinmetz
!
subroutine foo
interface
subroutine bar(x)
type(*) :: x
end subroutine bar
end interface
class(*) :: x, y
allocatable :: x
dimension :: x(:), y(:,:)
codimension :: x[:]
pointer :: y
y => null()
if (allocated(x)) then
call bar(x(2)[1])
end if
if (associated(y)) then
call bar(y(2,2))
end if
end subroutine foo
program p
class(*), allocatable :: x, y
y = 'abc'
call s1(x, y)
contains
subroutine s1(x, y)
class(*) :: x, y
end
subroutine s2(x, y)
class(*), allocatable :: x, y
optional :: x
end
end
subroutine s1 (x)
class(*) :: x
allocatable :: x
dimension :: x(:)
if (allocated (x)) print *, size (x)
end
subroutine s2 (x)
class(*) :: x
allocatable :: x(:)
if (allocated (x)) print *, size (x)
end
subroutine s3 (x)
class(*) :: x(:)
allocatable :: x
if (allocated (x)) print *, size (x)
end
subroutine s4 (x)
class(*) :: x
dimension :: x(:)
allocatable :: x
if (allocated (x)) print *, size (x)
end
subroutine c0 (x)
class(*) :: x
allocatable :: x
codimension :: x[:]
dimension :: x(:)
if (allocated (x)) print *, size (x)
end
subroutine c1 (x)
class(*) :: x(:)
allocatable :: x[:]
if (allocated (x)) print *, size (x)
end
subroutine c2 (x)
class(*) :: x[:]
allocatable :: x(:)
if (allocated (x)) print *, size (x)
end
subroutine c3 (x)
class(*) :: x(:)[:]
allocatable :: x
if (allocated (x)) print *, size (x)
end
subroutine c4 (x)
class(*) :: x
dimension :: x(:)
codimension :: x[:]
allocatable :: x
if (allocated (x)) print *, size (x)
end
subroutine p1 (x)
class(*) :: x
pointer :: x
dimension :: x(:)
if (associated (x)) print *, size (x)
end
subroutine p2 (x)
class(*) :: x
pointer :: x(:)
if (associated (x)) print *, size (x)
end
subroutine p3 (x)
class(*) :: x(:)
pointer :: x
if (associated (x)) print *, size (x)
end
subroutine p4 (x)
class(*) :: x
dimension :: x(:)
pointer :: x
if (associated (x)) print *, size (x)
end
! Testcase by Mikael Morin
subroutine mm ()
pointer :: y
dimension :: y(:,:)
class(*) :: y
if (associated (y)) print *, size (y)
end
! Testcase from pr53951
subroutine pr53951 ()
type t
end type t
class(t), pointer :: C
TARGET :: A
class(t), allocatable :: A, B
TARGET :: B
C => A ! Valid
C => B ! Valid, but was rejected
end

24
gcc/testsuite/gfortran.dg/class_75.f90 Normal file
View file

@ -0,0 +1,24 @@
! { dg-do compile }
! { dg-additional-options "-fcoarray=single" }
!
! PR fortran/106856
!
!
!
subroutine foo(x,y)
class(*), optional :: x, y
optional :: x ! { dg-error "Duplicate OPTIONAL attribute" }
target :: x
allocatable :: x
target :: x ! { dg-error "Duplicate TARGET attribute" }
allocatable :: x ! { dg-error "Duplicate ALLOCATABLE attribute" }
pointer :: y
contiguous :: y
pointer :: y ! { dg-error "Duplicate POINTER attribute" }
contiguous :: y ! { dg-error "Duplicate CONTIGUOUS attribute" }
codimension :: x[:]
dimension :: x(:,:)
dimension :: y(:,:,:)
codimension :: x[:] ! { dg-error "Duplicate CODIMENSION attribute" }
dimension :: y(:) ! { dg-error "Duplicate DIMENSION attribute" }
end

2
gcc/testsuite/gfortran.dg/interface_41.f90
View file

@ -14,6 +14,6 @@ contains
subroutine s
type(t) :: x(2)
real :: z
z = f(x) ! { dg-error "Rank mismatch in argument" }
z = f(x)
end
end