From: Harald Anlauf <anlauf@gmx.de>
To: Mikael Morin <morin-mikael@orange.fr>,
sgk@troutmask.apl.washington.edu,
Harald Anlauf via Fortran <fortran@gcc.gnu.org>
Cc: gcc-patches <gcc-patches@gcc.gnu.org>, tobias@codesourcery.com
Subject: Re: [PATCH, v2] Fortran: fix CLASS attribute handling [PR106856]
Date: Sat, 4 Mar 2023 17:06:22 +0100 [thread overview]
Message-ID: <a63549e1-80ba-96ab-d04a-808fd4195f3e@gmx.de> (raw)
In-Reply-To: <48caf060-4349-b077-24da-8bf53ed4b650@gmx.de>
[-- Attachment #1: Type: text/plain, Size: 475 bytes --]
Sorry, attached the wrong patch.
Here's the correct one.
Harald
Am 04.03.23 um 17:02 schrieb Harald Anlauf via Gcc-patches:
> The attached revised version uses the above proven changes,
> and extends the new testcase class_74.f90 by variations of
> the failures remaining with version 1 so that different
> codepaths are tested.
>
> Regtested again on x86_64-pc-linux-gnu.
>
> Any further comments?
>
> Thanks for your very helpful review!
>
> Harald
[-- Attachment #2: pr106856-v2.diff --]
[-- Type: text/x-patch, Size: 11992 bytes --]
From 0b7e9ea9c83ca6d6c0aae638be09fbcb8e42c682 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Thu, 2 Mar 2023 22:37:14 +0100
Subject: [PATCH] Fortran: fix CLASS attribute handling [PR106856]
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.
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>
---
gcc/fortran/class.cc | 25 +++-
gcc/fortran/decl.cc | 60 +++++-----
gcc/fortran/primary.cc | 1 -
gcc/testsuite/gfortran.dg/class_74.f90 | 130 +++++++++++++++++++++
gcc/testsuite/gfortran.dg/class_75.f90 | 24 ++++
gcc/testsuite/gfortran.dg/interface_41.f90 | 2 +-
6 files changed, 207 insertions(+), 35 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/class_74.f90
create mode 100644 gcc/testsuite/gfortran.dg/class_75.f90
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index ae653e74437..52235ab83e3 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -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, ©);
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
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index eec0314cf4c..a65c6dcb994 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -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, ¤t_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, ¤t_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, ¤t_attr, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
}
-
if (!gfc_set_array_spec (sym, as, &var_locus))
{
m = MATCH_ERROR;
@@ -8807,6 +8785,28 @@ 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;
+ }
+ else if (sym->ts.type == BT_CLASS
+ && sym->ts.u.derived->attr.is_class
+ && sym->old_symbol && sym->old_symbol->as == CLASS_DATA (sym)->as)
+ sym->old_symbol->as = NULL;
+
add_hidden_procptr_result (sym);
return MATCH_YES;
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 1bea17d44fe..00d35a71770 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -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
{
diff --git a/gcc/testsuite/gfortran.dg/class_74.f90 b/gcc/testsuite/gfortran.dg/class_74.f90
new file mode 100644
index 00000000000..a22a3d9f739
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_74.f90
@@ -0,0 +1,130 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/class_75.f90 b/gcc/testsuite/gfortran.dg/class_75.f90
new file mode 100644
index 00000000000..eb29ad51c85
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_75.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/interface_41.f90 b/gcc/testsuite/gfortran.dg/interface_41.f90
index b5ea8af189d..2fec01e3cf9 100644
--- a/gcc/testsuite/gfortran.dg/interface_41.f90
+++ b/gcc/testsuite/gfortran.dg/interface_41.f90
@@ -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
--
2.35.3
WARNING: multiple messages have this Message-ID
From: Harald Anlauf <anlauf@gmx.de>
To: gcc-patches@gcc.gnu.org
Cc: fortran@gcc.gnu.org
Subject: Re: [PATCH, v2] Fortran: fix CLASS attribute handling [PR106856]
Date: Sat, 4 Mar 2023 17:06:22 +0100 [thread overview]
Message-ID: <a63549e1-80ba-96ab-d04a-808fd4195f3e@gmx.de> (raw)
Message-ID: <20230304160622.cGtNOUV0T5QPgqn5YJfK0pQhaD71HO2bs1LKDx0FrVM@z> (raw)
In-Reply-To: <48caf060-4349-b077-24da-8bf53ed4b650@gmx.de>
[-- Attachment #1: Type: text/plain, Size: 459 bytes --]
Sorry, attached the wrong patch.
Here's the correct one.
Harald
Am 04.03.23 um 17:02 schrieb Harald Anlauf via Gcc-patches:
> The attached revised version uses the above proven changes,
> and extends the new testcase class_74.f90 by variations of
> the failures remaining with version 1 so that different
> codepaths are tested.
>
> Regtested again on x86_64-pc-linux-gnu.
>
> Any further comments?
>
> Thanks for your very helpful review!
>
> Harald
[-- Attachment #2: pr106856-v2.diff --]
[-- Type: text/x-patch, Size: 11992 bytes --]
From 0b7e9ea9c83ca6d6c0aae638be09fbcb8e42c682 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Thu, 2 Mar 2023 22:37:14 +0100
Subject: [PATCH] Fortran: fix CLASS attribute handling [PR106856]
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.
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>
---
gcc/fortran/class.cc | 25 +++-
gcc/fortran/decl.cc | 60 +++++-----
gcc/fortran/primary.cc | 1 -
gcc/testsuite/gfortran.dg/class_74.f90 | 130 +++++++++++++++++++++
gcc/testsuite/gfortran.dg/class_75.f90 | 24 ++++
gcc/testsuite/gfortran.dg/interface_41.f90 | 2 +-
6 files changed, 207 insertions(+), 35 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/class_74.f90
create mode 100644 gcc/testsuite/gfortran.dg/class_75.f90
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index ae653e74437..52235ab83e3 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -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, ©);
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
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index eec0314cf4c..a65c6dcb994 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -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, ¤t_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, ¤t_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, ¤t_attr, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
}
-
if (!gfc_set_array_spec (sym, as, &var_locus))
{
m = MATCH_ERROR;
@@ -8807,6 +8785,28 @@ 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;
+ }
+ else if (sym->ts.type == BT_CLASS
+ && sym->ts.u.derived->attr.is_class
+ && sym->old_symbol && sym->old_symbol->as == CLASS_DATA (sym)->as)
+ sym->old_symbol->as = NULL;
+
add_hidden_procptr_result (sym);
return MATCH_YES;
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 1bea17d44fe..00d35a71770 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -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
{
diff --git a/gcc/testsuite/gfortran.dg/class_74.f90 b/gcc/testsuite/gfortran.dg/class_74.f90
new file mode 100644
index 00000000000..a22a3d9f739
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_74.f90
@@ -0,0 +1,130 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/class_75.f90 b/gcc/testsuite/gfortran.dg/class_75.f90
new file mode 100644
index 00000000000..eb29ad51c85
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_75.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/interface_41.f90 b/gcc/testsuite/gfortran.dg/interface_41.f90
index b5ea8af189d..2fec01e3cf9 100644
--- a/gcc/testsuite/gfortran.dg/interface_41.f90
+++ b/gcc/testsuite/gfortran.dg/interface_41.f90
@@ -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
--
2.35.3
next prev parent reply other threads:[~2023-03-04 16:06 UTC|newest]
Thread overview: 18+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-03-02 22:03 [PATCH] " Harald Anlauf
2023-03-03 19:57 ` Steve Kargl
2023-03-03 21:17 ` Harald Anlauf
2023-03-03 21:17 ` Harald Anlauf
2023-03-03 21:24 ` Mikael Morin
2023-03-03 22:18 ` Steve Kargl
2023-03-04 13:56 ` Mikael Morin
2023-03-04 16:02 ` [PATCH, v2] " Harald Anlauf
2023-03-04 16:02 ` Harald Anlauf
2023-03-04 16:02 ` Harald Anlauf
2023-03-04 16:06 ` Harald Anlauf [this message]
2023-03-04 16:06 ` Harald Anlauf
2023-03-04 17:09 ` Mikael Morin
2023-03-04 21:20 ` Harald Anlauf
2023-03-04 21:20 ` Harald Anlauf
2023-03-04 22:29 ` Mikael Morin
2023-03-05 20:21 ` [PATCH, v3] " Harald Anlauf
2023-03-05 20:21 ` Harald Anlauf
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=a63549e1-80ba-96ab-d04a-808fd4195f3e@gmx.de \
--to=anlauf@gmx.de \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
--cc=morin-mikael@orange.fr \
--cc=sgk@troutmask.apl.washington.edu \
--cc=tobias@codesourcery.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).