From 2fcd5884177d490c5cdc36464bd6b0a3bc4e8d54 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 7 Oct 2017 21:14:06 +0000 Subject: [PATCH] re PR fortran/82375 (PDT components in PDT declarations fail to compile) 2017-10-07 Paul Thomas 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 Paul Thomas PR fortran/82375 * gfortran.dg/pdt_13.f03 : New test. * gfortran.dg/pdt_14.f03 : New test. * gfortran.dg/pdt_15.f03 : New test. From-SVN: r253514 --- gcc/fortran/ChangeLog | 35 +++++++++ gcc/fortran/class.c | 3 + gcc/fortran/decl.c | 6 +- gcc/fortran/module.c | 20 +++-- gcc/fortran/resolve.c | 7 +- gcc/fortran/trans-array.c | 29 +++++++- gcc/fortran/trans-decl.c | 4 + gcc/testsuite/ChangeLog | 7 ++ gcc/testsuite/gfortran.dg/pdt_13.f03 | 92 +++++++++++++++++++++++ gcc/testsuite/gfortran.dg/pdt_14.f03 | 90 +++++++++++++++++++++++ gcc/testsuite/gfortran.dg/pdt_15.f03 | 106 +++++++++++++++++++++++++++ 11 files changed, 386 insertions(+), 13 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pdt_13.f03 create mode 100644 gcc/testsuite/gfortran.dg/pdt_14.f03 create mode 100644 gcc/testsuite/gfortran.dg/pdt_15.f03 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 + + 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 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 + + 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 * 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 +! +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 +! +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 +! +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" } } -- 2.30.2