aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog16
-rw-r--r--gcc/fortran/check.c10
-rw-r--r--gcc/fortran/class.c4
-rw-r--r--gcc/fortran/trans-types.c14
-rw-r--r--gcc/testsuite/ChangeLog10
-rw-r--r--gcc/testsuite/gfortran.dg/pr66465.f9023
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_47.f9037
7 files changed, 110 insertions, 4 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index fc3afba..ce3d7d0 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2015-11-08 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/68196
+ * class.c (has_finalizer_component): Prevent infinite recursion
+ through this function if the derived type and that of its
+ component are the same.
+ * trans-types.c (gfc_get_derived_type): Do the same for proc
+ pointers by ignoring the explicit interface for the component.
+
+ PR fortran/66465
+ * check.c (same_type_check): If either of the expressions is
+ BT_PROCEDURE, use the typespec from the symbol, rather than the
+ expression.
+
2015-11-07 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/68153
@@ -111,7 +125,7 @@
PR fortran/68154
* decl.c (add_init_expr_to_sym): if the char length in the typespec
- is NULL, check for and use a constructor.
+ is NULL, check for and use a constructor.
2015-10-30 Steven G. Kargl <kargl@gcc.gnu.org>
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 86dae5b..038ee21 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -399,7 +399,15 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
static bool
same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
{
- if (gfc_compare_types (&e->ts, &f->ts))
+ gfc_typespec *ets = &e->ts;
+ gfc_typespec *fts = &f->ts;
+
+ if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
+ ets = &e->symtree->n.sym->ts;
+ if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
+ fts = &f->symtree->n.sym->ts;
+
+ if (gfc_compare_types (ets, fts))
return true;
gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 7a9e275..8b49ae9 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -843,7 +843,11 @@ has_finalizer_component (gfc_symbol *derived)
&& c->ts.u.derived->f2k_derived->finalizers)
return true;
+ /* Stop infinite recursion through this function by inhibiting
+ calls when the derived type and that of the component are
+ the same. */
if (c->ts.type == BT_DERIVED
+ && !gfc_compare_derived_types (derived, c->ts.u.derived)
&& !c->attr.pointer && !c->attr.allocatable
&& has_finalizer_component (c->ts.u.derived))
return true;
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 780200e..ad6cee8 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2366,6 +2366,7 @@ gfc_get_derived_type (gfc_symbol * derived)
gfc_component *c;
gfc_dt_list *dt;
gfc_namespace *ns;
+ tree tmp;
if (derived->attr.unlimited_polymorphic
|| (flag_coarray == GFC_FCOARRAY_LIB
@@ -2517,8 +2518,19 @@ gfc_get_derived_type (gfc_symbol * derived)
node as DECL_CONTEXT of each FIELD_DECL. */
for (c = derived->components; c; c = c->next)
{
- if (c->attr.proc_pointer)
+ /* Prevent infinite recursion, when the procedure pointer type is
+ the same as derived, by forcing the procedure pointer component to
+ be built as if the explicit interface does not exist. */
+ if (c->attr.proc_pointer
+ && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
+ || (c->ts.u.derived
+ && !gfc_compare_derived_types (derived, c->ts.u.derived))))
field_type = gfc_get_ppc_type (c);
+ else if (c->attr.proc_pointer && derived->backend_decl)
+ {
+ tmp = build_function_type_list (derived->backend_decl, NULL_TREE);
+ field_type = build_pointer_type (tmp);
+ }
else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
field_type = c->ts.u.derived->backend_decl;
else
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7cc0ac9..2801c94 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2015-11-08 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/68196
+ * gfortran.dg/proc_ptr_47.f90: New test.
+
+ PR fortran/66465
+ * gfortran.dg/pr66465.f90: New test.
+
2015-11-07 John David Anglin <danglin@gcc.gnu.org>
* gcc.dg/Wno-frame-address.c: Skip on hppa*-*-*.
@@ -36,7 +44,7 @@
2015-11-06 Dominique d'Humieres <dominiq@lps.ens.fr>
PR fortran/54224
- * gfortran.dg/warn_unused_function_2.f90: Add two new
+ * gfortran.dg/warn_unused_function_2.f90: Add two new
"defined but not used" subroutines.
2015-11-06 Jakub Jelinek <jakub@redhat.com>
diff --git a/gcc/testsuite/gfortran.dg/pr66465.f90 b/gcc/testsuite/gfortran.dg/pr66465.f90
new file mode 100644
index 0000000..ab86830
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr66465.f90
@@ -0,0 +1,23 @@
+! { dg-do compile }
+!
+! Tests the fix for PR66465, in which the arguments of the call to
+! ASSOCIATED were falsly detected to have different type/kind.
+!
+! Contributed by Damian Rouson <damian@sourceryinstitute.org>
+!
+ interface
+ real function HandlerInterface (arg)
+ real :: arg
+ end
+ end interface
+
+ type TextHandlerTestCase
+ procedure (HandlerInterface), nopass, pointer :: handlerOut=>null()
+ end type
+
+ type(TextHandlerTestCase) this
+
+ procedure (HandlerInterface), pointer :: procPtr=>null()
+
+ print*, associated(procPtr, this%handlerOut)
+end
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_47.f90
new file mode 100644
index 0000000..43084f6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_47.f90
@@ -0,0 +1,37 @@
+! { dg-do run }
+! Tests the fix for PR68196
+!
+! Contributed by Damian Rouson <damian@sourceryinstitute.org>
+!
+ type AA
+ integer :: i
+ procedure(foo), pointer :: funct
+ end type
+ class(AA), allocatable :: my_AA
+ type(AA) :: res
+
+ allocate (my_AA, source = AA (1, foo))
+
+ res = my_AA%funct ()
+
+ if (res%i .ne. 3) call abort
+ if (.not.associated (res%funct)) call abort
+ if (my_AA%i .ne. 4) call abort
+ if (associated (my_AA%funct)) call abort
+
+contains
+ function foo(A)
+ class(AA), allocatable :: A
+ type(AA) foo
+
+ if (.not.allocated (A)) then
+ allocate (A, source = AA (2, foo))
+ endif
+
+ select type (A)
+ type is (AA)
+ foo = AA (3, foo)
+ A = AA (4, NULL ())
+ end select
+ end function
+end
generated by cgit v1.1 at 2025-04-10 19:56:38 +0000