Index: gcc/fortran/class.c =================================================================== *** gcc/fortran/class.c (revision 253399) --- gcc/fortran/class.c (working copy) *************** gfc_find_derived_vtab (gfc_symbol *deriv *** 2211,2216 **** --- 2211,2219 ---- 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) Index: gcc/fortran/decl.c =================================================================== *** gcc/fortran/decl.c (revision 253399) --- gcc/fortran/decl.c (working copy) *************** gfc_get_pdt_instance (gfc_actual_arglist *** 3570,3576 **** type_param_spec_list = old_param_spec_list; c2->param_list = params; ! c2->initializer = gfc_default_initializer (&c2->ts); } } --- 3570,3580 ---- type_param_spec_list = old_param_spec_list; c2->param_list = params; ! if (!(c2->attr.pointer || c2->attr.allocatable)) ! c2->initializer = gfc_default_initializer (&c2->ts); ! ! if (c2->attr.allocatable) ! instance->attr.alloc_comp = 1; } } Index: gcc/fortran/module.c =================================================================== *** gcc/fortran/module.c (revision 253399) --- gcc/fortran/module.c (working copy) *************** mio_component_ref (gfc_component **cp) *** 2788,2793 **** --- 2788,2794 ---- 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) *************** mio_component (gfc_component *c, int vty *** 2819,2824 **** --- 2820,2828 ---- /* 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; *************** mio_component_list (gfc_component **cp, *** 2874,2890 **** static void ! mio_actual_arg (gfc_actual_arglist *a) { mio_lparen (); mio_pool_string (&a->name); mio_expr (&a->expr); mio_rparen (); } static void ! mio_actual_arglist (gfc_actual_arglist **ap) { gfc_actual_arglist *a, *tail; --- 2878,2896 ---- static void ! 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, bool pdt) { gfc_actual_arglist *a, *tail; *************** mio_actual_arglist (gfc_actual_arglist * *** 2893,2899 **** if (iomode == IO_OUTPUT) { for (a = *ap; a; a = a->next) ! mio_actual_arg (a); } else --- 2899,2905 ---- if (iomode == IO_OUTPUT) { for (a = *ap; a; a = a->next) ! mio_actual_arg (a, pdt); } else *************** mio_actual_arglist (gfc_actual_arglist * *** 2913,2919 **** tail->next = a; tail = a; ! mio_actual_arg (a); } } --- 2919,2925 ---- tail->next = a; tail = a; ! mio_actual_arg (a, pdt); } } *************** mio_expr (gfc_expr **ep) *** 3538,3544 **** case EXPR_FUNCTION: mio_symtree_ref (&e->symtree); ! mio_actual_arglist (&e->value.function.actual); if (iomode == IO_OUTPUT) { --- 3544,3550 ---- case EXPR_FUNCTION: mio_symtree_ref (&e->symtree); ! mio_actual_arglist (&e->value.function.actual, false); if (iomode == IO_OUTPUT) { *************** mio_omp_udr_expr (gfc_omp_udr *udr, gfc_ *** 4203,4209 **** int flag; mio_name (1, omp_declare_reduction_stmt); mio_symtree_ref (&ns->code->symtree); ! mio_actual_arglist (&ns->code->ext.actual); flag = ns->code->resolved_isym != NULL; mio_integer (&flag); --- 4209,4215 ---- int flag; mio_name (1, omp_declare_reduction_stmt); mio_symtree_ref (&ns->code->symtree); ! mio_actual_arglist (&ns->code->ext.actual, false); flag = ns->code->resolved_isym != NULL; mio_integer (&flag); *************** mio_omp_udr_expr (gfc_omp_udr *udr, gfc_ *** 4245,4251 **** int flag; ns->code = gfc_get_code (EXEC_CALL); mio_symtree_ref (&ns->code->symtree); ! mio_actual_arglist (&ns->code->ext.actual); mio_integer (&flag); if (flag) --- 4251,4257 ---- int flag; ns->code = gfc_get_code (EXEC_CALL); mio_symtree_ref (&ns->code->symtree); ! mio_actual_arglist (&ns->code->ext.actual, false); mio_integer (&flag); if (flag) Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 253400) --- gcc/fortran/resolve.c (working copy) *************** get_pdt_spec_expr (gfc_component *c, gfc *** 1161,1168 **** 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"); return false; } } --- 1161,1168 ---- param_tail->spec_type = SPEC_ASSUMED; if (c->attr.pdt_kind) { ! gfc_error ("The KIND parameter %qs in the PDT constructor " ! "at %C has no value", param->name); return false; } } *************** get_pdt_constructor (gfc_expr *expr, gfc *** 1188,1194 **** for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) { ! if (cons->expr->expr_type == EXPR_STRUCTURE && comp->ts.type == BT_DERIVED) { t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived); --- 1188,1195 ---- for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) { ! 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); Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 253399) --- gcc/fortran/trans-array.c (working copy) *************** structure_alloc_comps (gfc_symbol * der_ *** 8400,8405 **** --- 8400,8418 ---- 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) *************** structure_alloc_comps (gfc_symbol * der_ *** 9072,9078 **** /* 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) { bool is_deferred = false; gfc_actual_arglist *tail = c->param_list; --- 9085,9092 ---- /* 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->attr.pointer || c->attr.allocatable)) { bool is_deferred = false; gfc_actual_arglist *tail = c->param_list; *************** structure_alloc_comps (gfc_symbol * der_ *** 9106,9112 **** /* 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) { tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp, c->as ? c->as->rank : 0); --- 9120,9127 ---- /* 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->attr.pointer && !c->attr.allocatable)) { tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp, c->as ? c->as->rank : 0); *************** structure_alloc_comps (gfc_symbol * der_ *** 9116,9128 **** --- 9131,9153 ---- 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); Index: gcc/fortran/trans-decl.c =================================================================== *** gcc/fortran/trans-decl.c (revision 253400) --- gcc/fortran/trans-decl.c (working copy) *************** gfc_trans_deferred_vars (gfc_symbol * pr *** 4634,4639 **** --- 4634,4643 ---- } 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) Index: gcc/testsuite/gfortran.dg/pdt_13.f03 =================================================================== *** gcc/testsuite/gfortran.dg/pdt_13.f03 (nonexistent) --- gcc/testsuite/gfortran.dg/pdt_13.f03 (working copy) *************** *** 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 Index: gcc/testsuite/gfortran.dg/pdt_14.f03 =================================================================== *** gcc/testsuite/gfortran.dg/pdt_14.f03 (nonexistent) --- gcc/testsuite/gfortran.dg/pdt_14.f03 (working copy) *************** *** 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 Index: gcc/testsuite/gfortran.dg/pdt_15.f03 =================================================================== *** gcc/testsuite/gfortran.dg/pdt_15.f03 (nonexistent) --- gcc/testsuite/gfortran.dg/pdt_15.f03 (working copy) *************** *** 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" } }