2010-06-18 Tobias Burnus <burnus@net-b.de>
PR fortran/40632
* interface.c (compare_parameter): Add gfc_is_simply_contiguous
checks.
* symbol.c (gfc_add_contiguous): New function.
(gfc_copy_attr, check_conflict): Handle contiguous attribute.
* decl.c (match_attr_spec): Ditto.
(gfc_match_contiguous): New function.
* resolve.c (resolve_fl_derived, resolve_symbol): Handle
contiguous.
* gfortran.h (symbol_attribute): Add contiguous.
(gfc_is_simply_contiguous): Add prototype.
(gfc_add_contiguous): Add prototype.
* match.h (gfc_match_contiguous): Add prototype.
* parse.c (decode_specification_statement,
decode_statement): Handle contiguous attribute.
* expr.c (gfc_is_simply_contiguous): New function.
* dump-parse-tree.c (show_attr): Handle contiguous.
* module.c (ab_attribute, attr_bits, mio_symbol_attribute):
Ditto.
* trans-expr.c (gfc_add_interface_mapping): Copy
attr.contiguous.
* trans-array.c (gfc_conv_descriptor_stride_get,
gfc_conv_array_parameter): Handle contiguous arrays.
* trans-types.c (gfc_build_array_type, gfc_build_array_type,
gfc_sym_type, gfc_get_derived_type, gfc_get_array_descr_info):
Ditto.
* trans.h (gfc_array_kind): Ditto.
* trans-decl.c (gfc_get_symbol_decl): Ditto.
2010-06-18 Tobias Burnus <burnus@net-b.de>
PR fortran/40632
* gfortran.dg/contiguous_1.f90: New.
* gfortran.dg/contiguous_2.f90: New.
* gfortran.dg/contiguous_3.f90: New.
===================================================================
@@ -1435,6 +1435,16 @@ compare_parameter (gfc_symbol *formal, g
return 1;
}
+ /* F2008, C1241. */
+ if (formal->attr.pointer && formal->attr.contiguous
+ && !gfc_is_simply_contiguous (actual, true))
+ {
+ if (where)
+ gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
+ "must be simply contigous", formal->name, &actual->where);
+ return 0;
+ }
+
if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
&& !gfc_compare_types (&formal->ts, &actual->ts))
{
@@ -1502,6 +1512,34 @@ compare_parameter (gfc_symbol *formal, g
: actual->symtree->n.sym->as->corank);
return 0;
}
+
+ /* F2008, 12.5.2.8. */
+ if (formal->attr.dimension
+ && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
+ && !gfc_is_simply_contiguous (actual, true))
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be simply "
+ "contiguous", formal->name, &actual->where);
+ return 0;
+ }
+ }
+
+ /* F2008, C1239/C1240. */
+ if (actual->expr_type == EXPR_VARIABLE
+ && (actual->symtree->n.sym->attr.asynchronous
+ || actual->symtree->n.sym->attr.volatile_)
+ && (formal->attr.asynchronous || formal->attr.volatile_)
+ && actual->rank && !gfc_is_simply_contiguous (actual, true)
+ && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
+ || formal->attr.contiguous))
+ {
+ if (where)
+ gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
+ "array without CONTIGUOUS attribute as actual argument at "
+ "%L is not not simply contiguous and both are ASYNCHRONOUS "
+ "or VOLATILE", formal->name, &actual->where);
+ return 0;
}
if (symbol_rank (formal) == actual->rank)
===================================================================
@@ -1718,6 +1718,7 @@ gfc_add_interface_mapping (gfc_interface
new_sym->as = gfc_copy_array_spec (sym->as);
new_sym->attr.referenced = 1;
new_sym->attr.dimension = sym->attr.dimension;
+ new_sym->attr.contiguous = sym->attr.contiguous;
new_sym->attr.codimension = sym->attr.codimension;
new_sym->attr.pointer = sym->attr.pointer;
new_sym->attr.allocatable = sym->attr.allocatable;
===================================================================
@@ -285,7 +285,9 @@ gfc_conv_descriptor_stride_get (tree des
tree type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
if (integer_zerop (dim)
- && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+ && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
+ ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+ ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
return gfc_index_one_node;
return gfc_conv_descriptor_stride (desc, dim);
@@ -5515,6 +5517,7 @@ gfc_conv_array_parameter (gfc_se * se, g
bool array_constructor;
bool good_allocatable;
bool ultimate_ptr_comp;
+ bool ultimate_contiguous;
bool ultimate_alloc_comp;
gfc_symbol *sym;
stmtblock_t block;
@@ -5522,6 +5525,10 @@ gfc_conv_array_parameter (gfc_se * se, g
ultimate_ptr_comp = false;
ultimate_alloc_comp = false;
+ ultimate_contiguous = (expr->expr_type == EXPR_VARIABLE
+ || expr->expr_type == EXPR_FUNCTION)
+ ? expr->symtree->n.sym->attr.contiguous : false;
+
for (ref = expr->ref; ref; ref = ref->next)
{
if (ref->next == NULL)
@@ -5530,6 +5537,7 @@ gfc_conv_array_parameter (gfc_se * se, g
if (ref->type == REF_COMPONENT)
{
ultimate_ptr_comp = ref->u.c.component->attr.pointer;
+ ultimate_contiguous = ref->u.c.component->attr.contiguous;
ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
}
}
@@ -5608,7 +5616,7 @@ gfc_conv_array_parameter (gfc_se * se, g
contiguous = g77 && !this_array_result && contiguous;
/* There is no need to pack and unpack the array, if it is contiguous
- and not deferred or assumed shape. */
+ and not a non-CONTIGUOUS deferred- or assumed-shape array. */
no_pack = ((sym && sym->as
&& !sym->attr.pointer
&& sym->as->type != AS_DEFERRED
@@ -5616,7 +5624,9 @@ gfc_conv_array_parameter (gfc_se * se, g
||
(ref && ref->u.ar.as
&& ref->u.ar.as->type != AS_DEFERRED
- && ref->u.ar.as->type != AS_ASSUMED_SHAPE));
+ && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
+ ||
+ ultimate_contiguous);
no_pack = contiguous && no_pack;
===================================================================
@@ -372,7 +372,8 @@ check_conflict (symbol_attribute *attr,
*cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
*volatile_ = "VOLATILE", *is_protected = "PROTECTED",
*is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
- *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION";
+ *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
+ *contiguous = "CONTIGUOUS";
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
@@ -518,6 +519,7 @@ check_conflict (symbol_attribute *attr,
conf (cray_pointer, cray_pointee);
conf (cray_pointer, dimension);
conf (cray_pointer, codimension);
+ conf (cray_pointer, contiguous);
conf (cray_pointer, pointer);
conf (cray_pointer, target);
conf (cray_pointer, allocatable);
@@ -529,6 +531,7 @@ check_conflict (symbol_attribute *attr,
conf (cray_pointer, entry);
conf (cray_pointee, allocatable);
+ conf (cray_pointer, contiguous);
conf (cray_pointer, codimension);
conf (cray_pointee, intent);
conf (cray_pointee, optional);
@@ -613,6 +616,7 @@ check_conflict (symbol_attribute *attr,
conf2 (dummy);
conf2 (volatile_);
conf2 (asynchronous);
+ conf2 (contiguous);
conf2 (pointer);
conf2 (is_protected);
conf2 (target);
@@ -720,6 +724,7 @@ check_conflict (symbol_attribute *attr,
conf2 (function);
conf2 (subroutine);
conf2 (entry);
+ conf2 (contiguous);
conf2 (pointer);
conf2 (is_protected);
conf2 (target);
@@ -928,6 +933,18 @@ gfc_add_dimension (symbol_attribute *att
gfc_try
+gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return FAILURE;
+
+ attr->contiguous = 1;
+ return check_conflict (attr, name, where);
+}
+
+
+gfc_try
gfc_add_external (symbol_attribute *attr, locus *where)
{
@@ -1715,6 +1732,8 @@ gfc_copy_attr (symbol_attribute *dest, s
goto fail;
if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
goto fail;
+ if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE)
+ goto fail;
if (src->optional && gfc_add_optional (dest, where) == FAILURE)
goto fail;
if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
===================================================================
@@ -2875,8 +2875,8 @@ match_attr_spec (void)
DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
- DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_NONE,
- GFC_DECL_END /* Sentinel */
+ DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
+ DECL_NONE, GFC_DECL_END /* Sentinel */
}
decl_types;
@@ -2939,6 +2939,7 @@ match_attr_spec (void)
}
break;
}
+ break;
case 'b':
/* Try and match the bind(c). */
@@ -2950,8 +2951,24 @@ match_attr_spec (void)
break;
case 'c':
- if (match_string_p ("codimension"))
- d = DECL_CODIMENSION;
+ gfc_next_ascii_char ();
+ if ('o' != gfc_next_ascii_char ())
+ break;
+ switch (gfc_next_ascii_char ())
+ {
+ case 'd':
+ if (match_string_p ("imension"))
+ {
+ d = DECL_CODIMENSION;
+ break;
+ }
+ case 'n':
+ if (match_string_p ("tiguous"))
+ {
+ d = DECL_CONTIGUOUS;
+ break;
+ }
+ }
break;
case 'd':
@@ -3144,6 +3161,9 @@ match_attr_spec (void)
case DECL_CODIMENSION:
attr = "CODIMENSION";
break;
+ case DECL_CONTIGUOUS:
+ attr = "CONTIGUOUS";
+ break;
case DECL_DIMENSION:
attr = "DIMENSION";
break;
@@ -3214,7 +3234,7 @@ match_attr_spec (void)
if (gfc_current_state () == COMP_DERIVED
&& d != DECL_DIMENSION && d != DECL_CODIMENSION
&& d != DECL_POINTER && d != DECL_PRIVATE
- && d != DECL_PUBLIC && d != DECL_NONE)
+ && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
{
if (d == DECL_ALLOCATABLE)
{
@@ -3283,6 +3303,15 @@ match_attr_spec (void)
t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
break;
+ case DECL_CONTIGUOUS:
+ if (gfc_notify_std (GFC_STD_F2008,
+ "Fortran 2008: CONTIGUOUS attribute at %C")
+ == FAILURE)
+ t = FAILURE;
+ else
+ t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
+ break;
+
case DECL_DIMENSION:
t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
break;
@@ -6118,6 +6147,20 @@ gfc_match_codimension (void)
return attr_decl ();
}
+
+
+match
+gfc_match_contiguous (void)
+{
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTIGUOUS statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ gfc_clear_attr (¤t_attr);
+ current_attr.contiguous = 1;
+
+ return attr_decl ();
+}
match
===================================================================
@@ -598,6 +598,8 @@ show_attr (symbol_attribute *attr)
fputs (" CODIMENSION", dumpfile);
if (attr->dimension)
fputs (" DIMENSION", dumpfile);
+ if (attr->contiguous)
+ fputs (" CONTIGUOUS", dumpfile);
if (attr->external)
fputs (" EXTERNAL", dumpfile);
if (attr->intrinsic)
===================================================================
@@ -665,7 +665,8 @@ typedef struct
unsigned allocatable:1, dimension:1, codimension:1, external:1, intrinsic:1,
optional:1, pointer:1, target:1, value:1, volatile_:1, temporary:1,
dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
- implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1;
+ implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1,
+ contiguous:1;
/* For CLASS containers, the pointer attribute is sometimes set internally
even though it was not directly specified. In this case, keep the
@@ -2437,6 +2438,7 @@ gfc_try gfc_add_attribute (symbol_attrib
gfc_try gfc_add_ext_attribute (symbol_attribute *, ext_attr_id_t, locus *);
gfc_try gfc_add_allocatable (symbol_attribute *, locus *);
gfc_try gfc_add_codimension (symbol_attribute *, const char *, locus *);
+gfc_try gfc_add_contiguous (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_dimension (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_external (symbol_attribute *, locus *);
gfc_try gfc_add_intrinsic (symbol_attribute *, locus *);
@@ -2614,6 +2616,7 @@ void gfc_free_actual_arglist (gfc_actual
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
const char *gfc_extract_int (gfc_expr *, int *);
bool is_subref_array (gfc_expr *);
+bool gfc_is_simply_contiguous (gfc_expr *, bool);
gfc_expr *gfc_build_conversion (gfc_expr *);
void gfc_free_ref_list (gfc_ref *);
===================================================================
@@ -4080,3 +4080,95 @@ gfc_has_ultimate_pointer (gfc_expr *e)
else
return false;
}
+
+
+/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
+ Note: A scalar is not regarded as "simply contiguous" by the standard.
+ if bool is not strict, some futher checks are done - for instance,
+ a "(::1)" is accepted. */
+
+bool
+gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
+{
+ bool colon;
+ int i;
+ gfc_array_ref *ar = NULL;
+ gfc_ref *ref, *part_ref = NULL;
+
+ if (expr->expr_type == EXPR_FUNCTION)
+ return expr->symtree->n.sym->result->attr.contiguous;
+ else if (expr->expr_type != EXPR_VARIABLE)
+ return false;
+
+ if (expr->rank == 0)
+ return false;
+
+ for (ref = expr->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT)
+ part_ref = ref;
+ else if (ref->type == REF_SUBSTRING)
+ return false;
+ else
+ {
+ if (ar)
+ return false; /* Array shall be last part-ref. */
+ if (ref->u.ar.type != AR_ELEMENT)
+ ar = &ref->u.ar;
+ }
+ }
+
+ if ((part_ref && !part_ref->u.c.component->attr.contiguous
+ && part_ref->u.c.component->attr.pointer)
+ || (!part_ref && !expr->symtree->n.sym->attr.contiguous
+ && (expr->symtree->n.sym->attr.pointer
+ || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)))
+ return false;
+
+ if (!ar || ar->type == AR_FULL)
+ return true;
+
+ gcc_assert (ar->type != AR_UNKNOWN);
+
+ /* Check for simply contiguous array */
+ colon = true;
+ for (i = 0; i < ar->dimen; i++)
+ {
+ gcc_assert (ar->dimen_type[i] != DIMEN_UNKNOWN);
+
+ if (ar->dimen_type[i] == DIMEN_VECTOR)
+ return false;
+
+ /* Element or section. Following the standard, "(::1)" or - if known at
+ compile time - "(lbound:ubound)" are not simply contigous; if strict
+ is false, they are regarded as simple contiguous. */
+
+ if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
+ || ar->stride[i]->ts.type != BT_INTEGER
+ || mpz_cmp_si (expr->value.integer, 1) != 0))
+ return false;
+
+ if (ar->start[i]
+ && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
+ || ar->as->lower[i]->expr_type != EXPR_CONSTANT
+ || mpz_cmp (ar->start[i]->value.integer,
+ ar->as->lower[i]->value.integer) != 0))
+ {
+ if (!colon)
+ return false;
+ colon = false;
+ }
+ if (ar->end[i]
+ && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
+ || ar->as->upper[i]->expr_type != EXPR_CONSTANT
+ || mpz_cmp (ar->end[i]->value.integer,
+ ar->as->upper[i]->value.integer) != 0))
+ {
+ if (!colon)
+ return false;
+ colon = false;
+ }
+ }
+
+ return true;
+}
===================================================================
@@ -1675,7 +1675,7 @@ typedef enum
AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
- AB_COARRAY_COMP, AB_VTYPE, AB_VTAB
+ AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS
}
ab_attribute;
@@ -1685,6 +1685,7 @@ static const mstring attr_bits[] =
minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
minit ("DIMENSION", AB_DIMENSION),
minit ("CODIMENSION", AB_CODIMENSION),
+ minit ("CONTIGUOUS", AB_CONTIGUOUS),
minit ("EXTERNAL", AB_EXTERNAL),
minit ("INTRINSIC", AB_INTRINSIC),
minit ("OPTIONAL", AB_OPTIONAL),
@@ -1807,6 +1808,8 @@ mio_symbol_attribute (symbol_attribute *
MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
if (attr->codimension)
MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
+ if (attr->contiguous)
+ MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
if (attr->external)
MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
if (attr->intrinsic)
@@ -1915,6 +1918,9 @@ mio_symbol_attribute (symbol_attribute *
case AB_CODIMENSION:
attr->codimension = 1;
break;
+ case AB_CONTIGUOUS:
+ attr->contiguous = 1;
+ break;
case AB_EXTERNAL:
attr->external = 1;
break;
===================================================================
@@ -1202,7 +1202,8 @@ gfc_is_nodesc_array (gfc_symbol * sym)
static tree
gfc_build_array_type (tree type, gfc_array_spec * as,
- enum gfc_array_kind akind, bool restricted)
+ enum gfc_array_kind akind, bool restricted,
+ bool contiguous)
{
tree lbound[GFC_MAX_DIMENSIONS];
tree ubound[GFC_MAX_DIMENSIONS];
@@ -1219,7 +1220,8 @@ gfc_build_array_type (tree type, gfc_arr
}
if (as->type == AS_ASSUMED_SHAPE)
- akind = GFC_ARRAY_ASSUMED_SHAPE;
+ akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
+ : GFC_ARRAY_ASSUMED_SHAPE;
return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound,
ubound, 0, akind, restricted);
}
@@ -1799,10 +1801,12 @@ gfc_sym_type (gfc_symbol * sym)
{
enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
if (sym->attr.pointer)
- akind = GFC_ARRAY_POINTER;
+ akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT
+ : GFC_ARRAY_POINTER;
else if (sym->attr.allocatable)
akind = GFC_ARRAY_ALLOCATABLE;
- type = gfc_build_array_type (type, sym->as, akind, restricted);
+ type = gfc_build_array_type (type, sym->as, akind, restricted,
+ sym->attr.contiguous);
}
}
else
@@ -2121,14 +2125,16 @@ gfc_get_derived_type (gfc_symbol * deriv
{
enum gfc_array_kind akind;
if (c->attr.pointer)
- akind = GFC_ARRAY_POINTER;
+ akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
+ : GFC_ARRAY_POINTER;
else
akind = GFC_ARRAY_ALLOCATABLE;
/* Pointers to arrays aren't actually pointer types. The
descriptors are separate, but the data is common. */
field_type = gfc_build_array_type (field_type, c->as, akind,
!c->attr.target
- && !c->attr.pointer);
+ && !c->attr.pointer,
+ c->attr.contiguous);
}
else
field_type = gfc_get_nodesc_array_type (field_type, c->as,
@@ -2516,7 +2522,8 @@ gfc_get_array_descr_info (const_tree typ
if (int_size_in_bytes (etype) <= 0)
return false;
/* Nor non-constant lower bounds in assumed shape arrays. */
- if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
+ if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
{
for (dim = 0; dim < rank; dim++)
if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
@@ -2565,7 +2572,8 @@ gfc_get_array_descr_info (const_tree typ
if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
info->allocated = build2 (NE_EXPR, boolean_type_node,
info->data_location, null_pointer_node);
- else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER)
+ else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
info->associated = build2 (NE_EXPR, boolean_type_node,
info->data_location, null_pointer_node);
@@ -2579,7 +2587,8 @@ gfc_get_array_descr_info (const_tree typ
size_binop (PLUS_EXPR, dim_off, upper_suboff));
t = build1 (INDIRECT_REF, gfc_array_index_type, t);
info->dimen[dim].upper_bound = t;
- if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
+ if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
{
/* Assumed shape arrays have known lower bounds. */
info->dimen[dim].upper_bound
===================================================================
@@ -620,14 +620,17 @@ extern GTY(()) tree gfor_fndecl_sr_kind;
/* True if node is an integer constant. */
#define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST)
-/* G95-specific declaration information. */
+/* gfortran-specific declaration information, the _CONT versions denote
+ arrays with CONTIGUOUS attribute. */
enum gfc_array_kind
{
GFC_ARRAY_UNKNOWN,
GFC_ARRAY_ASSUMED_SHAPE,
+ GFC_ARRAY_ASSUMED_SHAPE_CONT,
GFC_ARRAY_ALLOCATABLE,
- GFC_ARRAY_POINTER
+ GFC_ARRAY_POINTER,
+ GFC_ARRAY_POINTER_CONT
};
/* Array types only. */
===================================================================
@@ -10826,6 +10826,14 @@ resolve_fl_derived (gfc_symbol *sym)
return FAILURE;
}
+ /* F2008, C448. */
+ if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
+ {
+ gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
+ "is not an array pointer", c->name, &c->loc);
+ return FAILURE;
+ }
+
if (c->attr.proc_pointer && c->ts.interface)
{
if (c->ts.interface->attr.procedure && !sym->attr.vtype)
@@ -11397,6 +11405,7 @@ resolve_symbol (gfc_symbol *sym)
sym->attr.pure = ifc->attr.pure;
sym->attr.elemental = ifc->attr.elemental;
sym->attr.dimension = ifc->attr.dimension;
+ sym->attr.contiguous = ifc->attr.contiguous;
sym->attr.recursive = ifc->attr.recursive;
sym->attr.always_explicit = ifc->attr.always_explicit;
sym->attr.ext_attr |= ifc->attr.ext_attr;
@@ -11442,6 +11451,18 @@ resolve_symbol (gfc_symbol *sym)
return;
}
+
+ /* F2008, C530. */
+ if (sym->attr.contiguous
+ && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE
+ && !sym->attr.pointer)))
+ {
+ gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
+ "array pointer or an assumed-shape array", sym->name,
+ &sym->declared_at);
+ return;
+ }
+
if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
return;
@@ -11500,6 +11521,7 @@ resolve_symbol (gfc_symbol *sym)
sym->attr.dimension = sym->result->attr.dimension;
sym->attr.pointer = sym->result->attr.pointer;
sym->attr.allocatable = sym->result->attr.allocatable;
+ sym->attr.contiguous = sym->result->attr.contiguous;
}
}
}
===================================================================
@@ -1213,7 +1213,8 @@ gfc_get_symbol_decl (gfc_symbol * sym)
/* Create variables to hold the non-constant bits of array info. */
gfc_build_qualified_array (decl, sym);
- if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
+ if (sym->attr.contiguous
+ || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
GFC_DECL_PACKED_ARRAY (decl) = 1;
}
===================================================================
@@ -168,6 +168,7 @@ void gfc_set_constant_character_len (int
match gfc_match_allocatable (void);
match gfc_match_asynchronous (void);
match gfc_match_codimension (void);
+match gfc_match_contiguous (void);
match gfc_match_dimension (void);
match gfc_match_external (void);
match gfc_match_gcc_attributes (void);
===================================================================
@@ -139,6 +139,7 @@ decode_specification_statement (void)
case 'c':
match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
+ match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
break;
case 'd':
@@ -346,6 +347,7 @@ decode_statement (void)
match ("call", gfc_match_call, ST_CALL);
match ("close", gfc_match_close, ST_CLOSE);
match ("continue", gfc_match_continue, ST_CONTINUE);
+ match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
match ("cycle", gfc_match_cycle, ST_CYCLE);
match ("case", gfc_match_case, ST_CASE);
match ("common", gfc_match_common, ST_COMMON);
===================================================================
@@ -1588,4 +1588,3 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref
return fin_dep == GFC_DEP_OVERLAP;
}
-
===================================================================
@@ -43,3 +43,4 @@ int gfc_expr_is_one (gfc_expr *, int);
int gfc_dep_resolver(gfc_ref *, gfc_ref *);
int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *);
+
===================================================================
@@ -0,0 +1,165 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/40632
+!
+! CONTIGUOUS compile-time tests
+!
+
+! C448: Must be an array with POINTER attribute
+type t1
+ integer, contiguous :: ca(5) ! { dg-error "Component .ca. at .1. has the CONTIGUOUS" }
+end type t1
+type t2
+ integer, contiguous, allocatable :: cb(:) ! { dg-error "Component .cb. at .1. has the CONTIGUOUS" }
+end type t2
+type t3
+ integer, contiguous, pointer :: cc(:) ! OK
+end type t3
+type t4
+ integer, pointer, contiguous :: cd ! { dg-error "Component .cd. at .1. has the CONTIGUOUS" }
+end type t4
+end
+
+! C530: Must be an array and (a) a POINTER or (b) assumed shape.
+subroutine test(x, y)
+ integer, pointer :: x(:)
+ integer, intent(in) :: y(:)
+ contiguous :: x, y
+
+ integer, contiguous :: a(5) ! { dg-error ".a. at .1. has the CONTIGUOUS attribute" }
+ integer, contiguous, allocatable :: b(:) ! { dg-error ".b. at .1. has the CONTIGUOUS attribute" }
+ integer, contiguous, pointer :: c(:) ! OK
+ integer, pointer, contiguous :: d ! { dg-error ".d. at .1. has the CONTIGUOUS attribute" }
+end
+
+! Pointer assignment check:
+! If the pointer object has the CONTIGUOUS attribute, the pointer target shall be contiguous.
+! Note: This is not compile-time checkable; but F2008, 5.3.7 except in a very few cases.
+subroutine ptr_assign()
+ integer, pointer, contiguous :: ptr1(:)
+ integer, target :: tgt(5)
+ ptr1 => tgt
+end subroutine
+
+
+! C1239 (R1223) If an actual argument is a nonpointer array that has the ASYNCHRONOUS or VOLATILE
+! attribute but is not simply contiguous (6.5.4), and the corresponding dummy argument has either the
+! VOLATILE or ASYNCHRONOUS attribute, that dummy argument shall be an assumed-shape array
+! that does not have the CONTIGUOUS attribute.
+
+subroutine C1239
+ type t
+ integer :: e(4)
+ end type t
+ type(t), volatile :: f
+ integer, asynchronous :: a(4), b(4)
+ integer, volatile :: c(4), d(4)
+ call test (a,b,c) ! OK
+ call test (a,b(::2),c) ! { dg-error "array without CONTIGUOUS" }
+ call test (a(::2),b,c) ! { dg-error "array without CONTIGUOUS" }
+
+ call test (a,b,f%e) ! OK
+ call test (a,f%e,c) ! OK
+ call test (f%e,b,c) ! OK
+ call test (a,b,f%e(::2)) ! OK
+ call test (a,f%e(::2),c) ! { dg-error "array without CONTIGUOUS" }
+ call test (f%e(::2),b,c) ! { dg-error "array without CONTIGUOUS" }
+contains
+ subroutine test(u, v, w)
+ integer, asynchronous :: u(:), v(*)
+ integer, volatile :: w(:)
+ contiguous :: u
+ end subroutine test
+end subroutine C1239
+
+
+! C1240 (R1223) If an actual argument is an array pointer that has the ASYNCHRONOUS or VOLATILE
+! attribute but does not have the CONTIGUOUS attribute, and the corresponding dummy argument has
+! either the VOLATILE or ASYNCHRONOUS attribute, that dummy argument shall be an array pointer
+! or an assumed-shape array that does not have the CONTIGUOUS attribute.
+
+subroutine C1240
+ type t
+ integer,pointer :: e(:)
+ end type t
+ type(t), volatile :: f
+ integer, pointer, asynchronous :: a(:), b(:)
+ integer,pointer, volatile :: c(:), d(:)
+ call test (a,b,c) ! { dg-error "array without CONTIGUOUS" }
+ call test (a,b(::2),c) ! { dg-error "array without CONTIGUOUS" }
+ call test (a(::2),b,c) ! { dg-error "array without CONTIGUOUS" }
+
+ call test (a,b,f%e) ! { dg-error "array without CONTIGUOUS" }
+ call test (a,f%e,c) ! { dg-error "array without CONTIGUOUS" }
+ call test (f%e,b,c) ! { dg-error "array without CONTIGUOUS" }
+ call test (a,b,f%e(::2)) ! { dg-error "array without CONTIGUOUS" }
+ call test (a,f%e(::2),c) ! { dg-error "array without CONTIGUOUS" }
+ call test (f%e(::2),b,c) ! { dg-error "array without CONTIGUOUS" }
+
+ call test2(a,b)
+ call test3(a,b)
+ call test2(c,d)
+ call test3(c,d)
+ call test2(f%e,d)
+ call test3(c,f%e)
+contains
+ subroutine test(u, v, w)
+ integer, asynchronous :: u(:), v(*)
+ integer, volatile :: w(:)
+ contiguous :: u
+ end subroutine test
+ subroutine test2(x,y)
+ integer, asynchronous :: x(:)
+ integer, volatile :: y(:)
+ end subroutine test2
+ subroutine test3(x,y)
+ integer, pointer, asynchronous :: x(:)
+ integer, pointer, volatile :: y(:)
+ end subroutine test3
+end subroutine C1240
+
+
+
+! 12.5.2.7 Pointer dummy variables
+! C1241 The actual argument corresponding to a dummy pointer with the CONTIGUOUS attribute shall be
+! simply contiguous (6.5.4).
+
+subroutine C1241
+ integer, pointer, contiguous :: a(:)
+ integer, pointer :: b(:)
+ call test(a)
+ call test(b) ! { dg-error "must be simply contigous" }
+contains
+ subroutine test(x)
+ integer, pointer, contiguous :: x(:)
+ end subroutine test
+end subroutine C1241
+
+
+! 12.5.2.8 Coarray dummy variables
+! If the dummy argument is an array coarray that has the CONTIGUOUS attribute or is not of assumed shape,
+! the corresponding actual argument shall be simply contiguous
+
+subroutine sect12528(cob)
+ integer, save :: coa(6)[*]
+ integer :: cob(:)[*]
+
+ call test(coa)
+ call test2(coa)
+ call test3(coa)
+
+ call test(cob) ! { dg-error "must be simply contiguous" }
+ call test2(cob) ! { dg-error "must be simply contiguous" }
+ call test3(cob)
+contains
+ subroutine test(x)
+ integer, contiguous :: x(:)[*]
+ end subroutine test
+ subroutine test2(x)
+ integer :: x(*)[*]
+ end subroutine test2
+ subroutine test3(x)
+ integer :: x(:)[*]
+ end subroutine test3
+end subroutine sect12528
===================================================================
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! PR fortran/40632
+!
+! CONTIGUOUS compile-time tests
+!
+
+integer, pointer, contiguous :: a(:) ! { dg-error "Fortran 2008:" }
+integer, pointer :: b(:)
+contiguous :: b ! { dg-error "Fortran 2008:" }
+end
===================================================================
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/40632
+!
+! CONTIGUOUS compile-time tests: Check that contigous
+! works properly.
+
+subroutine t(a,b)
+ integer, pointer, contiguous :: a(:)
+ call foo(a)
+ call foo(a(::1))
+ call foo(a(::2))
+contains
+ subroutine foo(b)
+ integer :: b(*)
+ end subroutine foo
+end subroutine t
+
+subroutine t2(a1,b1,c2,d2)
+ integer, pointer, contiguous :: a1(:), b1(:)
+ integer, pointer :: c2(:), d2(:)
+ a1 = b1
+ c2 = d2
+end subroutine t2
+
+! { dg-final { scan-tree-dump-times "_internal_pack" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_internal_unpack" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "= a1->dim.0..stride;" 0 "original" } }
+! { dg-final { scan-tree-dump-times "= b1->dim.0..stride;" 0 "original" } }
+! { dg-final { scan-tree-dump-times "= c2->dim.0..stride;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "= d2->dim.0..stride;" 1 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }