aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog35
-rw-r--r--gcc/fortran/class.c3
-rw-r--r--gcc/fortran/decl.c6
-rw-r--r--gcc/fortran/module.c20
-rw-r--r--gcc/fortran/resolve.c7
-rw-r--r--gcc/fortran/trans-array.c29
-rw-r--r--gcc/fortran/trans-decl.c4
-rw-r--r--gcc/testsuite/ChangeLog7
-rw-r--r--gcc/testsuite/gfortran.dg/pdt_13.f0392
-rw-r--r--gcc/testsuite/gfortran.dg/pdt_14.f0390
-rw-r--r--gcc/testsuite/gfortran.dg/pdt_15.f03106
11 files changed, 386 insertions, 13 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 67a5b02e43b..c9e81aa238c 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,38 @@
+2017-10-07 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/82375
+ * class.c (gfc_find_derived_vtab): Return NULL for a passed
+ pdt template to prevent bad procedures from being written.
+ * decl.c (gfc_get_pdt_instance): Do not use the default
+ initializer for pointer and allocatable pdt type components. If
+ the component is allocatbale, set the 'alloc_comp' attribute of
+ 'instance'.
+ * module.c : Add a prototype for 'mio_actual_arglist'. Add a
+ boolean argument 'pdt'.
+ (mio_component): Call it for the parameter list of pdt type
+ components with 'pdt' set to true.
+ (mio_actual_arg): Add the boolean 'pdt' and, if it is set, call
+ mio_integer for the 'spec_type'.
+ (mio_actual_arglist): Add the boolean 'pdt' and use it in the
+ call to mio_actual_arg.
+ (mio_expr, mio_omp_udr_expr): Call mio_actual_arglist with
+ 'pdt' set false.
+ * resolve.c (get_pdt_spec_expr): Add the parameter name to the
+ KIND parameter error.
+ (get_pdt_constructor): Check that cons->expr is non-null.
+ * trans-array.c (structure_alloc_comps): For deallocation of
+ allocatable components, ensure that parameterized components
+ are deallocated first. Likewise, when parameterized components
+ are allocated, nullify allocatable components first. Do not
+ recurse into pointer or allocatable pdt components while
+ allocating or deallocating parameterized components. Test that
+ parameterized arrays or strings are allocated before freeing
+ them.
+ (gfc_trans_pointer_assignment): Call the new function. Tidy up
+ a minor whitespace issue.
+ trans-decl.c (gfc_trans_deferred_vars): Set 'tmp' to NULL_TREE
+ to prevent the expression from being used a second time.
+
2017-10-07 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/49232
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index a345d131442..ebbd41b0d96 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -2211,6 +2211,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
gfc_gsymbol *gsym = NULL;
gfc_symbol *dealloc = NULL, *arg = NULL;
+ if (derived->attr.pdt_template)
+ return NULL;
+
/* Find the top-level namespace. */
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (!ns->parent)
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 18220a127c3..5bf56c4d4b0 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -3570,7 +3570,11 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
type_param_spec_list = old_param_spec_list;
c2->param_list = params;
- c2->initializer = gfc_default_initializer (&c2->ts);
+ if (!(c2->attr.pointer || c2->attr.allocatable))
+ c2->initializer = gfc_default_initializer (&c2->ts);
+
+ if (c2->attr.allocatable)
+ instance->attr.alloc_comp = 1;
}
}
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 63877a08050..3f19a021609 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -2788,6 +2788,7 @@ mio_component_ref (gfc_component **cp)
static void mio_namespace_ref (gfc_namespace **nsp);
static void mio_formal_arglist (gfc_formal_arglist **formal);
static void mio_typebound_proc (gfc_typebound_proc** proc);
+static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt);
static void
mio_component (gfc_component *c, int vtype)
@@ -2819,6 +2820,9 @@ mio_component (gfc_component *c, int vtype)
/* PDT templates store the expression for the kind of a component here. */
mio_expr (&c->kind_expr);
+ /* PDT types store component specification list here. */
+ mio_actual_arglist (&c->param_list, true);
+
mio_symbol_attribute (&c->attr);
if (c->ts.type == BT_CLASS)
c->attr.class_ok = 1;
@@ -2874,17 +2878,19 @@ mio_component_list (gfc_component **cp, int vtype)
static void
-mio_actual_arg (gfc_actual_arglist *a)
+mio_actual_arg (gfc_actual_arglist *a, bool pdt)
{
mio_lparen ();
mio_pool_string (&a->name);
mio_expr (&a->expr);
+ if (pdt)
+ mio_integer ((int *)&a->spec_type);
mio_rparen ();
}
static void
-mio_actual_arglist (gfc_actual_arglist **ap)
+mio_actual_arglist (gfc_actual_arglist **ap, bool pdt)
{
gfc_actual_arglist *a, *tail;
@@ -2893,7 +2899,7 @@ mio_actual_arglist (gfc_actual_arglist **ap)
if (iomode == IO_OUTPUT)
{
for (a = *ap; a; a = a->next)
- mio_actual_arg (a);
+ mio_actual_arg (a, pdt);
}
else
@@ -2913,7 +2919,7 @@ mio_actual_arglist (gfc_actual_arglist **ap)
tail->next = a;
tail = a;
- mio_actual_arg (a);
+ mio_actual_arg (a, pdt);
}
}
@@ -3538,7 +3544,7 @@ mio_expr (gfc_expr **ep)
case EXPR_FUNCTION:
mio_symtree_ref (&e->symtree);
- mio_actual_arglist (&e->value.function.actual);
+ mio_actual_arglist (&e->value.function.actual, false);
if (iomode == IO_OUTPUT)
{
@@ -4203,7 +4209,7 @@ mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
int flag;
mio_name (1, omp_declare_reduction_stmt);
mio_symtree_ref (&ns->code->symtree);
- mio_actual_arglist (&ns->code->ext.actual);
+ mio_actual_arglist (&ns->code->ext.actual, false);
flag = ns->code->resolved_isym != NULL;
mio_integer (&flag);
@@ -4245,7 +4251,7 @@ mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
int flag;
ns->code = gfc_get_code (EXEC_CALL);
mio_symtree_ref (&ns->code->symtree);
- mio_actual_arglist (&ns->code->ext.actual);
+ mio_actual_arglist (&ns->code->ext.actual, false);
mio_integer (&flag);
if (flag)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fab7c230c1a..bd316344813 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1161,8 +1161,8 @@ get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
param_tail->spec_type = SPEC_ASSUMED;
if (c->attr.pdt_kind)
{
- gfc_error ("The KIND parameter in the PDT constructor "
- "at %C has no value");
+ gfc_error ("The KIND parameter %qs in the PDT constructor "
+ "at %C has no value", param->name);
return false;
}
}
@@ -1188,7 +1188,8 @@ get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
{
- if (cons->expr->expr_type == EXPR_STRUCTURE
+ if (cons->expr
+ && cons->expr->expr_type == EXPR_STRUCTURE
&& comp->ts.type == BT_DERIVED)
{
t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 328da4e78b1..a357389ae64 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8400,6 +8400,19 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
return tmp;
}
+ if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
+ {
+ tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ DEALLOCATE_PDT_COMP, 0);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
+ {
+ tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ NULLIFY_ALLOC_COMP, 0);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
/* Otherwise, act on the components or recursively call self to
act on a chain of components. */
for (c = der_type->components; c; c = c->next)
@@ -9072,7 +9085,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
/* Recurse in to PDT components. */
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
- && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
+ && !(c->attr.pointer || c->attr.allocatable))
{
bool is_deferred = false;
gfc_actual_arglist *tail = c->param_list;
@@ -9106,7 +9120,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
/* Recurse in to PDT components. */
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
- && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
+ && (!c->attr.pointer && !c->attr.allocatable))
{
tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
c->as ? c->as->rank : 0);
@@ -9116,13 +9131,23 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
if (c->attr.pdt_array)
{
tmp = gfc_conv_descriptor_data_get (comp);
+ null_cond = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
tmp = gfc_call_free (tmp);
+ tmp = build3_v (COND_EXPR, null_cond, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&fnblock, tmp);
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
}
else if (c->attr.pdt_string)
{
+ null_cond = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
tmp = gfc_call_free (comp);
+ tmp = build3_v (COND_EXPR, null_cond, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&fnblock, tmp);
tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
gfc_add_modify (&fnblock, comp, tmp);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index b4f515f21d9..019b8035b6f 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -4634,6 +4634,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
+ /* TODO find out why this is necessary to stop double calls to
+ free. Somebody is reusing the expression in 'tmp' because
+ it is being used unititialized. */
+ tmp = NULL_TREE;
}
}
else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f7640283474..932a67f9855 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2017-10-07 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/82375
+ * gfortran.dg/pdt_13.f03 : New test.
+ * gfortran.dg/pdt_14.f03 : New test.
+ * gfortran.dg/pdt_15.f03 : New test.
+
2017-10-07 Jan Hubicka <hubicka@ucw.cz>
* gcc.dg/cold-1.c: New testcase.
diff --git a/gcc/testsuite/gfortran.dg/pdt_13.f03 b/gcc/testsuite/gfortran.dg/pdt_13.f03
new file mode 100644
index 00000000000..e53d0b7440b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_13.f03
@@ -0,0 +1,92 @@
+! { dg-do run }
+!
+! Test the fix for PR82375
+!
+! Based on contribution by Ian Chivers <ian@rhymneyconsulting.co.uk>
+!
+module precision_module
+ implicit none
+ integer, parameter :: sp = selected_real_kind(6, 37)
+ integer, parameter :: dp = selected_real_kind(15, 307)
+ integer, parameter :: qp = selected_real_kind( 30, 291)
+end module precision_module
+
+module link_module
+ use precision_module
+
+ type link(real_kind)
+ integer, kind :: real_kind
+ real (kind=real_kind) :: n
+ type (link(real_kind)), pointer :: next => NULL()
+ end type link
+
+contains
+
+ function push_8 (self, arg) result(current)
+ real(dp) :: arg
+ type (link(real_kind=dp)), pointer :: self
+ type (link(real_kind=dp)), pointer :: current
+
+ if (associated (self)) then
+ current => self
+ do while (associated (current%next))
+ current => current%next
+ end do
+
+ allocate (current%next)
+ current => current%next
+ else
+ allocate (current)
+ self => current
+ end if
+
+ current%n = arg
+ current%next => NULL ()
+ end function push_8
+
+ function pop_8 (self) result(res)
+ type (link(real_kind=dp)), pointer :: self
+ type (link(real_kind=dp)), pointer :: current => NULL()
+ type (link(real_kind=dp)), pointer :: previous => NULL()
+ real(dp) :: res
+
+ res = 0.0_8
+ if (associated (self)) then
+ current => self
+ do while (associated (current) .and. associated (current%next))
+ previous => current
+ current => current%next
+ end do
+
+ previous%next => NULL ()
+
+ res = current%n
+ if (associated (self, current)) then
+ deallocate (self)
+ else
+ deallocate (current)
+ end if
+
+ end if
+ end function pop_8
+
+end module link_module
+
+program ch2701
+ use precision_module
+ use link_module
+ implicit none
+ integer, parameter :: wp = dp
+ type (link(real_kind=wp)), pointer :: root => NULL()
+ type (link(real_kind=wp)), pointer :: current
+
+ current => push_8 (root, 1.0_8)
+ current => push_8 (root, 2.0_8)
+ current => push_8 (root, 3.0_8)
+
+ if (int (pop_8 (root)) .ne. 3) call abort
+ if (int (pop_8 (root)) .ne. 2) call abort
+ if (int (pop_8 (root)) .ne. 1) call abort
+ if (int (pop_8 (root)) .ne. 0) call abort
+
+end program ch2701
diff --git a/gcc/testsuite/gfortran.dg/pdt_14.f03 b/gcc/testsuite/gfortran.dg/pdt_14.f03
new file mode 100644
index 00000000000..749789848e4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_14.f03
@@ -0,0 +1,90 @@
+! { dg-do run }
+!
+! Test the fix for PR82375. This is the allocatable version of pdt_13.f03.
+!
+! Based on contribution by Ian Chivers <ian@rhymneyconsulting.co.uk>
+!
+module precision_module
+ implicit none
+ integer, parameter :: sp = selected_real_kind(6, 37)
+ integer, parameter :: dp = selected_real_kind(15, 307)
+ integer, parameter :: qp = selected_real_kind( 30, 291)
+end module precision_module
+
+module link_module
+ use precision_module
+
+ type link(real_kind)
+ integer, kind :: real_kind
+ real (kind=real_kind) :: n
+ type (link(real_kind)), allocatable :: next
+ end type link
+
+contains
+
+ function push_8 (self, arg) result(current)
+ real(dp) :: arg
+ type (link(real_kind=dp)), allocatable, target :: self
+ type (link(real_kind=dp)), pointer :: current
+
+ if (allocated (self)) then
+ current => self
+ do while (allocated (current%next))
+ current => current%next
+ end do
+
+ allocate (current%next)
+ current => current%next
+ else
+ allocate (self)
+ current => self
+ end if
+
+ current%n = arg
+
+ end function push_8
+
+ function pop_8 (self) result(res)
+ type (link(real_kind=dp)), allocatable, target :: self
+ type (link(real_kind=dp)), pointer:: current
+ type (link(real_kind=dp)), pointer :: previous
+ real(dp) :: res
+
+ res = 0.0_8
+ if (allocated (self)) then
+ current => self
+ previous => self
+ do while (allocated (current%next))
+ previous => current
+ current => current%next
+ end do
+ res = current%n
+ if (.not.allocated (previous%next)) then
+ deallocate (self)
+ else
+ deallocate (previous%next)
+ end if
+
+ end if
+ end function pop_8
+
+end module link_module
+
+program ch2701
+ use precision_module
+ use link_module
+ implicit none
+ integer, parameter :: wp = dp
+ type (link(real_kind=wp)), allocatable :: root
+ type (link(real_kind=wp)), pointer :: current
+
+ current => push_8 (root, 1.0_8)
+ current => push_8 (root, 2.0_8)
+ current => push_8 (root, 3.0_8)
+
+ if (int (pop_8 (root)) .ne. 3) call abort
+ if (int (pop_8 (root)) .ne. 2) call abort
+ if (int (pop_8 (root)) .ne. 1) call abort
+ if (int (pop_8 (root)) .ne. 0) call abort
+
+end program ch2701
diff --git a/gcc/testsuite/gfortran.dg/pdt_15.f03 b/gcc/testsuite/gfortran.dg/pdt_15.f03
new file mode 100644
index 00000000000..bbf140ea59b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_15.f03
@@ -0,0 +1,106 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR82375. This is a wrinkle on the the allocatable
+! version of pdt_13.f03, pdt_14.f03, whereby 'root' is now declared
+! in a subroutine so that it should be cleaned up automatically. This
+! is best tested with valgrind or its like.
+! In addition, the field 'n' has now become a parameterized length
+! array to verify that the combination of allocatable components and
+! parameterization works correctly.
+!
+! Based on contribution by Ian Chivers <ian@rhymneyconsulting.co.uk>
+!
+module precision_module
+ implicit none
+ integer, parameter :: sp = selected_real_kind(6, 37)
+ integer, parameter :: dp = selected_real_kind(15, 307)
+ integer, parameter :: qp = selected_real_kind( 30, 291)
+end module precision_module
+
+module link_module
+ use precision_module
+
+ type link(real_kind, mat_len)
+ integer, kind :: real_kind
+ integer, len :: mat_len
+ real (kind=real_kind) :: n(mat_len)
+ type (link(real_kind, :)), allocatable :: next
+ end type link
+
+contains
+
+ function push_8 (self, arg) result(current)
+ real(dp) :: arg
+ type (link(real_kind=dp, mat_len=:)), allocatable, target :: self
+ type (link(real_kind=dp, mat_len=:)), pointer :: current
+
+ if (allocated (self)) then
+ current => self
+ do while (allocated (current%next))
+ current => current%next
+ end do
+
+ allocate (link(real_kind=dp, mat_len=1) :: current%next)
+ current => current%next
+ else
+ allocate (link(real_kind=dp, mat_len=1) :: self)
+ current => self
+ end if
+
+ current%n(1) = arg
+
+ end function push_8
+
+ function pop_8 (self) result(res)
+ type (link(real_kind=dp, mat_len=:)), allocatable, target :: self
+ type (link(real_kind=dp, mat_len=:)), pointer:: current => NULL()
+ type (link(real_kind=dp, mat_len=:)), pointer :: previous => NULL()
+ real(dp) :: res
+
+ res = 0.0_8
+ if (allocated (self)) then
+ current => self
+ previous => self
+ do while (allocated (current%next))
+ previous => current
+ current => current%next
+ end do
+ res = current%n(1)
+ if (.not.allocated (previous%next)) then
+ deallocate (self)
+ else
+ deallocate (previous%next)
+ end if
+
+ end if
+ end function pop_8
+
+end module link_module
+
+program ch2701
+ use precision_module
+ use link_module
+ implicit none
+ integer, parameter :: wp = dp
+
+ call foo
+contains
+
+ subroutine foo
+ type (link(real_kind=wp, mat_len=:)), allocatable :: root
+ type (link(real_kind=wp, mat_len=:)), pointer :: current => NULL()
+
+ current => push_8 (root, 1.0_8)
+ current => push_8 (root, 2.0_8)
+ current => push_8 (root, 3.0_8)
+
+ if (int (pop_8 (root)) .ne. 3) call abort
+ if (int (pop_8 (root)) .ne. 2) call abort
+ if (int (pop_8 (root)) .ne. 1) call abort
+! if (int (pop_8 (root)) .ne. 0) call abort
+ end subroutine
+end program ch2701
+! { dg-final { scan-tree-dump-times "Pdtlink_8._deallocate " 5 "original" } }
+! { dg-final { scan-tree-dump-times ".n.data = 0B" 7 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 14 "original" } }
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-10 07:41:54 +0000