2014-03-06 Paul Thomas <pault@gcc.gnu.org>
Janus Weil <janus@gcc.gnu.org>
PR fortran/51976
* gfortran.h (symbol_attribute): Add deferred_parameter attribute.
* primary.c (build_actual_constructor): It is not an error if
a missing component has the deferred_parameter attribute;
equally, if one is given a value, it is an error.
* resolve.c (resolve_fl_derived0): Remove error for deferred
character length components. Add the hidden string length
field to the structure. Give it the deferred_parameter
attribute.
* trans-array.c (duplicate_allocatable): Add a strlen field
which is used as the element size if it is non-null.
(gfc_duplicate_allocatable, gfc_copy_allocatable_data): Pass a
NULL to the new argument in duplicate_allocatable.
(structure_alloc_comps): Set the hidden string length as
appropriate. Use it in calls to duplicate_allocatable.
(gfc_alloc_allocatable_for_assignment): When a deferred length
backend declaration is variable, use that; otherwise use the
string length from the expression evaluation.
* trans-expr.c (gfc_conv_component_ref): If this is a deferred
character length component, the string length should have the
value of the hidden string length field.
(gfc_trans_subcomponent_assign): Set the hidden string length
field for deferred character length components. Allocate the
necessary memory for the string.
(alloc_scalar_allocatable_for_assignment): Same change as in
gfc_alloc_allocatable_for_assignment above.
* trans-stmt.c (gfc_trans_allocate): Likewise.
* trans-intrinsic (size_of_string_in_bytes): Make non-static.
* trans-types.c (gfc_get_derived_type): Set the tree type for
a deferred character length component.
* trans.c (gfc_deferred_strlen): New function.
* trans.h (size_of_string_in_bytes,gfc_deferred_strlen): New prototypes.
2014-03-06 Paul Thomas <pault@gcc.gnu.org>
Janus Weil <janus@gcc.gnu.org>
PR fortran/51976
* gfortran.dg/deferred_type_component_1.f90 : New test.
* gfortran.dg/deferred_type_component_2.f90 : New test.
Co-Authored-By: Janus Weil <janus@gcc.gnu.org>
From-SVN: r208386
+2014-03-06 Paul Thomas <pault@gcc.gnu.org>
+ Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/51976
+ * gfortran.h (symbol_attribute): Add deferred_parameter attribute.
+ * primary.c (build_actual_constructor): It is not an error if
+ a missing component has the deferred_parameter attribute;
+ equally, if one is given a value, it is an error.
+ * resolve.c (resolve_fl_derived0): Remove error for deferred
+ character length components. Add the hidden string length
+ field to the structure. Give it the deferred_parameter
+ attribute.
+ * trans-array.c (duplicate_allocatable): Add a strlen field
+ which is used as the element size if it is non-null.
+ (gfc_duplicate_allocatable, gfc_copy_allocatable_data): Pass a
+ NULL to the new argument in duplicate_allocatable.
+ (structure_alloc_comps): Set the hidden string length as
+ appropriate. Use it in calls to duplicate_allocatable.
+ (gfc_alloc_allocatable_for_assignment): When a deferred length
+ backend declaration is variable, use that; otherwise use the
+ string length from the expression evaluation.
+ * trans-expr.c (gfc_conv_component_ref): If this is a deferred
+ character length component, the string length should have the
+ value of the hidden string length field.
+ (gfc_trans_subcomponent_assign): Set the hidden string length
+ field for deferred character length components. Allocate the
+ necessary memory for the string.
+ (alloc_scalar_allocatable_for_assignment): Same change as in
+ gfc_alloc_allocatable_for_assignment above.
+ * trans-stmt.c (gfc_trans_allocate): Likewise.
+ * trans-intrinsic (size_of_string_in_bytes): Make non-static.
+ * trans-types.c (gfc_get_derived_type): Set the tree type for
+ a deferred character length component.
+ * trans.c (gfc_deferred_strlen): New function.
+ * trans.h (size_of_string_in_bytes,gfc_deferred_strlen): New prototypes.
+
2014-03-01 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/60341
/* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */
unsigned ext_attr:EXT_ATTR_NUM;
+ /* Is a parameter associated with a deferred type component. */
+ unsigned deferred_parameter:1;
+
/* The namespace where the attribute has been set. */
struct gfc_namespace *volatile_ns, *asynchronous_ns;
}
}
/* If it was not found, try the default initializer if there's any;
- otherwise, it's an error. */
+ otherwise, it's an error unless this is a deferred parameter. */
if (!comp_iter)
{
if (comp->initializer)
return false;
value = gfc_copy_expr (comp->initializer);
}
- else
+ else if (!comp->attr.deferred_parameter)
{
gfc_error ("No initializer for component '%s' given in the"
" structure constructor at %C!", comp->name);
{
/* Components without name are not allowed after the first named
component initializer! */
- if (!comp)
+ if (!comp || comp->attr.deferred_parameter)
{
if (last_name)
gfc_error ("Component initializer without name after component"
if (c->attr.artificial)
continue;
- /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
- if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function)
- {
- gfc_error ("Deferred-length character component '%s' at %L is not "
- "yet supported", c->name, &c->loc);
- return false;
- }
-
/* F2008, C442. */
if ((!sym->attr.is_class || c != sym->components)
&& c->attr.codimension
return false;
}
+ /* Add the hidden deferred length field. */
+ if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function
+ && !sym->attr.is_class)
+ {
+ char name[GFC_MAX_SYMBOL_LEN+9];
+ gfc_component *strlen;
+ sprintf (name, "_%s_length", c->name);
+ strlen = gfc_find_component (sym, name, true, true);
+ if (strlen == NULL)
+ {
+ if (!gfc_add_component (sym, name, &strlen))
+ return false;
+ strlen->ts.type = BT_INTEGER;
+ strlen->ts.kind = gfc_charlen_int_kind;
+ strlen->attr.access = ACCESS_PRIVATE;
+ strlen->attr.deferred_parameter = 1;
+ }
+ }
+
if (c->ts.type == BT_DERIVED
&& sym->component_access != ACCESS_PRIVATE
&& gfc_check_symbol_access (sym)
static tree
duplicate_allocatable (tree dest, tree src, tree type, int rank,
- bool no_malloc)
+ bool no_malloc, tree str_sz)
{
tree tmp;
tree size;
null_data = gfc_finish_block (&block);
gfc_init_block (&block);
- size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+ if (str_sz != NULL_TREE)
+ size = str_sz;
+ else
+ size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+
if (!no_malloc)
{
tmp = gfc_call_malloc (&block, type, size);
else
nelems = gfc_index_one_node;
- tmp = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ if (str_sz != NULL_TREE)
+ tmp = fold_convert (gfc_array_index_type, str_sz);
+ else
+ tmp = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
nelems, tmp);
if (!no_malloc)
tree
gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
{
- return duplicate_allocatable (dest, src, type, rank, false);
+ return duplicate_allocatable (dest, src, type, rank, false, NULL_TREE);
}
tree
gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
{
- return duplicate_allocatable (dest, src, type, rank, true);
+ return duplicate_allocatable (dest, src, type, rank, true, NULL_TREE);
}
void_type_node, comp,
build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&fnblock, tmp);
+ if (gfc_deferred_strlen (c, &comp))
+ {
+ comp = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (comp),
+ decl, comp, NULL_TREE);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (comp), comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
}
else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
{
continue;
}
- if (c->attr.allocatable && !c->attr.proc_pointer
- && !cmp_has_alloc_comps)
+ if (gfc_deferred_strlen (c, &tmp))
+ {
+ tree len, size;
+ len = tmp;
+ tmp = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (len),
+ decl, len, NULL_TREE);
+ len = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (len),
+ dest, len, NULL_TREE);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (len), len, tmp);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ size = size_of_string_in_bytes (c->ts.kind, len);
+ tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
+ false, size);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else if (c->attr.allocatable && !c->attr.proc_pointer
+ && !cmp_has_alloc_comps)
{
rank = c->as ? c->as->rank : 0;
if (c->attr.codimension)
/* Get the new lhs size in bytes. */
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
{
- tmp = expr2->ts.u.cl->backend_decl;
- gcc_assert (expr1->ts.u.cl->backend_decl);
- tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
- gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+ if (expr2->ts.deferred)
+ {
+ if (TREE_CODE (expr2->ts.u.cl->backend_decl) == VAR_DECL)
+ tmp = expr2->ts.u.cl->backend_decl;
+ else
+ tmp = rss->info->string_length;
+ }
+ else
+ {
+ tmp = expr2->ts.u.cl->backend_decl;
+ tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
+ }
+
+ if (expr1->ts.u.cl->backend_decl
+ && TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL)
+ gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+ else
+ gfc_add_modify (&fblock, lss->info->string_length, tmp);
}
else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
{
se->string_length = tmp;
}
+ if (gfc_deferred_strlen (c, &field))
+ {
+ tmp = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field),
+ decl, field, NULL_TREE);
+ se->string_length = tmp;
+ }
+
if (((c->attr.pointer || c->attr.allocatable)
&& (!c->attr.dimension && !c->attr.codimension)
&& c->ts.type != BT_CHARACTER)
gfc_add_expr_to_block (&block, tmp);
}
}
- else
+ else if (gfc_deferred_strlen (cm, &tmp))
+ {
+ tree strlen;
+ strlen = tmp;
+ gcc_assert (strlen);
+ strlen = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (strlen),
+ TREE_OPERAND (dest, 0),
+ strlen, NULL_TREE);
+
+ if (expr->expr_type == EXPR_NULL)
+ {
+ tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
+ gfc_add_modify (&block, dest, tmp);
+ tmp = build_int_cst (TREE_TYPE (strlen), 0);
+ gfc_add_modify (&block, strlen, tmp);
+ }
+ else
+ {
+ tree size;
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, expr);
+ size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MALLOC),
+ 1, size);
+ gfc_add_modify (&block, dest,
+ fold_convert (TREE_TYPE (dest), tmp));
+ gfc_add_modify (&block, strlen, se.string_length);
+ tmp = gfc_build_memcpy_call (dest, se.expr, size);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ }
+ else if (!cm->attr.deferred_parameter)
{
- /* Scalar component. */
+ /* Scalar component (excluding deferred parameters). */
gfc_init_se (&se, NULL);
gfc_init_se (&lse, NULL);
/* Update the lhs character length. */
size = string_length;
- gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
+ if (TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL)
+ gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
+ else
+ gfc_add_modify (block, lse.string_length, size);
}
}
excluding the terminating null characters. The result has
gfc_array_index_type type. */
-static tree
+tree
size_of_string_in_bytes (int kind, tree string_length)
{
tree bytesize;
if (tmp && TREE_CODE (tmp) == VAR_DECL)
gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
memsz));
+ else if (al->expr->ts.type == BT_CHARACTER
+ && al->expr->ts.deferred && se.string_length)
+ gfc_add_modify (&se.pre, se.string_length,
+ fold_convert (TREE_TYPE (se.string_length),
+ memsz));
/* Convert to size in bytes, using the character KIND. */
if (unlimited_char)
field_type = c->ts.u.derived->backend_decl;
else
{
- if (c->ts.type == BT_CHARACTER)
+ if (c->ts.type == BT_CHARACTER && !c->ts.deferred)
{
/* Evaluate the string length. */
gfc_conv_const_charlen (c->ts.u.cl);
gcc_assert (c->ts.u.cl->backend_decl);
}
+ else if (c->ts.type == BT_CHARACTER)
+ c->ts.u.cl->backend_decl
+ = build_int_cst (gfc_charlen_type_node, 0);
field_type = gfc_typenode_for_spec (&c->ts);
}
cond = fold_convert (boolean_type_node, cond);
return cond;
}
+
+
+/* Get the string length for a deferred character length component. */
+
+bool
+gfc_deferred_strlen (gfc_component *c, tree *decl)
+{
+ char name[GFC_MAX_SYMBOL_LEN+9];
+ gfc_component *strlen;
+ if (!(c->ts.type == BT_CHARACTER && c->ts.deferred))
+ return false;
+ sprintf (name, "_%s_length", c->name);
+ for (strlen = c; strlen; strlen = strlen->next)
+ if (strcmp (strlen->name, name) == 0)
+ break;
+ *decl = strlen ? strlen->backend_decl : NULL_TREE;
+ return strlen != NULL;
+}
/* Find the appropriate variant of a math intrinsic. */
tree gfc_builtin_decl_for_float_kind (enum built_in_function, int);
+tree size_of_string_in_bytes (int, tree);
+
/* Intrinsic procedure handling. */
tree gfc_conv_intrinsic_subroutine (gfc_code *);
void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *);
tree gfc_likely (tree);
tree gfc_unlikely (tree);
+/* Return the string length of a deferred character length component. */
+bool gfc_deferred_strlen (gfc_component *, tree *);
+
/* Generate a runtime error call. */
tree gfc_trans_runtime_error (bool, locus*, const char*, ...);
+2014-03-06 Paul Thomas <pault@gcc.gnu.org>
+ Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/51976
+ * gfortran.dg/deferred_type_component_1.f90 : New test.
+ * gfortran.dg/deferred_type_component_2.f90 : New test.
+
2014-03-06 Marek Polacek <polacek@redhat.com>
PR c/60197
--- /dev/null
+! { dg-do run }
+!
+! PR 51976: [F2003] Support deferred-length character components of derived types (allocatable string length)
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+ type t
+ character(len=:), allocatable :: str_comp
+ character(len=:), allocatable :: str_comp1
+ end type t
+ type(t) :: x
+ type(t), allocatable, dimension(:) :: array
+
+ ! Check scalars
+ allocate (x%str_comp, source = "abc")
+ call check (x%str_comp, "abc")
+ deallocate (x%str_comp)
+ allocate (x%str_comp, source = "abcdefghijklmnop")
+ call check (x%str_comp, "abcdefghijklmnop")
+ x%str_comp = "xyz"
+ call check (x%str_comp, "xyz")
+ x%str_comp = "abcdefghijklmnop"
+ x%str_comp1 = "lmnopqrst"
+ call foo (x%str_comp1, "lmnopqrst")
+ call bar (x, "abcdefghijklmnop", "lmnopqrst")
+
+ ! Check arrays and structure constructors
+ allocate (array(2), source = [t("abcedefg","hi"), t("jkl","mnop")])
+ call check (array(1)%str_comp, "abcedefg")
+ call check (array(1)%str_comp1, "hi")
+ call check (array(2)%str_comp, "jkl")
+ call check (array(2)%str_comp1, "mnop")
+ deallocate (array)
+ allocate (array(3), source = [x, x, x])
+ array(2)%str_comp = "blooey"
+ call bar (array(1), "abcdefghijklmnop", "lmnopqrst")
+ call bar (array(2), "blooey", "lmnopqrst")
+ call bar (array(3), "abcdefghijklmnop", "lmnopqrst")
+
+contains
+
+ subroutine foo (chr1, chr2)
+ character (*) :: chr1, chr2
+ call check (chr1, chr2)
+ end subroutine
+
+ subroutine bar (a, chr1, chr2)
+ character (*) :: chr1, chr2
+ type(t) :: a
+ call check (a%str_comp, chr1)
+ call check (a%str_comp1, chr2)
+ end subroutine
+
+ subroutine check (chr1, chr2)
+ character (*) :: chr1, chr2
+ if (len(chr1) .ne. len (chr2)) call abort
+ if (chr1 .ne. chr2) call abort
+ end subroutine
+
+end
--- /dev/null
+! { dg-do run }
+!
+! PR 51976: [F2003] Support deferred-length character components of derived types (allocatable string length)
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+ type t
+ character(len=:,kind=4), allocatable :: str_comp
+ character(len=:,kind=4), allocatable :: str_comp1
+ end type t
+ type(t) :: x
+ type(t), allocatable, dimension(:) :: array
+
+ ! Check scalars
+ allocate (x%str_comp, source = 4_"abc")
+ call check (x%str_comp, 4_"abc")
+ deallocate (x%str_comp)
+ allocate (x%str_comp, source = 4_"abcdefghijklmnop")
+ call check (x%str_comp, 4_"abcdefghijklmnop")
+ x%str_comp = 4_"xyz"
+ call check (x%str_comp, 4_"xyz")
+ x%str_comp = 4_"abcdefghijklmnop"
+ x%str_comp1 = 4_"lmnopqrst"
+ call foo (x%str_comp1, 4_"lmnopqrst")
+ call bar (x, 4_"abcdefghijklmnop", 4_"lmnopqrst")
+
+ ! Check arrays and structure constructors
+ allocate (array(2), source = [t(4_"abcedefg",4_"hi"), t(4_"jkl",4_"mnop")])
+ call check (array(1)%str_comp, 4_"abcedefg")
+ call check (array(1)%str_comp1, 4_"hi")
+ call check (array(2)%str_comp, 4_"jkl")
+ call check (array(2)%str_comp1, 4_"mnop")
+ deallocate (array)
+ allocate (array(3), source = [x, x, x])
+ array(2)%str_comp = 4_"blooey"
+ call bar (array(1), 4_"abcdefghijklmnop", 4_"lmnopqrst")
+ call bar (array(2), 4_"blooey", 4_"lmnopqrst")
+ call bar (array(3), 4_"abcdefghijklmnop", 4_"lmnopqrst")
+
+contains
+
+ subroutine foo (chr1, chr2)
+ character (len=*,kind=4) :: chr1, chr2
+ call check (chr1, chr2)
+ end subroutine
+
+ subroutine bar (a, chr1, chr2)
+ character (len=*,kind=4) :: chr1, chr2
+ type(t) :: a
+ call check (a%str_comp, chr1)
+ call check (a%str_comp1, chr2)
+ end subroutine
+
+ subroutine check (chr1, chr2)
+ character (len=*,kind=4) :: chr1, chr2
+ if (len(chr1) .ne. len (chr2)) call abort
+ if (chr1 .ne. chr2) call abort
+ end subroutine
+
+end
projects / thirdparty / gcc.git / commitdiff
