Dear All,
I ran into Ian Chivers in last week's BCS meeting, who told me that he
had found a PDT bug. My response was to post it on Bugzilla, which he
did.... promptly :-) So promptly, in fact, that I felt honour bound to
respond in kind.
Please find attached a patch to fix his bug and the extension to
recursive allocatable instead of pointer components. The third
testcase checks some tidying up in trans-array.c to stop valgrind
complaining about jumps on uninitialized variables.
It turns out that the earlier PDT tests that had PDT components in
module declarations all made use of the default parameter expressions.
Ian's bug exposed this and required the handiwork in module.c. This is
straightforward and involves the hijacking of actual_arglist service
functions as elsewhere in the initial PDT patch.
Once recursive allocatable PDT components are added, the compiler
tries to generate vtables and the associated procedures for the
template types. This of course yields nonsense and so
gfc_find_derived_vtab simply returns null.
The rest of the patch is adequately explained apart from the seemingly
trivial change in trans-decl.c. This problem was characterised by
double freeing of a PDT type, as it goes out of scope, in the
'finally' block. Clearly somebody is using 'tmp' uninitialized but I
am blowed if I can find the culprit. I have fixed it by setting it to
NULL_TREE after the intended use. This is not very satisfactory since
there is clearly a buglet lurking in the woods somewhere. My first
thought was that, since this seems to be PDT related, it must be
associated with the earlier PDT chunks. They all look to be clean,
however. I have commented accordingly.
Bootstraps and regtests on FC23/x86_64 - OK for trunk?
Now to turn to Reinhold Bader's really nasty PDT bug....
Cheers
Paul
2017-10-07 Paul Thomas <pa...@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 Paul Thomas <pa...@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.
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
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 <i...@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
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 <i...@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
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 <i...@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" } }
