2018-01-08 Paul Thomas <pault@gcc.gnu.org>
PR fortran/83611
* decl.c (gfc_get_pdt_instance): If parameterized arrays have
an initializer, convert the kind parameters and add to the
component if the instance.
* trans-array.c (structure_alloc_comps): Add 'is_pdt_type' and
use it with case COPY_ALLOC_COMP. Call 'duplicate_allocatable'
for parameterized arrays. Clean up typos in comments. Convert
parameterized array initializers and copy into the array.
* trans-expr.c (gfc_trans_scalar_assign): Do a deep copy for
parameterized types.
*trans-stmt.c (trans_associate_var): Deallocate associate vars
as necessary, when they are PDT function results for example.
PR fortran/83731
* trans-array.c (structure_alloc_comps): Only compare len parms
when they are declared explicitly.
2018-01-08 Paul Thomas <pault@gcc.gnu.org>
PR fortran/83611
* gfortran.dg/pdt_15.f03 : Bump count of 'n.data = 0B' to 8.
* gfortran.dg/pdt_26.f03 : Bump count of '_malloc' to 9.
* gfortran.dg/pdt_27.f03 : New test.
PR fortran/83731
* gfortran.dg/pdt_28.f03 : New test.
From-SVN: r256335
+2018-01-08 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/83611
+ * decl.c (gfc_get_pdt_instance): If parameterized arrays have
+ an initializer, convert the kind parameters and add to the
+ component if the instance.
+ * trans-array.c (structure_alloc_comps): Add 'is_pdt_type' and
+ use it with case COPY_ALLOC_COMP. Call 'duplicate_allocatable'
+ for parameterized arrays. Clean up typos in comments. Convert
+ parameterized array initializers and copy into the array.
+ * trans-expr.c (gfc_trans_scalar_assign): Do a deep copy for
+ parameterized types.
+ *trans-stmt.c (trans_associate_var): Deallocate associate vars
+ as necessary, when they are PDT function results for example.
+
+ PR fortran/83731
+ * trans-array.c (structure_alloc_comps): Only compare len parms
+ when they are declared explicitly.
+
2018-01-06 Janne Blomqvist <jb@gcc.gnu.org>
PR fortran/50892
c2->as->upper[i] = e;
}
c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
+ if (c1->initializer)
+ {
+ c2->initializer = gfc_copy_expr (c1->initializer);
+ gfc_insert_kind_parameter_exprs (c2->initializer);
+ gfc_simplify_expr (c2->initializer, 1);
+ }
}
/* Recurse into this function for PDT components. */
bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
|| (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived);
+ bool is_pdt_type = c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.pdt_type;
+
cdecl = c->backend_decl;
ctype = TREE_TYPE (cdecl);
components that are really allocated, the deep copy code has to
be generated first and then added to the if-block in
gfc_duplicate_allocatable (). */
- if (cmp_has_alloc_comps && !c->attr.proc_pointer
- && !same_type)
+ if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
{
rank = c->as ? c->as->rank : 0;
tmp = fold_convert (TREE_TYPE (dcmp), comp);
false, false, size, NULL_TREE);
gfc_add_expr_to_block (&fnblock, tmp);
}
- else if (c->attr.allocatable && !c->attr.proc_pointer && !same_type
- && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension
- || caf_in_coarray (caf_mode)))
+ else if (c->attr.pdt_array)
+ {
+ tmp = duplicate_allocatable (dcmp, comp, ctype,
+ c->as ? c->as->rank : 0,
+ false, false, NULL_TREE, NULL_TREE);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else if ((c->attr.allocatable)
+ && !c->attr.proc_pointer && !same_type
+ && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension
+ || caf_in_coarray (caf_mode)))
{
rank = c->as ? c->as->rank : 0;
if (c->attr.codimension)
gfc_add_expr_to_block (&fnblock, tmp);
}
else
- if (cmp_has_alloc_comps)
+ if (cmp_has_alloc_comps || is_pdt_type)
gfc_add_expr_to_block (&fnblock, add_when_allocated);
break;
}
gfc_free_expr (e);
- /* Scalar parameterizied strings can be allocated now. */
+ /* Scalar parameterized strings can be allocated now. */
if (!c->as)
{
tmp = fold_convert (gfc_array_index_type, strlen);
}
}
- /* Allocate paramterized arrays of parameterized derived types. */
+ /* Allocate parameterized arrays of parameterized derived types. */
if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
&& !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
&& (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
tmp = gfc_conv_descriptor_dtype (comp);
gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
+
+ if (c->initializer && c->initializer->rank)
+ {
+ gfc_init_se (&tse, NULL);
+ e = gfc_copy_expr (c->initializer);
+ gfc_insert_parameter_exprs (e, pdt_param_list);
+ gfc_conv_expr_descriptor (&tse, e);
+ gfc_add_block_to_block (&fnblock, &tse.pre);
+ gfc_free_expr (e);
+ tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+ tmp = build_call_expr_loc (input_location, tmp, 3,
+ gfc_conv_descriptor_data_get (comp),
+ gfc_conv_descriptor_data_get (tse.expr),
+ fold_convert (size_type_node, size));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ gfc_add_block_to_block (&fnblock, &tse.post);
+ }
}
/* Recurse in to PDT components. */
gfc_init_se (&tse, NULL);
for (; param; param = param->next)
- if (!strcmp (c->name, param->name))
+ if (!strcmp (c->name, param->name)
+ && param->spec_type == SPEC_EXPLICIT)
c_expr = param->expr;
if (c_expr)
gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
rse->expr, ts.kind);
}
- else if (gfc_bt_struct (ts.type) && ts.u.derived->attr.alloc_comp)
+ else if (gfc_bt_struct (ts.type)
+ && (ts.u.derived->attr.alloc_comp
+ || (deep_copy && ts.u.derived->attr.pdt_type)))
{
tree tmp_var = NULL_TREE;
cond = NULL_TREE;
gfc_conv_descriptor_span_set (&se.pre, desc, tmp);
}
+ if (e->expr_type == EXPR_FUNCTION
+ && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived
+ && sym->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, se.expr,
+ sym->as->rank);
+ gfc_add_expr_to_block (&se.post, tmp);
+ }
+
/* Done, register stuff as init / cleanup code. */
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
gfc_finish_block (&se.post));
else
{
gfc_expr *lhs;
+ tree res;
lhs = gfc_lval_expr_from_sym (sym);
- tmp = gfc_trans_assignment (lhs, e, false, true);
- gfc_add_init_cleanup (block, tmp, NULL_TREE);
+ res = gfc_trans_assignment (lhs, e, false, true);
+
+ tmp = sym->backend_decl;
+ if (e->expr_type == EXPR_FUNCTION
+ && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived
+ && sym->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp,
+ 0);
+ }
+ else if (e->expr_type == EXPR_FUNCTION
+ && sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->ts.u.derived
+ && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_class_data_get (tmp);
+ tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived,
+ tmp, 0);
+ }
+
+ gfc_add_init_cleanup (block, res, tmp);
}
/* Set the stringlength, when needed. */
+2018-01-08 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/83611
+ * gfortran.dg/pdt_15.f03 : Bump count of 'n.data = 0B' to 8.
+ * gfortran.dg/pdt_26.f03 : Bump count of '_malloc' to 9.
+ * gfortran.dg/pdt_27.f03 : New test.
+
+ PR fortran/83731
+ * gfortran.dg/pdt_28.f03 : New test.
+
2018-01-08 Tom de Vries <tom@codesourcery.com>
* c-c++-common/builtins.c: Require effective target alloca.
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 ".n.data = 0B" 8 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_free" 14 "original" } }
if (any (c(1)%foo .ne. [13,15,17])) call abort
end program test_pdt
! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
-! { dg-final { scan-tree-dump-times "__builtin_malloc" 7 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 9 "original" } }
--- /dev/null
+! { dg-do run }
+!
+! Test the fix for PR83611, in which the assignment caused a
+! double free error and the initialization of 'foo' was not done.
+!
+module pdt_m
+ implicit none
+ type :: vec(k)
+ integer, len :: k=3
+ integer :: foo(k)=[1,2,3]
+ end type vec
+end module pdt_m
+
+program test_pdt
+ use pdt_m
+ implicit none
+ type(vec) :: u,v
+ if (any (u%foo .ne. [1,2,3])) call abort
+ u%foo = [7,8,9]
+ v = u
+ if (any (v%foo .ne. [7,8,9])) call abort
+end program test_pdt
--- /dev/null
+! { dg-do run }
+! ( dg-options "-fbounds-check" }
+!
+! Test the fix for PR83731, where the following failed on the check for the
+! value of the parameter 'k'.
+!
+! Contributed by Berke Durak <berke.durak@gmail.com>
+!
+module pdt_m
+ implicit none
+ type :: vec(k)
+ integer, len :: k=10
+ integer :: foo(k)
+ end type vec
+contains
+ function total(a)
+ type(vec(k=*)), intent(in) :: a ! Would compare with the default initializer.
+ integer :: total
+
+ total=sum(a%foo)
+ end function total
+end module pdt_m
+
+program test_pdt
+ use pdt_m
+ implicit none
+ type(vec(k=123)) :: u
+
+ u%foo=1
+ if (total(u) .ne. u%k) call abort
+end program test_pdt
projects / thirdparty / gcc.git / commitdiff
