* [Patch,Fortran] PR 40632 - Add CONTIGUOUS attribute (part 1)
@ 2010-06-18 16:52 Tobias Burnus
2010-06-19 3:57 ` Tobias Burnus
0 siblings, 1 reply; 7+ messages in thread
From: Tobias Burnus @ 2010-06-18 16:52 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 2225 bytes --]
In Fortran, one does not know whether one should use assumed-shape
dummies -- such that
calls assumed_shape_sub (array)
passes the array descriptor, but in "assumed_shape_sub" one needs to
assume that the strides are not one.
Or, whether is it better, in terms of performance, to use
explicit-/assumed-size arrays -- such that for
calls explicit_size_sub (size(array),array)
one passes a contiguous array (with stride == 1), but before the call a
check has to be inserted whether the array is contiguous - and, if not,
copy-in/copy-out has to be done.
Which of the two versions is faster strongly depends on the number and
kind of array operations in the called procedure. (If the passed array
is not contiguous, other things like available memory and array size are
also crucial.)
* * *
Well, at least for the common case of the contiguous arrays, Fortran
2008 offers the CONTIGUOUS attribute - to be used with POINTERs and
assumed-shaped (dummy) arrays. For such variables, the user guarantees
that the variable is indeed contiguous. While for non-pointers that is
mostly checkable by the compiler, it is the user's responsibility to
ensure this.
What I really like about CONTIGUOUS is that using a preprocessor, one
can remain compatible to Fortran 90, but still take advantage of the
attribute - one just needs to define
#define CONTIGUOUS ,contiguous
or
#define CONTIGOUS
* * *
The patch implements the parsing and the constraint checking. The next
step is to use it also for procedure calls (trans-exp.c) and for array
operations (trans-array.c); I think some checks in dependency can be
also simplified using a call to gfc_is_simply contiguous.
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
PS: Another performance item in F2008 is DO CONTIGUOUS, which does what
many though FORALL would do: Fast loop operations without the need for
temporary arrays. Contrary to FORALL, which is an assignment statement,
DO is a real loop with extra constraints. I currently do not plan to
support it, but I think it is also an important item for the users which
are more interested in performance than in new language concepts (such
as procedure pointers, polymorphic datatypes, submodules etc.).
[-- Attachment #2: contiguous.diff --]
[-- Type: text/x-patch, Size: 22560 bytes --]
2010-06-18 Tobias Burnus <burnus@net-b.de>
PR fortran/40632
* interface.c: Include dependency.h.
(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.
* Make-lang.in (F95_PARSER_OBJS): Add dependency.h for
interface.c.
* resolve.c (resolve_fl_derived, resolve_symbol): Handle
contiguous.
* gfortran.h (symbol_attribute): Add contiguous.
(gfc_add_contiguous): Add prototype.
* match.h (gfc_match_contiguous): Add prototype.
* parse.c (decode_specification_statement,
decode_statement): Handle contiguous attribute.
* dependency.c (gfc_is_simply_contiguous): New function.
* dependency.h (gfc_is_simply_contiguous): Add prototype.
2010-06-18 Tobias Burnus <burnus@net-b.de>
PR fortran/40632
* gfortran.dg/contiguous_1.f90: New.
* gfortran.dg/contiguous_2.f90: New.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 160998)
+++ gcc/fortran/interface.c (working copy)
@@ -69,6 +69,7 @@ along with GCC; see the file COPYING3.
#include "system.h"
#include "gfortran.h"
#include "match.h"
+#include "dependency.h" /* For gfc_is_simply_contiguous. */
/* The current_interface structure holds information about the
interface currently being parsed. This structure is saved and
@@ -1435,6 +1436,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 +1513,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)
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 160998)
+++ gcc/fortran/symbol.c (working copy)
@@ -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)
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 160998)
+++ gcc/fortran/decl.c (working copy)
@@ -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
Index: gcc/fortran/Make-lang.in
===================================================================
--- gcc/fortran/Make-lang.in (revision 160998)
+++ gcc/fortran/Make-lang.in (working copy)
@@ -324,7 +324,8 @@ $(F95_PARSER_OBJS): fortran/gfortran.h f
fortran/parse.h fortran/arith.h fortran/target-memory.h \
$(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \
$(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \
- $(FLAGS_H) output.h $(DIAGNOSTIC_H) errors.h $(FUNCTION_H)
+ $(FLAGS_H) output.h $(DIAGNOSTIC_H) errors.h $(FUNCTION_H) \
+ fortran/dependency.h
fortran/openmp.o: pointer-set.h $(TARGET_H) toplev.h
GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/libgfortran.h \
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 160998)
+++ gcc/fortran/gfortran.h (working copy)
@@ -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 *);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 160998)
+++ gcc/fortran/resolve.c (working copy)
@@ -10784,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)
@@ -11400,6 +11450,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;
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h (revision 160998)
+++ gcc/fortran/match.h (working copy)
@@ -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);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 160998)
+++ gcc/fortran/parse.c (working copy)
@@ -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);
Index: gcc/fortran/dependency.c
===================================================================
--- gcc/fortran/dependency.c (revision 160998)
+++ gcc/fortran/dependency.c (working copy)
@@ -1589,3 +1589,92 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref
return fin_dep == GFC_DEP_OVERLAP;
}
+
+/* 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 || gfc_expr_is_one (ar->stride[i], 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;
+}
Index: gcc/fortran/dependency.h
===================================================================
--- gcc/fortran/dependency.h (revision 160998)
+++ gcc/fortran/dependency.h (working copy)
@@ -43,3 +43,5 @@ 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 *);
+bool gfc_is_simply_contiguous (gfc_expr *, bool);
+
Index: gcc/testsuite/gfortran.dg/contiguous_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/contiguous_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/contiguous_1.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/contiguous_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/contiguous_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/contiguous_2.f90 (revision 0)
@@ -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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch,Fortran] PR 40632 - Add CONTIGUOUS attribute (part 1)
2010-06-18 16:52 [Patch,Fortran] PR 40632 - Add CONTIGUOUS attribute (part 1) Tobias Burnus
@ 2010-06-19 3:57 ` Tobias Burnus
2010-06-19 11:34 ` Mikael Morin
0 siblings, 1 reply; 7+ messages in thread
From: Tobias Burnus @ 2010-06-19 3:57 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 619 bytes --]
Tobias Burnus wrote:
> The patch implements the parsing and the constraint checking. The next
> step is to use it also for procedure calls and for array operations
This patch now does this; the right-most stride (dim[0]) is now one and
there is no (un)pack done for procedure calls. Additionally, I added
module and dump-parse-tree support, which I initially forgot.
While the patch should be OK, I would be happy if someone could
carefully read the patch; especially, the constraints, the
simply-contiguous conditions and the trans*c part.
Build and currently regtesting on x86-64-linux.
OK for the trunk?
Tobias
[-- Attachment #2: contiguous2.diff --]
[-- Type: text/x-patch, Size: 34617 bytes --]
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.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (Revision 161011)
+++ gcc/fortran/interface.c (Arbeitskopie)
@@ -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)
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (Revision 161011)
+++ gcc/fortran/trans-expr.c (Arbeitskopie)
@@ -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;
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (Revision 161011)
+++ gcc/fortran/trans-array.c (Arbeitskopie)
@@ -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;
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (Revision 161011)
+++ gcc/fortran/symbol.c (Arbeitskopie)
@@ -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)
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (Revision 161011)
+++ gcc/fortran/decl.c (Arbeitskopie)
@@ -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
Index: gcc/fortran/dump-parse-tree.c
===================================================================
--- gcc/fortran/dump-parse-tree.c (Revision 161011)
+++ gcc/fortran/dump-parse-tree.c (Arbeitskopie)
@@ -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)
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (Revision 161011)
+++ gcc/fortran/gfortran.h (Arbeitskopie)
@@ -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 *);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (Revision 161011)
+++ gcc/fortran/expr.c (Arbeitskopie)
@@ -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;
+}
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (Revision 161011)
+++ gcc/fortran/module.c (Arbeitskopie)
@@ -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;
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c (Revision 161011)
+++ gcc/fortran/trans-types.c (Arbeitskopie)
@@ -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
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (Revision 161011)
+++ gcc/fortran/trans.h (Arbeitskopie)
@@ -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. */
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 161011)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -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;
}
}
}
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (Revision 161011)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -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;
}
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h (Revision 161011)
+++ gcc/fortran/match.h (Arbeitskopie)
@@ -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);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (Revision 161011)
+++ gcc/fortran/parse.c (Arbeitskopie)
@@ -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);
Index: gcc/fortran/dependency.c
===================================================================
--- gcc/fortran/dependency.c (Revision 161011)
+++ gcc/fortran/dependency.c (Arbeitskopie)
@@ -1588,4 +1588,3 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref
return fin_dep == GFC_DEP_OVERLAP;
}
-
Index: gcc/fortran/dependency.h
===================================================================
--- gcc/fortran/dependency.h (Revision 161011)
+++ gcc/fortran/dependency.h (Arbeitskopie)
@@ -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 *);
+
Index: gcc/testsuite/gfortran.dg/contiguous_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/contiguous_1.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/contiguous_1.f90 (Revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/contiguous_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/contiguous_2.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/contiguous_2.f90 (Revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/contiguous_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/contiguous_3.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/contiguous_3.f90 (Revision 0)
@@ -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" } }
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch,Fortran] PR 40632 - Add CONTIGUOUS attribute (part 1)
2010-06-19 3:57 ` Tobias Burnus
@ 2010-06-19 11:34 ` Mikael Morin
2010-06-19 12:34 ` Tobias Burnus
2010-06-20 10:00 ` Tobias Burnus
0 siblings, 2 replies; 7+ messages in thread
From: Mikael Morin @ 2010-06-19 11:34 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
On 19.06.2010 00:57, Tobias Burnus wrote:
> Tobias Burnus wrote:
>> The patch implements the parsing and the constraint checking. The next
>> step is to use it also for procedure calls and for array operations
>
> This patch now does this; the right-most stride (dim[0]) is now one and
> there is no (un)pack done for procedure calls. Additionally, I added
> module and dump-parse-tree support, which I initially forgot.
>
> While the patch should be OK, I would be happy if someone could
> carefully read the patch; especially, the constraints, the
> simply-contiguous conditions and the trans*c part.
>
> Build and currently regtesting on x86-64-linux.
> OK for the trunk?
>
> Tobias
Hello,
I have little time, so this is FastReview(TM).
> Index: gcc/fortran/interface.c
> ===================================================================
> --- gcc/fortran/interface.c (Revision 161011)
> +++ gcc/fortran/interface.c (Arbeitskopie)
> @@ -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;
> }
The error message is a bit cryptic to me.
> Index: gcc/fortran/expr.c
> ===================================================================
> --- gcc/fortran/expr.c (Revision 161011)
> +++ gcc/fortran/expr.c (Arbeitskopie)
> @@ -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. */
I think this should be outside the else block. For array(:)%component cases.
> + 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);
You can even assert that ar->type == AR_SECTION.
> +
> + /* 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;
> +}
I think you are not rejecting the case array(:,1,:)
Otherwise OK.
Thanks,
Mikael
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch,Fortran] PR 40632 - Add CONTIGUOUS attribute (part 1)
2010-06-19 11:34 ` Mikael Morin
@ 2010-06-19 12:34 ` Tobias Burnus
2010-06-20 10:00 ` Tobias Burnus
1 sibling, 0 replies; 7+ messages in thread
From: Tobias Burnus @ 2010-06-19 12:34 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran
Hi Mikael,
thanks for the fast review!
I agree that the error message is a bit cryptic, but do you (or anyone
else) have a better suggestion? The constraints are also rather lengthy
and convoluted:
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.
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.
Mikael Morin wrote:
>> + /* 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->typI have to checke != 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;
>> }
> The error message is a bit cryptic to me.
It becomes a bit clearer if one replaces "both" by "actual and dummy
argument" - but that's even longer.
* * *
> I think you are not rejecting the case array(:,1,:)
I have to check. I think you are right. Additionally, the following
program give the wrong result; I don't know whether it should be
accepted with copy-in/copy-out or whether it should be rejected at
compiler time, but instead of 1,3,5,7 it prints with the patch 1,2,3,4.
(The program might even be invalid, but then it can and should be
rejected at compile time. crayftn accepts it,)
Thus, back to the standard and the drawing board - I need to recheck
again what has to be done and think about what should be done. Somehow
the concept of being "contiguous" sounds so simple, but specifying it
(in the standard) and implementing it, is more difficult than expected -
especially, in the general case, it is impossible to tell at compile
time whether an object is contiguous or not - only whether it is simply
contiguous can be checked.
implicit none
integer :: a(8),i
a = [(i,i=1,8)]
call foo(a(::2))
contains
subroutine foo(x)
integer, contiguous :: x(:)
print *, x
if (any (x != [1,3,5,7])) call abort()
end subroutine
end
Tobias
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch,Fortran] PR 40632 - Add CONTIGUOUS attribute (part 1)
2010-06-19 11:34 ` Mikael Morin
2010-06-19 12:34 ` Tobias Burnus
@ 2010-06-20 10:00 ` Tobias Burnus
2010-06-21 11:55 ` Mikael Morin
1 sibling, 1 reply; 7+ messages in thread
From: Tobias Burnus @ 2010-06-20 10:00 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 1592 bytes --]
Dear all, hi Mikael,
here comes an updated patch.
On 19.06.2010 09:45, Mikael Morin wrote:
> The error message is a bit cryptic to me.
Since there were no better suggestion, I kept it. Hopefully, no one will
run into this message.
>> + 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. */
> I think this should be outside the else block. For array(:)%component
> cases.
I have moved it before REF_COMPONENT.
>> + gcc_assert (ar->type != AR_UNKNOWN);
> You can even assert that ar->type == AR_SECTION.
Done.
> I think you are not rejecting the case array(:,1,:)
Fixed - and added a test case.
Additional fixes in trans-array.c's gfc_conv_array_parameter:
* I now use gfc_is_simply_contiguous for no_pack, which is shorter and
more correct
* I had completely forgotten about passing "array(::2)" to " ...,
contiguous :: dummy(:)". The standard says (slightly hidden) that this
is valid and that a copy-in/copy-out can happen if the variable is not
simply contiguous (cf. 12.5.2.13 and 12.3.3 [paragraph 9 and 10]). Well,
that's what the patch now does: It (un)packs the array if needed. (+
test case added)
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
PS: I think one can clean up a bit the contiguity checks in
gfc_conv_array_parameter as gfc_is_simply_contiguous covers a lot -
though it does not cover all items.
[-- Attachment #2: contiguous3.diff --]
[-- Type: text/x-patch, Size: 35519 bytes --]
2010-06-20 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-20 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.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (Revision 161033)
+++ gcc/fortran/interface.c (Arbeitskopie)
@@ -1435,6 +1435,16 @@
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 @@
: 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)
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (Revision 161033)
+++ gcc/fortran/trans-array.c (Arbeitskopie)
@@ -285,7 +285,9 @@
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);
@@ -5522,6 +5524,7 @@
ultimate_ptr_comp = false;
ultimate_alloc_comp = false;
+
for (ref = expr->ref; ref; ref = ref->next)
{
if (ref->next == NULL)
@@ -5608,7 +5611,8 @@
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 deferred- or assumed-shape array, or if it is simply
+ contiguous. */
no_pack = ((sym && sym->as
&& !sym->attr.pointer
&& sym->as->type != AS_DEFERRED
@@ -5616,7 +5620,9 @@
||
(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)
+ ||
+ gfc_is_simply_contiguous (expr, false));
no_pack = contiguous && no_pack;
@@ -5680,9 +5686,24 @@
gfc_add_expr_to_block (&se->post, tmp);
}
- if (g77)
+ if (g77 || (fsym && fsym->attr.contiguous
+ && !gfc_is_simply_contiguous (expr, false)))
{
+ tree origptr = NULL_TREE;
+
desc = se->expr;
+
+ /* For contiguous arrays, save the original value of the descriptor. */
+ if (!g77)
+ {
+ origptr = gfc_create_var (pvoid_type_node, "origptr");
+ tmp = build_fold_indirect_ref_loc (input_location, desc);
+ tmp = gfc_conv_array_data (tmp);
+ tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (origptr), origptr,
+ fold_convert (TREE_TYPE (origptr), tmp));
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
/* Repack the array. */
if (gfc_option.warn_array_temp)
{
@@ -5706,7 +5727,15 @@
ptr = gfc_evaluate_now (ptr, &se->pre);
- se->expr = ptr;
+ /* Use the packed data for the actual argument, except for contiguous arrays,
+ where the descriptor's data component is set. */
+ if (g77)
+ se->expr = ptr;
+ else
+ {
+ tmp = build_fold_indirect_ref_loc (input_location, desc);
+ gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
+ }
if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
{
@@ -5768,6 +5797,14 @@
gfc_add_block_to_block (&block, &se->post);
gfc_init_block (&se->post);
+
+ /* Reset the descriptor pointer. */
+ if (!g77)
+ {
+ tmp = build_fold_indirect_ref_loc (input_location, desc);
+ gfc_conv_descriptor_data_set (&se->post, tmp, origptr);
+ }
+
gfc_add_block_to_block (&se->post, &block);
}
}
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (Revision 161033)
+++ gcc/fortran/trans-expr.c (Arbeitskopie)
@@ -1718,6 +1718,7 @@
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;
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (Revision 161033)
+++ gcc/fortran/symbol.c (Arbeitskopie)
@@ -372,7 +372,8 @@
*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 @@
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 @@
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 @@
conf2 (dummy);
conf2 (volatile_);
conf2 (asynchronous);
+ conf2 (contiguous);
conf2 (pointer);
conf2 (is_protected);
conf2 (target);
@@ -720,6 +724,7 @@
conf2 (function);
conf2 (subroutine);
conf2 (entry);
+ conf2 (contiguous);
conf2 (pointer);
conf2 (is_protected);
conf2 (target);
@@ -928,6 +933,18 @@
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 @@
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)
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (Revision 161033)
+++ gcc/fortran/decl.c (Arbeitskopie)
@@ -2875,8 +2875,8 @@
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 @@
}
break;
}
+ break;
case 'b':
/* Try and match the bind(c). */
@@ -2950,8 +2951,24 @@
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 @@
case DECL_CODIMENSION:
attr = "CODIMENSION";
break;
+ case DECL_CONTIGUOUS:
+ attr = "CONTIGUOUS";
+ break;
case DECL_DIMENSION:
attr = "DIMENSION";
break;
@@ -3214,7 +3234,7 @@
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 @@
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 @@
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
Index: gcc/fortran/dump-parse-tree.c
===================================================================
--- gcc/fortran/dump-parse-tree.c (Revision 161033)
+++ gcc/fortran/dump-parse-tree.c (Arbeitskopie)
@@ -598,6 +598,8 @@
fputs (" CODIMENSION", dumpfile);
if (attr->dimension)
fputs (" DIMENSION", dumpfile);
+ if (attr->contiguous)
+ fputs (" CONTIGUOUS", dumpfile);
if (attr->external)
fputs (" EXTERNAL", dumpfile);
if (attr->intrinsic)
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (Revision 161033)
+++ gcc/fortran/gfortran.h (Arbeitskopie)
@@ -665,7 +665,8 @@
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_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 @@
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 *);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (Revision 161033)
+++ gcc/fortran/expr.c (Arbeitskopie)
@@ -4080,3 +4080,105 @@
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->value.function.esym
+ ? expr->value.function.esym->result->attr.contiguous : false;
+ else if (expr->expr_type != EXPR_VARIABLE)
+ return false;
+
+ if (expr->rank == 0)
+ return false;
+
+ for (ref = expr->ref; ref; ref = ref->next)
+ {
+ if (ar)
+ return false; /* Array shall be last part-ref. */
+
+ if (ref->type == REF_COMPONENT)
+ part_ref = ref;
+ else if (ref->type == REF_SUBSTRING)
+ return false;
+ else 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_SECTION);
+
+ /* Check for simply contiguous array */
+ colon = true;
+ for (i = 0; i < ar->dimen; i++)
+ {
+ if (ar->dimen_type[i] == DIMEN_VECTOR)
+ return false;
+
+ if (ar->dimen_type[i] == DIMEN_ELEMENT)
+ {
+ colon = false;
+ continue;
+ }
+
+ gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
+
+
+ /* If the previous section was not contiguous, that's an error,
+ unless we have effective only one element and checking is not
+ strict. */
+ if (!colon && (strict || !ar->start[i] || !ar->end[i]
+ || ar->start[i]->expr_type != EXPR_CONSTANT
+ || ar->end[i]->expr_type != EXPR_CONSTANT
+ || mpz_cmp (ar->start[i]->value.integer,
+ ar->end[i]->value.integer) != 0))
+ return false;
+
+ /* 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 (ar->stride[i]->value.integer, 1) != 0))
+ return false;
+
+ if (ar->start[i]
+ && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
+ || !ar->as->lower[i]
+ || ar->as->lower[i]->expr_type != EXPR_CONSTANT
+ || mpz_cmp (ar->start[i]->value.integer,
+ ar->as->lower[i]->value.integer) != 0))
+ colon = false;
+
+ if (ar->end[i]
+ && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
+ || !ar->as->upper[i]
+ || ar->as->upper[i]->expr_type != EXPR_CONSTANT
+ || mpz_cmp (ar->end[i]->value.integer,
+ ar->as->upper[i]->value.integer) != 0))
+ colon = false;
+ }
+
+ return true;
+}
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (Revision 161033)
+++ gcc/fortran/module.c (Arbeitskopie)
@@ -1675,7 +1675,7 @@
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 @@
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_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 @@
case AB_CODIMENSION:
attr->codimension = 1;
break;
+ case AB_CONTIGUOUS:
+ attr->contiguous = 1;
+ break;
case AB_EXTERNAL:
attr->external = 1;
break;
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c (Revision 161033)
+++ gcc/fortran/trans-types.c (Arbeitskopie)
@@ -1202,7 +1202,8 @@
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 @@
}
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 @@
{
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 @@
{
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 @@
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 @@
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 @@
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
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (Revision 161033)
+++ gcc/fortran/trans.h (Arbeitskopie)
@@ -620,14 +620,17 @@
/* 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. */
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 161033)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -10826,6 +10826,14 @@
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 @@
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 @@
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 @@
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;
}
}
}
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (Revision 161033)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -1213,7 +1213,8 @@
/* 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;
}
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h (Revision 161033)
+++ gcc/fortran/match.h (Arbeitskopie)
@@ -168,6 +168,7 @@
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);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (Revision 161033)
+++ gcc/fortran/parse.c (Arbeitskopie)
@@ -139,6 +139,7 @@
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 @@
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);
Index: gcc/fortran/dependency.c
===================================================================
--- gcc/fortran/dependency.c (Revision 161033)
+++ gcc/fortran/dependency.c (Arbeitskopie)
@@ -1588,4 +1588,3 @@
return fin_dep == GFC_DEP_OVERLAP;
}
-
Index: gcc/fortran/dependency.h
===================================================================
--- gcc/fortran/dependency.h (Revision 161033)
+++ gcc/fortran/dependency.h (Arbeitskopie)
@@ -43,3 +43,4 @@
int gfc_dep_resolver(gfc_ref *, gfc_ref *);
int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *);
+
Index: gcc/testsuite/gfortran.dg/contiguous_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/contiguous_1.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/contiguous_1.f90 (Revision 0)
@@ -0,0 +1,177 @@
+! { 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
+
+
+
+subroutine test34
+ implicit none
+ integer, volatile,pointer :: a(:,:),i
+ call foo(a(2,2:3:2)) ! { dg-error "must be simply contigous" }
+contains
+ subroutine foo(x)
+ integer, pointer, contiguous, volatile :: x(:)
+ end subroutine
+end subroutine test34
Index: gcc/testsuite/gfortran.dg/contiguous_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/contiguous_2.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/contiguous_2.f90 (Revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/contiguous_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/contiguous_3.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/contiguous_3.f90 (Revision 0)
@@ -0,0 +1,65 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/40632
+!
+! CONTIGUOUS compile-time tests: Check that contigous
+! works properly.
+
+subroutine test1(a,b)
+ integer, pointer, contiguous :: test1_a(:)
+ call foo(test1_a)
+ call foo(test1_a(::1))
+ call foo(test1_a(::2))
+contains
+ subroutine foo(b)
+ integer :: b(*)
+ end subroutine foo
+end subroutine test1
+
+! For the first two no pack is done; for the third one, an array descriptor
+! (cf. below test3) is created for packing.
+!
+! { dg-final { scan-tree-dump-times "_internal_pack.*test1_a" 0 "original" } }
+! { dg-final { scan-tree-dump-times "_internal_unpack.*test1_a" 0 "original" } }
+
+
+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 "= 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" } }
+
+
+subroutine test3()
+ implicit none
+ integer :: test3_a(8),i
+ test3_a = [(i,i=1,8)]
+ call foo(test3_a(::1))
+ call foo(test3_a(::2))
+ call bar(test3_a(::1))
+ call bar(test3_a(::2))
+contains
+ subroutine foo(x)
+ integer, contiguous :: x(:)
+ print *, x
+ end subroutine
+ subroutine bar(x)
+ integer :: x(:)
+ print *, x
+ end subroutine bar
+end subroutine test3
+
+! Once for test1 (third call), once for test3 (second call)
+! { dg-final { scan-tree-dump-times "data = origptr" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_internal_pack .&parm" 2 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack .&parm" 2 "original" } }
+
+
+! { dg-final { cleanup-tree-dump "original" } }
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch,Fortran] PR 40632 - Add CONTIGUOUS attribute (part 1)
2010-06-20 10:00 ` Tobias Burnus
@ 2010-06-21 11:55 ` Mikael Morin
2010-06-21 15:24 ` Tobias Burnus
0 siblings, 1 reply; 7+ messages in thread
From: Mikael Morin @ 2010-06-21 11:55 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
On 20.06.2010 00:00, Tobias Burnus wrote:
> Dear all, hi Mikael,
Hi,
>
> here comes an updated patch.
>
> On 19.06.2010 09:45, Mikael Morin wrote:
>> The error message is a bit cryptic to me.
>
> Since there were no better suggestion, I kept it. Hopefully, no one will
> run into this message.
On second thought, your sentence is fine.
Maybe add a comma before "as actual argument..." ; I was somehow trying
to attach the latter part of the sentence with the one just before and
couldn't make any sense out of it.
>
>>> + 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. */
>> I think this should be outside the else block. For array(:)%component
>> cases.
>
> I have moved it before REF_COMPONENT.
>
>>> + gcc_assert (ar->type != AR_UNKNOWN);
>> You can even assert that ar->type == AR_SECTION.
> Done.
>
>> I think you are not rejecting the case array(:,1,:)
> Fixed - and added a test case.
>
>
> Additional fixes in trans-array.c's gfc_conv_array_parameter:
>
> * I now use gfc_is_simply_contiguous for no_pack, which is shorter and
> more correct
>
> * I had completely forgotten about passing "array(::2)" to " ...,
> contiguous :: dummy(:)". The standard says (slightly hidden) that this
> is valid and that a copy-in/copy-out can happen if the variable is not
> simply contiguous (cf. 12.5.2.13 and 12.3.3 [paragraph 9 and 10]). Well,
> that's what the patch now does: It (un)packs the array if needed. (+
> test case added)
It was the first patch and was supposed to be parsing/erroring only,
right ? ;-)
>
>
> Build and regtested on x86-64-linux.
> OK for the trunk?
OK, thanks.
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch,Fortran] PR 40632 - Add CONTIGUOUS attribute (part 1)
2010-06-21 11:55 ` Mikael Morin
@ 2010-06-21 15:24 ` Tobias Burnus
0 siblings, 0 replies; 7+ messages in thread
From: Tobias Burnus @ 2010-06-21 15:24 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran
On 06/21/2010 01:08 PM, Mikael Morin wrote:
> On second thought, your sentence is fine.
> Maybe add a comma before "as actual argument..." ; I was somehow
> trying to attach the latter part of the sentence with the one just
> before and couldn't make any sense out of it.
I have now added a hyphen.
> OK, thanks.
Thanks for the review! Committed revision 161079.
Tobias
^ permalink raw reply [flat|nested] 7+ messages in thread
end of thread, other threads:[~2010-06-21 14:19 UTC | newest]
Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2010-06-18 16:52 [Patch,Fortran] PR 40632 - Add CONTIGUOUS attribute (part 1) Tobias Burnus
2010-06-19 3:57 ` Tobias Burnus
2010-06-19 11:34 ` Mikael Morin
2010-06-19 12:34 ` Tobias Burnus
2010-06-20 10:00 ` Tobias Burnus
2010-06-21 11:55 ` Mikael Morin
2010-06-21 15:24 ` Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).