{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
- if (string->ts.u.cl)
+ if (string->ts.deferred)
+ f->ts = string->ts;
+ else if (string->ts.u.cl)
f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
{
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
- if (string->ts.u.cl)
+ if (string->ts.deferred)
+ f->ts = string->ts;
+ else if (string->ts.u.cl)
f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
}
-/* Set up the call to RANDOM_INIT. */
+/* Set up the call to RANDOM_INIT. */
void
gfc_resolve_random_init (gfc_code *c)
resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
{
gfc_expr* target;
+ bool parentheses = false;
gcc_assert (sym->assoc);
gcc_assert (sym->attr.flavor == FL_VARIABLE);
return;
gcc_assert (!sym->assoc->dangling);
+ if (target->expr_type == EXPR_OP
+ && target->value.op.op == INTRINSIC_PARENTHESES
+ && target->value.op.op1->expr_type == EXPR_VARIABLE)
+ {
+ sym->assoc->target = gfc_copy_expr (target->value.op.op1);
+ gfc_free_expr (target);
+ target = sym->assoc->target;
+ parentheses = true;
+ }
+
if (resolve_target && !gfc_resolve_expr (target))
return;
/* See if this is a valid association-to-variable. */
sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
+ && !parentheses
&& !gfc_has_vector_subscript (target));
/* Finally resolve if this is an array or not. */
return;
}
-
/* We cannot deal with class selectors that need temporaries. */
if (target->ts.type == BT_CLASS
&& gfc_ref_needs_temporary_p (target->ref))
/* Resolve a BLOCK construct statement. */
-static gfc_expr*
-get_temp_from_expr (gfc_expr *, gfc_namespace *);
-static gfc_code *
-build_assignment (gfc_exec_op, gfc_expr *, gfc_expr *,
- gfc_component *, gfc_component *, locus);
static void
resolve_block_construct (gfc_code* code)
int full;
bool subref_array_target = false;
bool deferred_array_component = false;
+ bool substr = false;
gfc_expr *arg, *ss_expr;
if (se->want_coarray)
&& TREE_CODE (desc) == COMPONENT_REF)
deferred_array_component = true;
+ substr = info->ref && info->ref->next
+ && info->ref->next->type == REF_SUBSTRING;
+
subref_array_target = (is_subref_array (expr)
&& (se->direct_byref
|| expr->ts.type == BT_CHARACTER));
subref_array_target, expr);
/* ....and set the span field. */
- tmp = gfc_conv_descriptor_span_get (desc);
+ if (ss_info->expr->ts.type == BT_CHARACTER)
+ tmp = gfc_conv_descriptor_span_get (desc);
+ else
+ tmp = gfc_get_array_span (desc, expr);
gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
}
else if (se->want_pointer)
need_tmp = 1;
if (expr->ts.type == BT_CHARACTER
+ && expr->ts.u.cl->length
&& expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
get_array_charlen (expr, se);
/* Set the string_length for a character array. */
if (expr->ts.type == BT_CHARACTER)
{
- if (deferred_array_component)
+ if (deferred_array_component && !substr)
se->string_length = ss_info->string_length;
else
se->string_length = gfc_get_expr_charlen (expr);
}
/* Set the span field. */
- tmp = gfc_get_array_span (desc, expr);
+ tmp = NULL_TREE;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ tmp = gfc_conv_descriptor_span_get (desc);
+ else
+ tmp = gfc_get_array_span (desc, expr);
if (tmp)
gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
tree add_when_allocated)
{
tree tmp;
+ tree eltype;
tree size;
tree nelems;
tree null_cond;
null_data = gfc_finish_block (&block);
gfc_init_block (&block);
+ eltype = TREE_TYPE (type);
if (str_sz != NULL_TREE)
size = str_sz;
else
- size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+ size = TYPE_SIZE_UNIT (eltype);
if (!no_malloc)
{
else
nelems = gfc_index_one_node;
+ /* If type is not the array type, then it is the element type. */
+ if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
+ eltype = gfc_get_element_type (type);
+ else
+ eltype = 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)));
+ TYPE_SIZE_UNIT (eltype));
+
+ tmp = gfc_evaluate_now (tmp, &block);
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
nelems, tmp);
if (!no_malloc)
/* This component cannot have allocatable components,
therefore add_when_allocated of duplicate_allocatable ()
is always NULL. */
+ rank = c->as ? c->as->rank : 0;
tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
false, false, size, NULL_TREE);
gfc_add_expr_to_block (&fnblock, tmp);
return decl;
}
+ if (sym->ts.type == BT_UNKNOWN)
+ gfc_fatal_error ("%s at %C has no default type", sym->name);
+
if (sym->attr.intrinsic)
gfc_internal_error ("intrinsic variable which isn't a procedure");
}
trans_function_start (sym);
+ gfc_current_locus = sym->declared_at;
gfc_init_block (&init);
gfc_init_block (&cleanup);
{
gfc_ref *r;
tree length;
+ tree previous = NULL_TREE;
gfc_se se;
gcc_assert (e->expr_type == EXPR_VARIABLE
/* Look through the reference chain for component references. */
for (r = e->ref; r; r = r->next)
{
+ previous = length;
switch (r->type)
{
case REF_COMPONENT:
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
length = se.expr;
- gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
+ if (r->u.ss.end)
+ gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
+ else
+ se.expr = previous;
length = fold_build2_loc (input_location, MINUS_EXPR,
gfc_charlen_type_node,
se.expr, length);
expr_flat = gfc_copy_expr (expr);
flatten_array_ctors_without_strlen (expr_flat);
gfc_resolve_expr (expr_flat);
-
- gfc_conv_expr (&se, expr_flat);
- gfc_add_block_to_block (pblock, &se.pre);
- cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
-
+ if (expr_flat->rank)
+ gfc_conv_expr_descriptor (&se, expr_flat);
+ else
+ gfc_conv_expr (&se, expr_flat);
+ if (expr_flat->expr_type != EXPR_VARIABLE)
+ gfc_add_block_to_block (pblock, &se.pre);
+ se.expr = convert (gfc_charlen_type_node, se.string_length);
+ gfc_add_block_to_block (pblock, &se.post);
gfc_free_expr (expr_flat);
- return;
}
-
- /* Convert cl->length. */
-
- gcc_assert (cl->length);
-
- gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
- se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
- se.expr, build_zero_cst (TREE_TYPE (se.expr)));
- gfc_add_block_to_block (pblock, &se.pre);
+ else
+ {
+ /* Convert cl->length. */
+ gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
+ se.expr = fold_build2_loc (input_location, MAX_EXPR,
+ gfc_charlen_type_node, se.expr,
+ build_zero_cst (TREE_TYPE (se.expr)));
+ gfc_add_block_to_block (pblock, &se.pre);
+ }
if (cl->backend_decl && VAR_P (cl->backend_decl))
gfc_add_modify (pblock, cl->backend_decl, se.expr);
if (parmse.string_length && fsym && fsym->ts.deferred)
{
if (INDIRECT_REF_P (parmse.string_length))
- /* In chains of functions/procedure calls the string_length already
- is a pointer to the variable holding the length. Therefore
- remove the deref on call. */
- parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
+ {
+ /* In chains of functions/procedure calls the string_length already
+ is a pointer to the variable holding the length. Therefore
+ remove the deref on call. */
+ tmp = parmse.string_length;
+ parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
+ }
else
{
tmp = parmse.string_length;
tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
}
+
+ if (e && e->expr_type == EXPR_VARIABLE
+ && fsym->attr.allocatable
+ && e->ts.u.cl->backend_decl
+ && VAR_P (e->ts.u.cl->backend_decl))
+ {
+ if (INDIRECT_REF_P (tmp))
+ tmp = TREE_OPERAND (tmp, 0);
+ gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
+ fold_convert (gfc_charlen_type_node, tmp));
+ }
}
/* Character strings are passed as two parameters, a length and a
gfc_conv_expr_descriptor (&se, expr);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_modify (&block, dest, se.expr);
+ if (cm->ts.type == BT_CHARACTER
+ && gfc_deferred_strlen (cm, &tmp))
+ {
+ tmp = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (tmp),
+ TREE_OPERAND (dest, 0),
+ tmp, NULL_TREE);
+ gfc_add_modify (&block, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ se.string_length));
+ cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
+ "slen");
+ gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
+ }
/* Deal with arrays of derived types with allocatable components. */
if (gfc_bt_struct (cm->ts.type)
tmp, expr->rank, NULL_TREE);
}
}
+ else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
+ tmp = gfc_duplicate_allocatable (dest, se.expr,
+ gfc_typenode_for_spec (&cm->ts),
+ cm->as->rank, NULL_TREE);
else
tmp = gfc_duplicate_allocatable (dest, se.expr,
TREE_TYPE(cm->backend_decl),
cm->as->rank, NULL_TREE);
+
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se.post);
if (expr->ts.type != BT_CLASS
&& expr->expr_type == EXPR_VARIABLE
- && gfc_expr_attr (expr).pointer)
+ && ((expr->symtree->n.sym->ts.type == BT_DERIVED && expr->ts.deferred)
+ || gfc_expr_attr (expr).pointer))
goto scalarize;
-
if (!(gfc_bt_struct (expr->ts.type)
|| expr->ts.type == BT_CLASS)
&& ref && ref->next == NULL
end associate
if (x%d(1) .ne. 'zqrtyd') stop 5
-! Substrings of arrays still do not work correctly.
call foo ('lmnopqrst','ghijklmno')
associate (y => x%d(:)(2:4))
-! if (any (y .ne. ['mno','hij'])) stop 6
+ if (any (y .ne. ['mno','hij'])) stop 6
end associate
call foo ('abcdef','ghijkl')
end
recursive subroutine s2
- associate (y => (s2)) ! { dg-error "Associating selector-expression at .1. yields a procedure" }
+ associate (y => (s2)) ! { dg-error "is a procedure name" }
end associate
end
--- /dev/null
+! { dg-do run }
+!
+! Tests fixes for various pr87477 dependencies
+!
+! Contributed by Gerhard Steinmetz <gscfq@t-online.de> except for pr102106:
+! which was contributed by Brad Richardson <everythingfunctional@protonmail.com>
+!
+program associate_60
+ implicit none
+ character(20) :: buffer
+
+ call pr102106
+ call pr100948
+ call pr85686
+ call pr88247
+ call pr91941
+ call pr92779
+ call pr93339
+ call pr93813
+
+contains
+
+ subroutine pr102106
+ type :: sub_class_t
+ integer :: i
+ end type
+ type :: with_polymorphic_component_t
+ class(sub_class_t), allocatable :: sub_obj_
+ end type
+ associate(obj => with_polymorphic_component_t(sub_class_t(42)))
+ if (obj%sub_obj_%i .ne. 42) stop 1
+ end associate
+ end
+
+ subroutine pr100948
+ type t
+ character(:), allocatable :: c(:)
+ end type
+ type(t), allocatable :: x
+!
+! Valid test in comment 1
+!
+ x = t(['ab','cd'])
+ associate (y => x%c(:))
+ if (any (y .ne. x%c)) stop 2
+ if (any (y .ne. ['ab','cd'])) stop 3
+ end associate
+ deallocate (x)
+!
+! Allocation with source was found to only copy over one of the array elements
+!
+ allocate (x, source = t(['ef','gh']))
+ associate (y => x%c(:))
+ if (any (y .ne. x%c)) stop 4
+ if (any (y .ne. ['ef','gh'])) stop 5
+ end associate
+ deallocate (x)
+ end
+
+ subroutine pr85686
+ call s85686([" g'day "," bye!! "])
+ if (trim (buffer) .ne. " a g'day a bye!!") stop 6
+ end
+
+ subroutine s85686(x)
+ character(*) :: x(:)
+ associate (y => 'a'//x)
+ write (buffer, *) y ! Used to segfault at the write statement.
+ end associate
+ end
+
+ subroutine pr88247
+ type t
+ character(:), dimension(:), allocatable :: d
+ end type t
+ type(t), allocatable :: x
+ character(5) :: buffer(3)
+ allocate (x, source = t (['ab','cd'])) ! Didn't work
+ write(buffer(1), *) x%d(2:1:-1) ! Was found to be broken
+ write(buffer(2), *) [x%d(2:1:-1)] ! Was OK
+ associate (y => [x%d(2:1:-1)])
+ write(buffer(3), *) y ! Bug in comment 7
+ end associate
+ if (any (buffer .ne. " cdab")) stop 7
+ end
+
+ subroutine pr91941
+ character(:), allocatable :: x(:), z(:)
+ x = [' abc', ' xyz']
+ z = adjustl(x)
+ associate (y => adjustl(x)) ! Wrong character length was passed
+ if (any(y .ne. ['abc ', 'xyz '])) stop 8
+ end associate
+ end
+
+ subroutine pr92779
+ character(3) :: a = 'abc'
+ associate (y => spread(trim(a),1,2) // 'd')
+ if (any (y .ne. ['abcd','abcd'])) stop 9
+ end associate
+ end
+
+ subroutine pr93339
+ type t
+ character(:), allocatable :: a(:)
+ end type
+ type(t) :: x
+ x = t(["abc "]) ! Didn't assign anything
+! allocate (x%a(1), source = 'abc') ! Worked OK
+ associate (y => x%a)
+ if (any (y .ne. 'abc ')) stop 10
+ associate (z => x%a)
+ if (any (y .ne. z)) stop 11
+ end associate
+ end associate
+ end
+
+ subroutine pr93813
+ type t
+ end type
+ type, extends(t) :: t2
+ end type
+ class(t), allocatable :: x
+ integer :: i = 0
+ allocate (t :: x)
+ associate (y => (x)) ! The parentheses triggered an ICE in select type
+ select type (y)
+ type is (t2)
+ stop 12
+ type is (t)
+ i = 42
+ class default
+ stop 13
+ end select
+ end associate
+ if (i .ne. 42) stop 14
+ end
+end
! { dg-note {'b' declared here} {} { target *-*-* } .-1 }
!$acc update host(b(::2))
-! { dg-warning {'b\.dim\[0\]\.ubound' is used uninitialized} {} { target *-*-* } .-1 }
-! { dg-warning {'b\.dim\[0\]\.lbound' is used uninitialized} {} { target *-*-* } .-2 }
+! { dg-warning {'b\.span' is used uninitialized} {} { target *-*-* } .-1 }
+! { dg-warning {'b\.dim\[0\]\.ubound' is used uninitialized} {} { target *-*-* } .-2 }
+! { dg-warning {'b\.dim\[0\]\.lbound' is used uninitialized} {} { target *-*-* } .-3 }
!$acc update host(b(1)%A(::3,::4))
end
--- /dev/null
+! { dg-do run }
+!
+! Contributed by Rich Townsend <townsend@astro.wisc.edu>
+!
+program alloc_char_type
+ implicit none
+ integer, parameter :: start = 1, finish = 4
+ character(3) :: check(4)
+ type mytype
+ character(:), allocatable :: c(:)
+ end type mytype
+ type(mytype) :: a
+ type(mytype) :: b
+ integer :: i
+ a%c = ['foo','bar','biz','buz']
+ check = ['foo','bar','biz','buz']
+ b = a
+ do i = 1, size(b%c)
+ if (b%c(i) .ne. check(i)) stop 1
+ end do
+ if (any (a%c .ne. check)) stop 2
+ if (any (a%c(start:finish) .ne. check)) stop 3
+ deallocate (a%c)
+ deallocate (b%c)
+end
--- /dev/null
+! { dg-do run }
+!
+! Contributed by Lionel Guez <guez@lmd.ens.fr>
+!
+ character(len = :), allocatable:: attr_name(:)
+ character(6) :: buffer
+ type coord_def
+ character(len = :), allocatable:: attr_name(:)
+ end type coord_def
+ type(coord_def) coordinates
+ attr_name = ["units"]
+ write (buffer, *) attr_name
+ if (buffer .ne. " units") stop 1
+ coordinates = coord_def(attr_name)
+ write (buffer, *) coordinates%attr_name
+ if (buffer .ne. " units") stop 2
+ deallocate (attr_name)
+ deallocate (coordinates%attr_name)
+end
--- /dev/null
+! { dg-do run }
+!
+! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
+!
+program main
+ character (len=:), allocatable :: a(:)
+ allocate (character(len=10) :: a(5))
+ if (sizeof(a) .ne. 50) stop 1
+ deallocate (a)
+end program main
projects / platform / upstream / gcc.git / commitdiff