/* Array translation routines
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
- 2011, 2012
+ 2011, 2012, 2013
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
/* This provides WRITE access to the data field.
TUPLES_P is true if we are generating tuples.
-
+
This function gets called through the following macros:
gfc_conv_descriptor_data_set
gfc_conv_descriptor_data_set. */
return ss;
}
-
+
/* Creates and initializes a scalar type gfc_ss struct. */
/* Variables needed for bounds-checking. */
static bool first_len;
-static tree first_len_val;
+static tree first_len_val;
static bool typespec_chararray_ctor;
static void
if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
- {
+ {
first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
first_len = true;
}
if (expr->ts.type == BT_CHARACTER)
{
bool const_string;
-
+
/* get_array_ctor_strlen walks the elements of the constructor, if a
typespec was given, we already know the string length and want the one
specified there. */
gcc_assert (se->loop);
index = se->loop->loopvar[se->loop->order[i]];
- /* Pointer functions can have stride[0] different from unity.
+ /* Pointer functions can have stride[0] different from unity.
Use the stride returned by the function call and stored in
- the descriptor for the temporary. */
+ the descriptor for the temporary. */
if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
&& se->ss->info->expr
&& se->ss->info->expr->symtree
ts = &ref->u.c.component->ts;
class_ref = ref;
break;
- }
+ }
}
if (ts == NULL)
build_array_ref (tree desc, tree offset, tree decl)
{
tree tmp;
+ tree type;
- /* Class array references need special treatment because the assigned
- type size needs to be used to point to the element. */
+ /* Class container types do not always have the GFC_CLASS_TYPE_P
+ but the canonical type does. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
- && TREE_CODE (desc) == COMPONENT_REF
- && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
+ && TREE_CODE (desc) == COMPONENT_REF)
{
- tree type = gfc_get_element_type (TREE_TYPE (desc));
- tmp = TREE_OPERAND (desc, 0);
- tmp = gfc_get_class_array_ref (offset, tmp);
- tmp = fold_convert (build_pointer_type (type), tmp);
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ type = TREE_TYPE (TREE_OPERAND (desc, 0));
+ if (TYPE_CANONICAL (type)
+ && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
+ type = TYPE_CANONICAL (type);
}
else
+ type = NULL;
+
+ /* Class array references need special treatment because the assigned
+ type size needs to be used to point to the element. */
+ if (type && GFC_CLASS_TYPE_P (type))
{
- tmp = gfc_conv_array_data (desc);
+ type = gfc_get_element_type (TREE_TYPE (desc));
+ tmp = TREE_OPERAND (desc, 0);
+ tmp = gfc_get_class_array_ref (offset, tmp);
+ tmp = fold_convert (build_pointer_type (type), tmp);
tmp = build_fold_indirect_ref_loc (input_location, tmp);
- tmp = gfc_build_array_ref (tmp, offset, decl);
+ return tmp;
}
+ tmp = gfc_conv_array_data (desc);
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = gfc_build_array_ref (tmp, offset, decl);
return tmp;
}
-
/* Build an array reference. se->expr already holds the array descriptor.
This should be either a variable, indirect variable reference or component
reference. For arrays which do not have a descriptor, se->expr will be
tmp = tmpse.expr;
}
- cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
indexse.expr, tmp);
asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
"below lower bound of %%ld", n+1, sym->name);
stride_pos, stride_neg);
/* Check the start of the range against the lower and upper
- bounds of the array, if the range is not empty.
- If upper bound is present, include both bounds in the
+ bounds of the array, if the range is not empty.
+ If upper bound is present, include both bounds in the
error message. */
if (check_upper)
{
fold_convert (long_integer_type_node, lbound));
free (msg);
}
-
+
/* Compute the last element of the range, which is not
necessarily "end" (think 0:5:3, which doesn't contain 5)
and check it against both lower and upper bounds. */
gfc_trans_runtime_check (true, false, tmp2, &inner,
expr_loc, msg,
fold_convert (long_integer_type_node, tmp),
- fold_convert (long_integer_type_node, ubound),
+ fold_convert (long_integer_type_node, ubound),
fold_convert (long_integer_type_node, lbound));
gfc_trans_runtime_check (true, false, tmp3, &inner,
expr_loc, msg,
fold_convert (long_integer_type_node, tmp),
- fold_convert (long_integer_type_node, ubound),
+ fold_convert (long_integer_type_node, ubound),
fold_convert (long_integer_type_node, lbound));
free (msg);
}
ubound = lower[n];
}
}
- gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+ gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
gfc_rank_cst[n], se.expr);
conv_lbound = se.expr;
/* Check whether multiplying the stride by the number of
elements in this dimension would overflow. We must also check
whether the current dimension has zero size in order to avoid
- division by zero.
+ division by zero.
*/
- tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
- gfc_array_index_type,
- fold_convert (gfc_array_index_type,
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_array_index_type,
+ fold_convert (gfc_array_index_type,
TYPE_MAX_VALUE (gfc_array_index_type)),
size);
cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
*overflow, tmp);
*overflow = gfc_evaluate_now (tmp, pblock);
-
+
/* Multiply the stride by the number of elements in this dimension. */
stride = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, stride, size);
ubound = lower[n];
}
}
- gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+ gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
gfc_rank_cst[n], se.expr);
if (n < rank + corank - 1)
/* First check for overflow. Since an array of type character can
have zero element_size, we must check for that before
dividing. */
- tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
size_type_node,
TYPE_MAX_VALUE (size_type_node), element_size);
cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
{
cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, var_overflow, integer_zero_node));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
error, gfc_finish_block (&elseblock));
}
else
if (expr->ts.type == BT_CLASS)
{
tmp = build_int_cst (unsigned_char_type_node, 0);
- /* With class objects, it is best to play safe and null the
+ /* With class objects, it is best to play safe and null the
memory because we cannot know if dynamic types have allocatable
components or not. */
tmp = build_call_expr_loc (input_location,
/* Update the array descriptors. */
if (dimension)
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
-
+
set_descriptor = gfc_finish_block (&set_descriptor_block);
if (status != NULL_TREE)
{
gfc_add_expr_to_block (&se->pre,
fold_build3_loc (input_location, COND_EXPR, void_type_node,
gfc_likely (cond), set_descriptor,
- build_empty_stmt (input_location)));
+ build_empty_stmt (input_location)));
}
else
gfc_add_expr_to_block (&se->pre, set_descriptor);
/* A single scalar or derived type value. Create an array with all
elements equal to that value. */
gfc_init_se (&se, NULL);
-
+
if (expr->expr_type == EXPR_CONSTANT)
gfc_conv_constant (&se, expr);
else
tmp = gfc_conv_expr_present (sym);
stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
}
-
+
gfc_add_init_cleanup (block, stmt, NULL_TREE);
}
asprintf (&msg, "Dimension %d of array '%s' has extent "
"%%ld instead of %%ld", n+1, sym->name);
- gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
+ gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
fold_convert (long_integer_type_node, temp),
fold_convert (long_integer_type_node, stride2));
gfc_add_expr_to_block (&cleanup, tmp);
stmtCleanup = gfc_finish_block (&cleanup);
-
+
/* Only do the cleanup if the array was repacked. */
tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
tmp = gfc_conv_descriptor_data_get (tmp);
EXPR is the right-hand side of a pointer assignment and
se->expr is the descriptor for the previously-evaluated
left-hand side. The function creates an assignment from
- EXPR to se->expr.
+ EXPR to se->expr.
The se->force_tmp flag disables the non-copying descriptor optimization
return;
}
break;
-
+
case EXPR_FUNCTION:
/* A transformational function return value will be a temporary
array descriptor. We still need to go through the scalarizer
/* Vector subscripts need copying and are handled elsewhere. */
if (info->ref)
gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
-
+
/* look for the corresponding scalarizer dimension: dim. */
for (dim = 0; dim < ndim; dim++)
if (ss->dim[dim] == n)
if (!sym->attr.pointer
&& sym->as
- && sym->as->type != AS_ASSUMED_SHAPE
+ && sym->as->type != AS_ASSUMED_SHAPE
&& sym->as->type != AS_DEFERRED
- && sym->as->type != AS_ASSUMED_RANK
+ && sym->as->type != AS_ASSUMED_RANK
&& !sym->attr.allocatable)
{
/* Some variables are declared directly, others are declared as
&& expr->symtree->n.sym->attr.allocatable;
/* Or ultimate allocatable components. */
- ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
+ ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
{
tree
gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
-{
+{
tree tmp;
tree var;
stmtblock_t block;
tmp = gfc_conv_array_data (decl);
var = build_fold_indirect_ref_loc (input_location,
tmp);
-
+
/* Get the number of elements - 1 and set the counter. */
if (GFC_DESCRIPTOR_TYPE_P (decl_type))
{
/* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
-
+
/* Add reference to '_data' component. */
tmp = CLASS_DATA (c)->backend_decl;
comp = fold_build3_loc (input_location, COMPONENT_REF,
null_cond = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, src_data,
- null_pointer_node);
+ null_pointer_node);
gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
tmp, null_data));
as = NULL;
/* If the lhs shape is not the same as the rhs jump to setting the
- bounds and doing the reallocation....... */
+ bounds and doing the reallocation....... */
for (n = 0; n < expr1->rank; n++)
{
/* Check the shape. */
tmp = build3_v (COND_EXPR, cond,
build1_v (GOTO_EXPR, jump_label1),
build_empty_stmt (input_location));
- gfc_add_expr_to_block (&fblock, tmp);
+ gfc_add_expr_to_block (&fblock, tmp);
}
/* ....else jump past the (re)alloc code. */
tmp = build1_v (GOTO_EXPR, jump_label2);
gfc_add_expr_to_block (&fblock, tmp);
-
+
/* Add the label to start automatic (re)allocation. */
tmp = build1_v (LABEL_EXPR, jump_label1);
gfc_add_expr_to_block (&fblock, tmp);
unallocated allocatable variable, then it is allocated with each
deferred type parameter equal to the corresponding type parameters
of expr , with the shape of expr , and with each lower bound equal
- to the corresponding element of LBOUND(expr)."
+ to the corresponding element of LBOUND(expr)."
Reuse size1 to keep a dimension-by-dimension track of the
stride of the new array. */
size1 = gfc_index_one_node;
sym->backend_decl);
type = TREE_TYPE (descriptor);
}
-
+
/* NULLIFY the data pointer. */
if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
/* Backend support for Fortran 95 basic types and derived types.
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
- 2010, 2011, 2012
+ 2010, 2011, 2012, 2013
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
/* The kind size used for record offsets. If the target system supports
kind=8, this will be set to 8, otherwise it is set to 4. */
-int gfc_intio_kind;
+int gfc_intio_kind;
/* The integer kind used to store character lengths. */
int gfc_charlen_int_kind;
gfc_check_any_c_kind (gfc_typespec *ts)
{
int i;
-
+
for (i = 0; i < ISOCBINDING_NUMBER; i++)
{
/* Check for any C interoperable kind for the given type/kind in ts.
i_index += 1;
}
- /* Set the kind used to match GFC_INT_IO in libgfortran. This is
+ /* Set the kind used to match GFC_INT_IO in libgfortran. This is
used for large file access. */
if (saw_i8)
else
gfc_intio_kind = 4;
- /* If we do not at least have kind = 4, everything is pointless. */
- gcc_assert(saw_i4);
+ /* If we do not at least have kind = 4, everything is pointless. */
+ gcc_assert(saw_i4);
/* Set the maximum integer kind. Used with at least BOZ constants. */
gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
else
gfc_default_real_kind = gfc_real_kinds[0].kind;
- /* Choose the default double kind. If -fdefault-real and -fdefault-double
+ /* Choose the default double kind. If -fdefault-real and -fdefault-double
are specified, we use kind=8, if it's available. If -fdefault-real is
specified without -fdefault-double, we use kind=16, if it's available.
Otherwise we do not change anything. */
type = build_pointer_type (type);
if (restricted)
- type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
+ type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
GFC_ARRAY_TYPE_P (type) = 1;
- TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
+ TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
}
return type;
a derived type, we need a copy of its component declarations.
This is done by recursing into gfc_get_derived_type and
ensures that the component's component declarations have
- been built. If it is a character, we need the character
+ been built. If it is a character, we need the character
length, as well. */
for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
{
BT_INTEGER that needs to fit a void * for the purpose of the
iso_c_binding derived types. */
derived->ts.f90_type = BT_VOID;
-
+
return derived->backend_decl;
}
field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
ptr_mode, true);
+ /* Ensure that the CLASS language specific flag is set. */
+ if (c->ts.type == BT_CLASS)
+ {
+ if (POINTER_TYPE_P (field_type))
+ GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
+ else
+ GFC_CLASS_TYPE_P (field_type) = 1;
+ }
+
field = gfc_add_field_to_struct (typenode,
get_identifier (c->name),
field_type, &chain);
&& sym->ts.kind == gfc_default_real_kind
&& !sym->attr.always_explicit)
{
- /* Special case: f2c calling conventions require that (scalar)
+ /* Special case: f2c calling conventions require that (scalar)
default REAL functions return the C type double instead. f2c
compatibility is only an issue with functions that don't
require an explicit interface, as only these could be
--- /dev/null
+! { dg-do run }
+!
+! Tests the fixes for three bugs with the same underlying cause. All are regressions
+! that come about because class array elements end up with a different tree type
+! to the class array. In addition, the language specific flag that marks a class
+! container is not being set.
+!
+! PR53876 contributed by Prince Ogunbade <pogos77@hotmail.com>
+! PR54990 contributed by Janus Weil <janus@gcc.gnu.org>
+! PR54992 contributed by Tobias Burnus <burnus@gcc.gnu.org>
+! The two latter bugs were reported by Andrew Benson
+! starting at http://gcc.gnu.org/ml/fortran/2012-10/msg00087.html
+!
+module G_Nodes
+ type :: nc
+ type(tn), pointer :: hostNode
+ end type nc
+ type, extends(nc) :: ncBh
+ end type ncBh
+ type, public, extends(ncBh) :: ncBhStd
+ double precision :: massSeedData
+ end type ncBhStd
+ type, public :: tn
+ class (ncBh), allocatable, dimension(:) :: cBh
+ end type tn
+ type(ncBhStd) :: defaultBhC
+contains
+ subroutine Node_C_Bh_Move(targetNode)
+ implicit none
+ type (tn ), intent(inout) , target :: targetNode
+ class(ncBh), allocatable , dimension(:) :: instancesTemporary
+! These two lines resulted in the wrong result:
+ allocate(instancesTemporary(2),source=defaultBhC)
+ call Move_Alloc(instancesTemporary,targetNode%cBh)
+! These two lines gave the correct result:
+!!deallocate(targetNode%cBh)
+!!allocate(targetNode%cBh(2))
+ targetNode%cBh(1)%hostNode => targetNode
+ targetNode%cBh(2)%hostNode => targetNode
+ return
+ end subroutine Node_C_Bh_Move
+ function bhGet(self,instance)
+ implicit none
+ class (ncBh), pointer :: bhGet
+ class (tn ), intent(inout), target :: self
+ integer , intent(in ) :: instance
+ bhGet => self%cBh(instance)
+ return
+ end function bhGet
+end module G_Nodes
+
+ call pr53876
+ call pr54990
+ call pr54992
+end
+
+subroutine pr53876
+ IMPLICIT NONE
+ TYPE :: individual
+ integer :: icomp ! Add an extra component to test offset
+ REAL, DIMENSION(:), ALLOCATABLE :: genes
+ END TYPE
+ CLASS(individual), DIMENSION(:), ALLOCATABLE :: indv
+ allocate (indv(2), source = [individual(1, [99,999]), &
+ individual(2, [999,9999])])
+ CALL display_indv(indv(2)) ! Similarly, reference 2nd element to test offset
+CONTAINS
+ SUBROUTINE display_indv(self)
+ CLASS(individual), INTENT(IN) :: self
+ if (any(self%genes .ne. [999,9999]) )call abort
+ END SUBROUTINE
+END
+
+subroutine pr54990
+ implicit none
+ type :: ncBhStd
+ integer :: i
+ end type
+ type, extends(ncBhStd) :: ncBhStde
+ integer :: i2(2)
+ end type
+ type :: tn
+ integer :: i ! Add an extra component to test offset
+ class (ncBhStd), allocatable, dimension(:) :: cBh
+ end type
+ integer :: i
+ type(tn), target :: a
+ allocate (a%cBh(2), source = [(ncBhStde(i*99, [1,2]), i = 1,2)])
+ select type (q => a%cBh(2)) ! Similarly, reference 2nd element to test offset
+ type is (ncBhStd)
+ call abort
+ type is (ncBhStde)
+ if (q%i .ne. 198) call abort ! This tests that the component really gets the
+ end select ! language specific flag denoting a class type
+end
+
+subroutine pr54992 ! This test remains as the original.
+ use G_Nodes
+ implicit none
+ type (tn), target :: b
+ class(ncBh), pointer :: bh
+ class(ncBh), allocatable, dimension(:) :: t
+ allocate(b%cBh(1),source=defaultBhC)
+ b%cBh(1)%hostNode => b
+! #1 this worked
+ if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
+ call Node_C_Bh_Move(b)
+! #2 this worked
+ if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
+ if (loc(b) .ne. loc(b%cBh(2)%hostNode)) call abort
+! #3 this did not
+ bh => bhGet(b,instance=1)
+ if (loc (b) .ne. loc(bh%hostNode)) call abort
+ bh => bhGet(b,instance=2)
+ if (loc (b) .ne. loc(bh%hostNode)) call abort
+end
projects / platform / upstream / gcc.git / commitdiff