* [Patch, Fortran] Add parsing support for assumed-rank array
@ 2012-06-16 14:06 Tobias Burnus
2012-06-24 15:48 ` Tobias Burnus
0 siblings, 1 reply; 18+ messages in thread
From: Tobias Burnus @ 2012-06-16 14:06 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 898 bytes --]
To cleanup my local trees; I had the patch lingering there for a many weeks.
User visible, it only adds parsing support for "dimension(..)" and a
sorry message.
Internally, it implements a basic support for assumed-shape arrays.
There are still many constraint checks missing, scalar actual arguments
to assumed-rank dummies have issues, and many intrinsics do not yet
handle assumed-rank arguments.
In order to be more useful, some C binding changes and the
implementation of IS_CONTIGUOUS is required. However, the big stumbling
block for practical usage is the array descriptor: Instead of using the
TS29113 one, gfortran's internal one is passed. [Cf. array descriptor
reform.*]
Build on x86-64-linux.
OK for the trunk?
Tobias
* Talking about the new array descriptor, we really should find out why
the following patch fails:
http://gcc.gnu.org/ml/fortran/2012-04/msg00115.html
[-- Attachment #2: assumed-rank.diff --]
[-- Type: text/x-patch, Size: 13323 bytes --]
2012-06-12 Tobias Burnus <burnus@net-b.de>
* array.c (gfc_match_array_spec, gfc_match_array_spec): Add support
for assumed-rank arrays.
* check.c (dim_rank_check): Ditto.
* dump-parse-tree.c (show_array_spec): Ditto.
* gfortran.h (array_type): Ditto.
* interface.c (compare_type_rank, compare_parameter): Ditto.
* resolve.c (resolve_formal_arglist, resolve_global_procedure,
expression_shape, resolve_variable, resolve_symbol): Ditto.
* simplify.c (simplify_bound, gfc_simplify_range): Ditto.
* trans-array.c (gfc_conv_array_parameter): Ditto.
* trans-decl. (gfc_build_dummy_array_decl,
gfc_trans_deferred_vars): Ditto.
* trans-types.c (gfc_is_nodesc_array, gfc_build_array_type,
gfc_get_array_descriptor_base): Ditto.
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index b36d517..5b412dc 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -457,6 +457,24 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
goto coarray;
}
+ if (gfc_match (" .. )") == MATCH_YES)
+ {
+ as->type = AS_ASSUMED_RANK;
+ as->rank = -1;
+
+ if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed-rank array "
+ "at %C") == FAILURE)
+ goto cleanup;
+
+ gfc_error ("Sorry, support for assumed-rank array at %C is not yet "
+ "implemented");
+ goto cleanup;
+
+ if (!match_codim)
+ goto done;
+ goto coarray;
+ }
+
for (;;)
{
as->rank++;
@@ -535,6 +553,9 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
gfc_error ("Bad specification for assumed size array at %C");
goto cleanup;
+
+ case AS_ASSUMED_RANK:
+ gcc_unreachable ();
}
if (gfc_match_char (')') == MATCH_YES)
@@ -641,6 +662,9 @@ coarray:
case AS_ASSUMED_SIZE:
gfc_error ("Bad specification for assumed size array at %C");
goto cleanup;
+
+ case AS_ASSUMED_RANK:
+ gcc_unreachable ();
}
if (gfc_match_char (']') == MATCH_YES)
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 9926f05..ff71ff5 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -618,6 +618,10 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
else
rank = array->rank;
+ /* Assumed-rank array. */
+ if (rank == -1)
+ rank = GFC_MAX_DIMENSIONS;
+
if (array->expr_type == EXPR_VARIABLE)
{
ar = gfc_find_array_ref (array);
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 7f1d28f..14909f4 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -173,6 +173,7 @@ show_array_spec (gfc_array_spec *as)
case AS_DEFERRED: c = "AS_DEFERRED"; break;
case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
+ case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break;
default:
gfc_internal_error ("show_array_spec(): Unhandled array shape "
"type.");
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 759074a..454d873 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -132,7 +132,8 @@ expr_t;
/* Array types. */
typedef enum
{ AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED,
- AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_UNKNOWN
+ AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_ASSUMED_RANK,
+ AS_UNKNOWN
}
array_type;
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 95439c1..13f3ee8 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -511,7 +511,9 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
r1 = (s1->as != NULL) ? s1->as->rank : 0;
r2 = (s2->as != NULL) ? s2->as->rank : 0;
- if (r1 != r2)
+ if (r1 != r2
+ && (!s1->as || s1->as->type != AS_ASSUMED_RANK)
+ && (!s2->as || s2->as->type != AS_ASSUMED_RANK))
return 0; /* Ranks differ. */
return gfc_compare_types (&s1->ts, &s2->ts)
@@ -1842,7 +1844,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
" is modified", &actual->where, formal->name);
}
- if (symbol_rank (formal) == actual->rank)
+ /* If the rank is the same or the formal argument has assumed-rank. */
+ if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
return 1;
if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 8531318..63dd79e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -239,7 +239,7 @@ resolve_formal_arglist (gfc_symbol *proc)
if (gfc_elemental (proc)
|| sym->attr.pointer || sym->attr.allocatable
- || (sym->as && sym->as->rank > 0))
+ || (sym->as && sym->as->rank != 0))
{
proc->attr.always_explicit = 1;
sym->attr.always_explicit = 1;
@@ -299,6 +299,7 @@ resolve_formal_arglist (gfc_symbol *proc)
}
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
|| sym->attr.optional)
{
@@ -2195,6 +2196,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* TS 29113, 6.2. */
+ else if (arg->sym && arg->sym->as
+ && arg->sym->as->type == AS_ASSUMED_RANK)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
/* F2008, 12.4.2.2 (2c) */
else if (arg->sym->attr.codimension)
{
@@ -2220,6 +2230,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* As assumed-type is unlimited polymorphic (cf. above).
+ See also TS 29113, Note 6.1. */
+ else if (arg->sym->ts.type == BT_ASSUMED)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-type dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
}
if (def_sym->attr.function)
@@ -4965,7 +4984,7 @@ expression_shape (gfc_expr *e)
mpz_t array[GFC_MAX_DIMENSIONS];
int i;
- if (e->rank == 0 || e->shape != NULL)
+ if (e->rank <= 0 || e->shape != NULL)
return;
for (i = 0; i < e->rank; i++)
@@ -5085,6 +5104,17 @@ resolve_variable (gfc_expr *e)
return FAILURE;
}
+ /* TS 29113, C535b. */
+ if (sym->as && sym->as->type == AS_ASSUMED_RANK && e->ref
+ && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+ && e->ref->next == NULL))
+ {
+ gfc_error ("Assumed-rank variable %s with designator at %L",
+ sym->name, &e->ref->u.ar.where);
+ return FAILURE;
+ }
+
+
/* If this is an associate-name, it may be parsed with an array reference
in error even though the target is scalar. Fail directly in this case.
TODO Understand why class scalar expressions must be excluded. */
@@ -12464,6 +12494,20 @@ resolve_symbol (gfc_symbol *sym)
&sym->declared_at);
return;
}
+ /* TS 29113, C535a. */
+ if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy)
+ {
+ gfc_error ("Assumed-rank array at %L must be a dummy argument",
+ &sym->declared_at);
+ return;
+ }
+ if (as->type == AS_ASSUMED_RANK
+ && (sym->attr.codimension || sym->attr.value))
+ {
+ gfc_error ("Assumed-rank array at %L may not have the VALUE or "
+ "CODIMENSION attribute", &sym->declared_at);
+ return;
+ }
}
/* Make sure symbols with known intent or optional are really dummy
@@ -12536,6 +12580,13 @@ resolve_symbol (gfc_symbol *sym)
sym->name, &sym->declared_at);
return;
}
+ if (sym->attr.intent == INTENT_OUT)
+ {
+ gfc_error ("Assumed-type variable %s at %L may not have the "
+ "INTENT(OUT) attribute",
+ sym->name, &sym->declared_at);
+ return;
+ }
if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
{
gfc_error ("Assumed-type variable %s at %L shall not be an "
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 1578db1..13c8589 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2934,7 +2934,6 @@ gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
}
-
gfc_expr *
gfc_simplify_is_iostat_end (gfc_expr *x)
{
@@ -3380,7 +3378,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
done:
- if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
+ if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
+ || as->type == AS_ASSUMED_RANK))
return NULL;
if (dim == NULL)
@@ -3442,13 +3441,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
d = mpz_get_si (dim->value.integer);
- if (d < 1 || d > array->rank
+ if ((d < 1 || d > array->rank)
|| (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
{
gfc_error ("DIM argument at %L is out of bounds", &dim->where);
return &gfc_bad_expr;
}
+ if (as && as->type == AS_ASSUMED_RANK)
+ return NULL;
+
return simplify_bound_dim (array, kind, d, upper, as, ref, false);
}
}
@@ -4779,6 +4781,10 @@ gfc_simplify_range (gfc_expr *e)
gfc_expr *
gfc_simplify_rank (gfc_expr *e)
{
+ /* Assumed rank. */
+ if (e->rank == -1)
+ return NULL;
+
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
}
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0e78210..3011cbb 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -6892,9 +6892,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
}
if (!sym->attr.pointer
- && sym->as
- && sym->as->type != AS_ASSUMED_SHAPE
- && !sym->attr.allocatable)
+ && sym->as
+ && sym->as->type != AS_ASSUMED_SHAPE
+ && sym->as->type != AS_ASSUMED_RANK
+ && !sym->attr.allocatable)
{
/* Some variables are declared directly, others are declared as
pointers and allocated on the heap. */
@@ -6930,10 +6931,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
no_pack = ((sym && sym->as
&& !sym->attr.pointer
&& sym->as->type != AS_DEFERRED
+ && sym->as->type != AS_ASSUMED_RANK
&& sym->as->type != AS_ASSUMED_SHAPE)
||
(ref && ref->u.ar.as
&& ref->u.ar.as->type != AS_DEFERRED
+ && ref->u.ar.as->type != AS_ASSUMED_RANK
&& ref->u.ar.as->type != AS_ASSUMED_SHAPE)
||
gfc_is_simply_contiguous (expr, false));
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 75a2160..b7e137e 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -933,7 +933,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
int n;
bool known_size;
- if (sym->attr.pointer || sym->attr.allocatable)
+ if (sym->attr.pointer || sym->attr.allocatable
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
return dummy;
/* Add to list of variables if not a fake result variable. */
@@ -3670,6 +3671,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
break;
case AS_DEFERRED:
+ case AS_ASSUMED_RANK:
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, block);
break;
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index aa50e3d..c6088e0 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1277,7 +1277,8 @@ gfc_is_nodesc_array (gfc_symbol * sym)
return 0;
if (sym->attr.dummy)
- return sym->as->type != AS_ASSUMED_SHAPE;
+ return sym->as->type != AS_ASSUMED_SHAPE
+ && sym->as->type != AS_ASSUMED_RANK;
if (sym->attr.result || sym->attr.function)
return 0;
@@ -1299,6 +1300,13 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
tree ubound[GFC_MAX_DIMENSIONS];
int n;
+ if (as->type == AS_ASSUMED_RANK)
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ {
+ lbound[n] = NULL_TREE;
+ ubound[n] = NULL_TREE;
+ }
+
for (n = 0; n < as->rank; n++)
{
/* Create expressions for the known bounds of the array. */
@@ -1323,7 +1331,9 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
if (as->type == AS_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,
+ return gfc_get_array_type_bounds (type, as->rank == -1
+ ? GFC_MAX_DIMENSIONS : as->rank,
+ as->corank, lbound,
ubound, 0, akind, restricted);
}
\f
@@ -1684,6 +1694,10 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
int idx = 2 * (codimen + dimen - 1) + restricted;
+ /* Assumed-rank array. */
+ if (dimen == -1)
+ dimen = GFC_MAX_DIMENSIONS;
+
gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-06-16 14:06 [Patch, Fortran] Add parsing support for assumed-rank array Tobias Burnus
@ 2012-06-24 15:48 ` Tobias Burnus
2012-07-05 13:52 ` Mikael Morin
0 siblings, 1 reply; 18+ messages in thread
From: Tobias Burnus @ 2012-06-24 15:48 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 1010 bytes --]
Tobias Burnus wrote:
> To cleanup my local trees; I had the patch lingering there for a many
> weeks. User visible, it only adds parsing support for "dimension(..)"
> and a sorry message.
I have now updated the patch. Changes:
* No longer stops with a sorry message (except for scalars to
assumed-rank arrays)
* Test cases are included
* Passing nondescriptor arrays now works
* lbound, ubound and size with dim= and size without dim= are
supported, including the distinction of the lower bound for
allocatables/pointers vs nonallocatables/nonpointers
* Many constraint checks
Missing:
* Passing of scalars
* Scalarizer (to be used by lbound/ubound/shape w/o dim=)
* More tests, especially with noncontiguous assumed-shape->contiguous,
type<->class, and assumed-size arrays - and fixing the fall out
* Relaxing the constraint checks for C_loc et alia.
(* And out of scope: Full access from C as that implies the new array
descriptor.)
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
[-- Attachment #2: assumed-rank-2012-06-24.diff --]
[-- Type: text/x-patch, Size: 48642 bytes --]
2012-06-24 Tobias Burnus <burnus@net-b.de>
PR fortran/48820
* array.c (match_array_element_spec, gfc_match_array_spec,
spec_size, gfc_array_dimen_size): Add support for
assumed-rank arrays.
* check.c (dim_rank_check): Ditto.
* decl.c (merge_array_spec): Ditto.
* dump-parse-tree.c (show_array_spec): Ditto.
* gfortran.h (array_type): Ditto.
* interface.c (compare_type_rank, compare_parameter,
argument_rank_mismatch, gfc_procedure_use): Ditto.
* module.c (mio_typespec): Ditto.
* resolve.c (resolve_formal_arglist, resolve_global_procedure,
expression_shape, resolve_variable, resolve_symbol,
resolve_fl_var_and_proc, resolve_actual_arglist,
resolve_elemental_actual, update_ppc_arglist,
check_typebound_baseobject, gfc_resolve_finalizers,
resolve_typebound_procedure): Ditto.
(assumed_rank_type_expr_allowed): Renamed static variable
from assumed_type_expr_allowed.
* simplify.c (simplify_bound, gfc_simplify_range): Ditto.
* trans-array.c (gfc_conv_array_parameter): Ditto.
* trans-decl. (gfc_build_dummy_array_decl,
gfc_trans_deferred_vars, add_argument_checking): Ditto.
* trans-expr.c (gfc_conv_expr_present, gfc_conv_variable,
gfc_conv_procedure_call): Ditto.
* trans-intrinsic.c (get_rank_from_desc): New function.
(gfc_conv_intrinsic_rank, gfc_conv_intrinsic_bound,
gfc_conv_associated): Use it.
* trans-types.c (gfc_is_nodesc_array, gfc_is_nodesc_array,
gfc_build_array_type, gfc_get_array_descriptor_base): Ditto.
* trans.h (gfc_array_kind): Add GFC_ARRAY_ASSUMED_RANK and
GFC_ARRAY_ASSUMED_RANK_CONT.
2012-06-24 Tobias Burnus <burnus@net-b.de>
PR fortran/48820
* gfortran.dg/assumed_rank_1.f90: New.
* gfortran.dg/assumed_rank_1_c.c: New.
* gfortran.dg/assumed_rank_2.f90: New.
* gfortran.dg/assumed_rank_3.f90: New.
* gfortran.dg/assumed_rank_4.f90: New.
* gfortran.dg/assumed_rank_5.f90: New.
* gfortran.dg/assumed_rank_6.f90: New.
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index b36d517..e986299 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -389,9 +389,11 @@ match_array_element_spec (gfc_array_spec *as)
{
gfc_expr **upper, **lower;
match m;
+ int rank;
- lower = &as->lower[as->rank + as->corank - 1];
- upper = &as->upper[as->rank + as->corank - 1];
+ rank = as->rank == -1 ? 0 : as->rank;
+ lower = &as->lower[rank + as->corank - 1];
+ upper = &as->upper[rank + as->corank - 1];
if (gfc_match_char ('*') == MATCH_YES)
{
@@ -457,6 +459,20 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
goto coarray;
}
+ if (gfc_match (" .. )") == MATCH_YES)
+ {
+ as->type = AS_ASSUMED_RANK;
+ as->rank = -1;
+
+ if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed-rank array "
+ "at %C") == FAILURE)
+ goto cleanup;
+
+ if (!match_codim)
+ goto done;
+ goto coarray;
+ }
+
for (;;)
{
as->rank++;
@@ -535,6 +551,9 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
gfc_error ("Bad specification for assumed size array at %C");
goto cleanup;
+
+ case AS_ASSUMED_RANK:
+ gcc_unreachable ();
}
if (gfc_match_char (')') == MATCH_YES)
@@ -641,6 +660,9 @@ coarray:
case AS_ASSUMED_SIZE:
gfc_error ("Bad specification for assumed size array at %C");
goto cleanup;
+
+ case AS_ASSUMED_RANK:
+ gcc_unreachable ();
}
if (gfc_match_char (']') == MATCH_YES)
@@ -1959,6 +1981,9 @@ spec_size (gfc_array_spec *as, mpz_t *result)
mpz_t size;
int d;
+ if (as->type == AS_ASSUMED_RANK)
+ return FAILURE;
+
mpz_init_set_ui (*result, 1);
for (d = 0; d < as->rank; d++)
@@ -2115,6 +2140,9 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
if (array->ts.type == BT_CLASS)
return FAILURE;
+ if (array->rank == -1)
+ return FAILURE;
+
if (dimen < 0 || array == NULL || dimen > array->rank - 1)
gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 7d505d5..b0c4b28 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -619,6 +619,10 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
else
rank = array->rank;
+ /* Assumed-rank array. */
+ if (rank == -1)
+ rank = GFC_MAX_DIMENSIONS;
+
if (array->expr_type == EXPR_VARIABLE)
{
ar = gfc_find_array_ref (array);
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 26b5059..4c360bf 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -593,7 +593,7 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
{
int i;
- if (to->rank == 0 && from->rank > 0)
+ if (to->rank == 0 && from->rank != 0)
{
to->rank = from->rank;
to->type = from->type;
@@ -621,20 +621,24 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
}
else if (to->corank == 0 && from->corank > 0)
{
+ int rank;
+
to->corank = from->corank;
to->cotype = from->cotype;
+ rank = to->rank == -1 ? 0 : to->rank;
+
for (i = 0; i < from->corank; i++)
{
if (copy)
{
- to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
- to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
+ to->lower[rank + i] = gfc_copy_expr (from->lower[i]);
+ to->upper[rank + i] = gfc_copy_expr (from->upper[i]);
}
else
{
- to->lower[to->rank + i] = from->lower[i];
- to->upper[to->rank + i] = from->upper[i];
+ to->lower[rank + i] = from->lower[i];
+ to->upper[rank + i] = from->upper[i];
}
}
}
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 7f1d28f..d94d9d3 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -165,7 +165,7 @@ show_array_spec (gfc_array_spec *as)
fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
- if (as->rank + as->corank > 0)
+ if (as->rank + as->corank > 0 || as->rank == -1)
{
switch (as->type)
{
@@ -173,6 +173,7 @@ show_array_spec (gfc_array_spec *as)
case AS_DEFERRED: c = "AS_DEFERRED"; break;
case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
+ case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break;
default:
gfc_internal_error ("show_array_spec(): Unhandled array shape "
"type.");
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 0b38cac..29cfa5e 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4441,7 +4441,8 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
|| (!part_ref
&& !sym->attr.contiguous
&& (sym->attr.pointer
- || sym->as->type == AS_ASSUMED_SHAPE))))
+ || sym->as->type == AS_ASSUMED_RANK
+ || sym->as->type == AS_ASSUMED_SHAPE))))
return false;
if (!ar || ar->type == AR_FULL)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 43904e9..3ae1f1b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -132,7 +132,8 @@ expr_t;
/* Array types. */
typedef enum
{ AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED,
- AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_UNKNOWN
+ AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_ASSUMED_RANK,
+ AS_UNKNOWN
}
array_type;
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 7a63f69..61163d8 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -511,7 +511,9 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
r1 = (s1->as != NULL) ? s1->as->rank : 0;
r2 = (s2->as != NULL) ? s2->as->rank : 0;
- if (r1 != r2)
+ if (r1 != r2
+ && (!s1->as || s1->as->type != AS_ASSUMED_RANK)
+ && (!s2->as || s2->as->type != AS_ASSUMED_RANK))
return 0; /* Ranks differ. */
return gfc_compare_types (&s1->ts, &s2->ts)
@@ -1634,7 +1636,14 @@ static void
argument_rank_mismatch (const char *name, locus *where,
int rank1, int rank2)
{
- if (rank1 == 0)
+
+ /* TS 29113, C407b. */
+ if (rank2 == -1)
+ {
+ gfc_error ("The assumed-rank array at %L requires that the dummy argument"
+ " '%s' has assumed-rank", where, name);
+ }
+ else if (rank1 == 0)
{
gfc_error ("Rank mismatch in argument '%s' at %L "
"(scalar and rank-%d)", name, where, rank2);
@@ -1859,7 +1868,16 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
" is modified", &actual->where, formal->name);
}
- if (symbol_rank (formal) == actual->rank)
+ if (symbol_rank (formal) == -1 && actual->rank == 0)
+ {
+ gfc_error ("Sorry, passing the scalar at %L to the assumed-rank dummy "
+ "argument '%s' is not yet supported", &actual->where,
+ formal->name);
+ return 0;
+ }
+
+ /* If the rank is the same or the formal argument has assumed-rank. */
+ if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
return 1;
if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
@@ -2990,6 +3008,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
return;
}
+
+ /* TS 29113, C407b. */
+ if (a->expr && a->expr->expr_type == EXPR_VARIABLE
+ && symbol_rank (a->expr->symtree->n.sym) == -1)
+ {
+ gfc_error ("Assumed-rank argument requires an explicit interface "
+ "at %L", &a->expr->where);
+ return;
+ }
}
return;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 60a74ca..87b903a 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -2340,6 +2340,7 @@ mio_typespec (gfc_typespec *ts)
static const mstring array_spec_types[] = {
minit ("EXPLICIT", AS_EXPLICIT),
+ minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
minit ("DEFERRED", AS_DEFERRED),
minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4595f76..33e3e4c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -63,7 +63,8 @@ static code_stack *cs_base = NULL;
static int forall_flag;
static int do_concurrent_flag;
-static bool assumed_type_expr_allowed = false;
+/* Nonzero for assumed rank and for assumed type. */
+static bool assumed_rank_type_expr_allowed = false;
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
@@ -239,7 +240,7 @@ resolve_formal_arglist (gfc_symbol *proc)
if (gfc_elemental (proc)
|| sym->attr.pointer || sym->attr.allocatable
- || (sym->as && sym->as->rank > 0))
+ || (sym->as && sym->as->rank != 0))
{
proc->attr.always_explicit = 1;
sym->attr.always_explicit = 1;
@@ -299,6 +300,7 @@ resolve_formal_arglist (gfc_symbol *proc)
}
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
|| sym->attr.optional)
{
@@ -1599,7 +1601,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_expr *e;
int save_need_full_assumed_size;
- assumed_type_expr_allowed = true;
+ assumed_rank_type_expr_allowed = true;
for (; arg; arg = arg->next)
{
@@ -1832,8 +1834,18 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
"component", &e->where);
return FAILURE;
}
+
+ /* TS29113, C407b and C535b: Assumed-type and assumed-rank are only
+ allowed for the first argument.
+ Cf. http://j3-fortran.org/pipermail/j3/2012-June/005419.html
+ FIXME: It doesn't work reliably as inquiry_argument is not set
+ for all inquiry functions in resolve_function; the reason is that
+ the function-name resolution happens too late in that function. */
+ if (inquiry_argument)
+ assumed_rank_type_expr_allowed = false;
+
}
- assumed_type_expr_allowed = false;
+ assumed_rank_type_expr_allowed = false;
return SUCCESS;
}
@@ -1895,7 +1907,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
/* The rank of an elemental is the rank of its array argument(s). */
for (arg = arg0; arg; arg = arg->next)
{
- if (arg->expr != NULL && arg->expr->rank > 0)
+ if (arg->expr != NULL && arg->expr->rank != 0)
{
rank = arg->expr->rank;
if (arg->expr->expr_type == EXPR_VARIABLE
@@ -2194,6 +2206,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* TS 29113, 6.2. */
+ else if (arg->sym && arg->sym->as
+ && arg->sym->as->type == AS_ASSUMED_RANK)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
/* F2008, 12.4.2.2 (2c) */
else if (arg->sym->attr.codimension)
{
@@ -2219,6 +2240,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* As assumed-type is unlimited polymorphic (cf. above).
+ See also TS 29113, Note 6.1. */
+ else if (arg->sym->ts.type == BT_ASSUMED)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-type dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
}
if (def_sym->attr.function)
@@ -4964,7 +4994,7 @@ expression_shape (gfc_expr *e)
mpz_t array[GFC_MAX_DIMENSIONS];
int i;
- if (e->rank == 0 || e->shape != NULL)
+ if (e->rank <= 0 || e->shape != NULL)
return;
for (i = 0; i < e->rank; i++)
@@ -5067,13 +5097,26 @@ resolve_variable (gfc_expr *e)
sym = e->symtree->n.sym;
/* TS 29113, 407b. */
- if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
+ if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed)
{
gfc_error ("Invalid expression with assumed-type variable %s at %L",
sym->name, &e->where);
return FAILURE;
}
+ /* TS 29113, C535b. */
+ if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || (sym->ts.type != BT_CLASS && sym->as
+ && sym->as->type == AS_ASSUMED_RANK))
+ && !assumed_rank_type_expr_allowed)
+ {
+ gfc_error ("Invalid expression with assumed-rank variable %s at %L",
+ sym->name, &e->where);
+ return FAILURE;
+ }
+
/* TS 29113, 407b. */
if (e->ts.type == BT_ASSUMED && e->ref
&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
@@ -5084,6 +5127,22 @@ resolve_variable (gfc_expr *e)
return FAILURE;
}
+ /* TS 29113, C535b. */
+ if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || (sym->ts.type != BT_CLASS && sym->as
+ && sym->as->type == AS_ASSUMED_RANK))
+ && e->ref
+ && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+ && e->ref->next == NULL))
+ {
+ gfc_error ("Assumed-rank variable %s with designator at %L",
+ sym->name, &e->ref->u.ar.where);
+ return FAILURE;
+ }
+
+
/* If this is an associate-name, it may be parsed with an array reference
in error even though the target is scalar. Fail directly in this case.
TODO Understand why class scalar expressions must be excluded. */
@@ -5584,7 +5643,7 @@ update_ppc_arglist (gfc_expr* e)
return FAILURE;
/* F08:R739. */
- if (po->rank > 0)
+ if (po->rank != 0)
{
gfc_error ("Passed-object at %L must be scalar", &e->where);
return FAILURE;
@@ -5632,7 +5691,7 @@ check_typebound_baseobject (gfc_expr* e)
/* F08:C1230. If the procedure called is NOPASS,
the base object must be scalar. */
- if (e->value.compcall.tbp->nopass && base->rank > 0)
+ if (e->value.compcall.tbp->nopass && base->rank != 0)
{
gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
" be scalar", &e->where);
@@ -10319,10 +10378,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
if (allocatable)
{
- if (dimension)
+ if (dimension && as->type != AS_ASSUMED_RANK)
{
- gfc_error ("Allocatable array '%s' at %L must have "
- "a deferred shape", sym->name, &sym->declared_at);
+ gfc_error ("Allocatable array '%s' at %L must have a deferred "
+ "shape or assumed rank", sym->name, &sym->declared_at);
return FAILURE;
}
else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
@@ -10331,10 +10390,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
return FAILURE;
}
- if (pointer && dimension)
+ if (pointer && dimension && as->type != AS_ASSUMED_RANK)
{
- gfc_error ("Array pointer '%s' at %L must have a deferred shape",
- sym->name, &sym->declared_at);
+ gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
+ "deferred rank", sym->name, &sym->declared_at);
return FAILURE;
}
}
@@ -10948,7 +11007,7 @@ gfc_resolve_finalizers (gfc_symbol* derived)
}
/* Warn if the procedure is non-scalar and not assumed shape. */
- if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
+ if (gfc_option.warn_surprising && arg->as && arg->as->rank != 0
&& arg->as->type != AS_ASSUMED_SHAPE)
gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
" shape argument", &arg->declared_at);
@@ -11461,7 +11520,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
}
gcc_assert (me_arg->ts.type == BT_CLASS);
- if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
+ if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
{
gfc_error ("Passed-object dummy argument of '%s' at %L must be"
" scalar", proc->name, &where);
@@ -12475,6 +12534,20 @@ resolve_symbol (gfc_symbol *sym)
&sym->declared_at);
return;
}
+ /* TS 29113, C535a. */
+ if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy)
+ {
+ gfc_error ("Assumed-rank array at %L must be a dummy argument",
+ &sym->declared_at);
+ return;
+ }
+ if (as->type == AS_ASSUMED_RANK
+ && (sym->attr.codimension || sym->attr.value))
+ {
+ gfc_error ("Assumed-rank array at %L may not have the VALUE or "
+ "CODIMENSION attribute", &sym->declared_at);
+ return;
+ }
}
/* Make sure symbols with known intent or optional are really dummy
@@ -12547,6 +12620,13 @@ resolve_symbol (gfc_symbol *sym)
sym->name, &sym->declared_at);
return;
}
+ if (sym->attr.intent == INTENT_OUT)
+ {
+ gfc_error ("Assumed-type variable %s at %L may not have the "
+ "INTENT(OUT) attribute",
+ sym->name, &sym->declared_at);
+ return;
+ }
if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
{
gfc_error ("Assumed-type variable %s at %L shall not be an "
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 1578db1..10f654d 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2934,7 +2934,6 @@ gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
}
-
gfc_expr *
gfc_simplify_is_iostat_end (gfc_expr *x)
{
@@ -3380,7 +3379,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
done:
- if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
+ if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
+ || as->type == AS_ASSUMED_RANK))
return NULL;
if (dim == NULL)
@@ -3442,13 +3442,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
d = mpz_get_si (dim->value.integer);
- if (d < 1 || d > array->rank
+ if ((d < 1 || d > array->rank)
|| (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
{
gfc_error ("DIM argument at %L is out of bounds", &dim->where);
return &gfc_bad_expr;
}
+ if (as && as->type == AS_ASSUMED_RANK)
+ return NULL;
+
return simplify_bound_dim (array, kind, d, upper, as, ref, false);
}
}
@@ -4779,6 +4782,10 @@ gfc_simplify_range (gfc_expr *e)
gfc_expr *
gfc_simplify_rank (gfc_expr *e)
{
+ /* Assumed rank. */
+ if (e->rank == -1)
+ return NULL;
+
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
}
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index f135af1..6c58a8e 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -311,6 +311,7 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim)
if (integer_zerop (dim)
&& (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_ASSUMED_RANK_CONT
||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
return gfc_index_one_node;
@@ -6906,9 +6907,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
}
if (!sym->attr.pointer
- && sym->as
- && sym->as->type != AS_ASSUMED_SHAPE
- && !sym->attr.allocatable)
+ && sym->as
+ && sym->as->type != AS_ASSUMED_SHAPE
+ && sym->as->type != AS_ASSUMED_RANK
+ && !sym->attr.allocatable)
{
/* Some variables are declared directly, others are declared as
pointers and allocated on the heap. */
@@ -6944,10 +6946,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
no_pack = ((sym && sym->as
&& !sym->attr.pointer
&& sym->as->type != AS_DEFERRED
+ && sym->as->type != AS_ASSUMED_RANK
&& sym->as->type != AS_ASSUMED_SHAPE)
||
(ref && ref->u.ar.as
&& ref->u.ar.as->type != AS_DEFERRED
+ && ref->u.ar.as->type != AS_ASSUMED_RANK
&& ref->u.ar.as->type != AS_ASSUMED_SHAPE)
||
gfc_is_simply_contiguous (expr, false));
@@ -8319,12 +8323,15 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
break;
case AR_FULL:
- newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
+ newss = gfc_get_array_ss (ss, expr,
+ ar->as->rank < 0 ? GFC_MAX_DIMENSIONS
+ : ar->as->rank,
+ GFC_SS_SECTION);
newss->info->data.array.ref = ref;
/* Make sure array is the same as array(:,:), this way
we don't need to special case all the time. */
- ar->dimen = ar->as->rank;
+ ar->dimen = ar->as->rank < 0 ? GFC_MAX_DIMENSIONS : ar->as->rank;
for (n = 0; n < ar->dimen; n++)
{
ar->dimen_type[n] = DIMEN_RANGE;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 75a2160..f1b7444 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -933,7 +933,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
int n;
bool known_size;
- if (sym->attr.pointer || sym->attr.allocatable)
+ if (sym->attr.pointer || sym->attr.allocatable
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
return dummy;
/* Add to list of variables if not a fake result variable. */
@@ -3669,6 +3670,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
break;
+ case AS_ASSUMED_RANK:
case AS_DEFERRED:
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, block);
@@ -4782,7 +4784,8 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
dummy argument is an array. (See "Sequence association" in
Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
if (fsym->attr.pointer || fsym->attr.allocatable
- || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
+ || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK)))
{
comparison = NE_EXPR;
message = _("Actual string length does not match the declared one"
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7d1a6d4..791b410 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -730,7 +730,8 @@ gfc_conv_expr_present (gfc_symbol * sym)
as actual argument to denote absent dummies. For array descriptors,
we thus also need to check the array descriptor. */
if (!sym->attr.pointer && !sym->attr.allocatable
- && sym->as && sym->as->type == AS_ASSUMED_SHAPE
+ && sym->as && (sym->as->type == AS_ASSUMED_SHAPE
+ || sym->as->type == AS_ASSUMED_RANK)
&& (gfc_option.allow_std & GFC_STD_F2008) != 0)
{
tree tmp;
@@ -1325,7 +1326,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
/* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
if ((sym->attr.pointer || sym->attr.allocatable
- || gfc_is_associate_pointer (sym))
+ || gfc_is_associate_pointer (sym)
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result
@@ -3769,7 +3771,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
bool f;
f = (fsym != NULL)
&& !(fsym->attr.pointer || fsym->attr.allocatable)
- && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
+ && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE
+ && fsym->as->type != AS_ASSUMED_RANK;
if (comp)
f = f || !comp->attr.always_explicit;
else
@@ -3878,12 +3881,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
but do not always set fsym. */
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional
- && ((e->rank > 0 && sym->attr.elemental)
+ && ((e->rank != 0 && sym->attr.elemental)
|| e->representation.length || e->ts.type == BT_CHARACTER
- || (e->rank > 0
+ || (e->rank != 0
&& (fsym == NULL
|| (fsym-> as
&& (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK
|| fsym->as->type == AS_DEFERRED))))))
gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
e->representation.length);
@@ -4129,7 +4133,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp = caf_decl;
}
- if (fsym->as->type == AS_ASSUMED_SHAPE)
+ if (fsym->as->type == AS_ASSUMED_SHAPE
+ || (fsym->as->type == AS_ASSUMED_RANK && !fsym->attr.pointer
+ && !fsym->attr.allocatable))
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index c74e81a..db2a486 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1316,29 +1316,37 @@ trans_num_images (gfc_se * se)
}
+static tree
+get_rank_from_desc (tree desc)
+{
+ tree tmp;
+ tree dtype;
+
+ dtype = gfc_conv_descriptor_dtype (desc);
+ tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
+ tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
+ dtype, tmp);
+ return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+}
+
+
static void
gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
{
gfc_se argse;
gfc_ss *ss;
- tree dtype, tmp;
ss = gfc_walk_expr (expr->value.function.actual->expr);
gcc_assert (ss != gfc_ss_terminator);
gfc_init_se (&argse, NULL);
argse.data_not_needed = 1;
- argse.want_pointer = 1;
+ argse.descriptor_only = 1;
gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr);
- argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr);
- dtype = gfc_conv_descriptor_dtype (argse.expr);
- tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
- tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
- dtype, tmp);
- se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+
+ se->expr = get_rank_from_desc (argse.expr);
}
@@ -1360,6 +1368,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
gfc_se argse;
gfc_ss *ss;
gfc_array_spec * as;
+ bool assumed_rank_lb_one;
arg = expr->value.function.actual;
arg2 = arg->next;
@@ -1401,27 +1410,40 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
desc = argse.expr;
+ as = gfc_get_full_arrayspec_from_expr (arg->expr);
+
+ /* FIXME: Why is this extra indirect_ref required? */
+/* if (as->type == AS_ASSUMED_RANK)
+ desc = build_fold_indirect_ref_loc (input_location, desc);*/
+
if (INTEGER_CST_P (bound))
{
int hi, low;
hi = TREE_INT_CST_HIGH (bound);
low = TREE_INT_CST_LOW (bound);
- if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+ if (hi || low < 0
+ || ((!as || as->type != AS_ASSUMED_RANK)
+ && low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+ || low > GFC_MAX_DIMENSIONS)
gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
"dimension index", upper ? "UBOUND" : "LBOUND",
&expr->where);
}
- else
+
+ if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
{
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
bound = gfc_evaluate_now (bound, &se->pre);
cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
bound, build_int_cst (TREE_TYPE (bound), 0));
- tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
+ if (as && as->type == AS_ASSUMED_RANK)
+ tmp = get_rank_from_desc (desc);
+ else
+ tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
- bound, tmp);
+ bound, fold_convert(TREE_TYPE (bound), tmp));
cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
boolean_type_node, cond, tmp);
gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
@@ -1429,11 +1451,19 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
}
}
+ /* Take care of the lbound shift for assumed-rank arrays, which are
+ nonallocatable and nonpointers. Those has a lbound of 1. */
+ assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
+ && ((arg->expr->ts.type != BT_CLASS
+ && !arg->expr->symtree->n.sym->attr.allocatable
+ && !arg->expr->symtree->n.sym->attr.pointer)
+ || (arg->expr->ts.type == BT_CLASS
+ && !CLASS_DATA (arg->expr)->attr.allocatable
+ && !CLASS_DATA (arg->expr)->attr.class_pointer));
+
ubound = gfc_conv_descriptor_ubound_get (desc, bound);
lbound = gfc_conv_descriptor_lbound_get (desc, bound);
- as = gfc_get_full_arrayspec_from_expr (arg->expr);
-
/* 13.14.53: Result value for LBOUND
Case (i): For an array section or for an array expression other than a
@@ -1455,7 +1485,9 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
not have size zero and has value zero if dimension DIM has
size zero. */
- if (as)
+ if (!upper && assumed_rank_lb_one)
+ se->expr = gfc_index_one_node;
+ else if (as)
{
tree stride = gfc_conv_descriptor_stride_get (desc, bound);
@@ -1481,9 +1513,19 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
boolean_type_node, cond, cond5);
+ if (assumed_rank_lb_one)
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, ubound, lbound);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp, gfc_index_one_node);
+ }
+ else
+ tmp = ubound;
+
se->expr = fold_build3_loc (input_location, COND_EXPR,
gfc_array_index_type, cond,
- ubound, gfc_index_zero_node);
+ tmp, gfc_index_zero_node);
}
else
{
@@ -5856,8 +5898,15 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
present. */
arg1se.descriptor_only = 1;
gfc_conv_expr_lhs (&arg1se, arg1->expr);
- tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
- gfc_rank_cst[arg1->expr->rank - 1]);
+ if (arg1->expr->rank == -1)
+ {
+ tmp = get_rank_from_desc (arg1se.expr);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE (tmp), tmp, gfc_index_one_node);
+ }
+ else
+ tmp = gfc_rank_cst[arg1->expr->rank - 1];
+ tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index aa50e3d..8b1caf8 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1277,7 +1277,8 @@ gfc_is_nodesc_array (gfc_symbol * sym)
return 0;
if (sym->attr.dummy)
- return sym->as->type != AS_ASSUMED_SHAPE;
+ return sym->as->type != AS_ASSUMED_SHAPE
+ && sym->as->type != AS_ASSUMED_RANK;
if (sym->attr.result || sym->attr.function)
return 0;
@@ -1299,6 +1300,13 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
tree ubound[GFC_MAX_DIMENSIONS];
int n;
+ if (as->type == AS_ASSUMED_RANK)
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ {
+ lbound[n] = NULL_TREE;
+ ubound[n] = NULL_TREE;
+ }
+
for (n = 0; n < as->rank; n++)
{
/* Create expressions for the known bounds of the array. */
@@ -1323,7 +1331,12 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
if (as->type == AS_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,
+ else if (as->type == AS_ASSUMED_RANK)
+ akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
+ : GFC_ARRAY_ASSUMED_RANK;
+ return gfc_get_array_type_bounds (type, as->rank == -1
+ ? GFC_MAX_DIMENSIONS : as->rank,
+ as->corank, lbound,
ubound, 0, akind, restricted);
}
\f
@@ -1682,7 +1695,13 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
{
tree fat_type, decl, arraytype, *chain = NULL;
char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
- int idx = 2 * (codimen + dimen - 1) + restricted;
+ int idx;
+
+ /* Assumed-rank array. */
+ if (dimen == -1)
+ dimen = GFC_MAX_DIMENSIONS;
+
+ idx = 2 * (codimen + dimen - 1) + restricted;
gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 3b77281..d4092f7 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -765,6 +765,8 @@ enum gfc_array_kind
GFC_ARRAY_UNKNOWN,
GFC_ARRAY_ASSUMED_SHAPE,
GFC_ARRAY_ASSUMED_SHAPE_CONT,
+ GFC_ARRAY_ASSUMED_RANK,
+ GFC_ARRAY_ASSUMED_RANK_CONT,
GFC_ARRAY_ALLOCATABLE,
GFC_ARRAY_POINTER,
GFC_ARRAY_POINTER_CONT
--- /dev/null 2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_1.f90 2012-06-24 15:17:36.000000000 +0200
@@ -0,0 +1,145 @@
+! { dg-do run }
+! { dg-additional-sources assumed_rank_1_c.c }
+!
+! PR fortran/48820
+!
+! Assumed-rank tests
+!
+
+implicit none
+
+interface
+ subroutine check_value(b, n, val)
+ integer :: b(..)
+ integer, value :: n
+ integer :: val(n)
+ end subroutine
+end interface
+
+integer, target :: x(2:5,4:7), y(-4:4)
+integer, allocatable, target :: z(:,:,:,:)
+integer, allocatable :: val(:)
+integer :: i
+
+allocate(z(1:4, -2:5, 4, 10:11))
+
+if (rank(x) /= 2) call abort ()
+val = [(2*i+3, i = 1, size(x))]
+x = reshape (val, shape(x))
+call foo(x, rank(x), lbound(x), ubound(x), val)
+call foo2(x, rank(x), lbound(x), ubound(x), val)
+call bar(x,x,.true.)
+call bar(x,prsnt=.false.)
+
+if (rank(y) /= 1) call abort ()
+val = [(2*i+7, i = 1, size(y))]
+y = reshape (val, shape(y))
+call foo(y, rank(y), lbound(y), ubound(y), val)
+call foo2(y, rank(y), lbound(y), ubound(y), val)
+call bar(y,y,.true.)
+call bar(y,prsnt=.false.)
+
+if (rank(z) /= 4) call abort ()
+val = [(2*i+5, i = 1, size(z))]
+z(:,:,:,:) = reshape (val, shape(z))
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo2(z, rank(z), lbound(z), ubound(z), val)
+call bar(z,z,.true.)
+call bar(z,prsnt=.false.)
+
+contains
+ subroutine bar(a,b, prsnt)
+ integer, pointer, optional, intent(in) :: a(..),b(..)
+ logical, value :: prsnt
+ ! The following is not valid, but it goes past the constraint check
+ ! Technically, it could be allowed and might be in Fortran 2015:
+ if (.not. associated(a)) call abort()
+ if (present(b)) then
+ if (.not. associated(a,b)) call abort()
+ else
+ if (.not. associated(a)) call abort()
+ end if
+ if (.not. present(a)) call abort()
+ if (prsnt .neqv. present(b)) call abort()
+ end subroutine
+
+ ! POINTER argument - bounds as specified before
+ subroutine foo(a, rnk, low, high, val)
+ integer,pointer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (low(1) /= lbound(a,1)) call abort()
+ if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (low(i) /= lbound(a,i)) call abort()
+ if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call check_value (a, rnk, val)
+ call foo2(a, rnk, low, high, val)
+ end subroutine
+
+ ! Non-pointer, non-allocatable bounds. lbound == 1
+ subroutine foo2(a, rnk, low, high, val)
+ integer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (1 /= lbound(a,1)) call abort()
+ if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (1 /= lbound(a,i)) call abort()
+ if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call check_value (a, rnk, val)
+ end subroutine foo2
+
+ ! ALLOCATABLE argument - bounds as specified before
+ subroutine foo3 (a, rnk, low, high, val)
+ integer, allocatable, intent(in), target :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (low(1) /= lbound(a,1)) call abort()
+ if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (low(i) /= lbound(a,i)) call abort()
+ if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call check_value (a, rnk, val)
+ call foo(a, rnk, low, high, val)
+ end subroutine
+end
--- /dev/null 2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_1_c.c 2012-06-24 12:58:44.000000000 +0200
@@ -0,0 +1,16 @@
+/* Called by assumed_rank_1.f90. */
+
+#include <stdlib.h> /* For abort(). */
+
+struct array {
+ int *data;
+};
+
+void check_value_ (struct array *b, int n, int val[])
+{
+ int i;
+
+ for (i = 0; i < n; i++)
+ if (b->data[i] != val[i])
+ abort ();
+}
--- /dev/null 2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_2.f90 2012-06-24 15:17:39.000000000 +0200
@@ -0,0 +1,135 @@
+! { dg-do run }
+! { dg-options "-fcheck=all" }
+!
+! PR fortran/48820
+!
+! Assumed-rank tests - same as assumed_rank_1.f90,
+! but with bounds checks and w/o call to C function
+!
+
+implicit none
+
+integer, target :: x(2:5,4:7), y(-4:4)
+integer, allocatable, target :: z(:,:,:,:)
+integer, allocatable :: val(:)
+integer :: i
+
+allocate(z(1:4, -2:5, 4, 10:11))
+
+if (rank(x) /= 2) call abort ()
+val = [(2*i+3, i = 1, size(x))]
+x = reshape (val, shape(x))
+call foo(x, rank(x), lbound(x), ubound(x), val)
+call foo2(x, rank(x), lbound(x), ubound(x), val)
+call bar(x,x,.true.)
+call bar(x,prsnt=.false.)
+
+if (rank(y) /= 1) call abort ()
+val = [(2*i+7, i = 1, size(y))]
+y = reshape (val, shape(y))
+call foo(y, rank(y), lbound(y), ubound(y), val)
+call foo2(y, rank(y), lbound(y), ubound(y), val)
+call bar(y,y,.true.)
+call bar(y,prsnt=.false.)
+
+if (rank(z) /= 4) call abort ()
+val = [(2*i+5, i = 1, size(z))]
+z(:,:,:,:) = reshape (val, shape(z))
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo2(z, rank(z), lbound(z), ubound(z), val)
+call bar(z,z,.true.)
+call bar(z,prsnt=.false.)
+
+contains
+ subroutine bar(a,b, prsnt)
+ integer, pointer, optional, intent(in) :: a(..),b(..)
+ logical, value :: prsnt
+ ! The following is not valid, but it goes past the constraint check
+ ! Technically, it could be allowed and might be in Fortran 2015:
+ if (.not. associated(a)) call abort()
+ if (present(b)) then
+ if (.not. associated(a,b)) call abort()
+ else
+ if (.not. associated(a)) call abort()
+ end if
+ if (.not. present(a)) call abort()
+ if (prsnt .neqv. present(b)) call abort()
+ end subroutine
+
+ ! POINTER argument - bounds as specified before
+ subroutine foo(a, rnk, low, high, val)
+ integer,pointer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (low(1) /= lbound(a,1)) call abort()
+ if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (low(i) /= lbound(a,i)) call abort()
+ if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call foo2(a, rnk, low, high, val)
+ end subroutine
+
+ ! Non-pointer, non-allocatable bounds. lbound == 1
+ subroutine foo2(a, rnk, low, high, val)
+ integer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (1 /= lbound(a,1)) call abort()
+ if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (1 /= lbound(a,i)) call abort()
+ if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ end subroutine foo2
+
+ ! ALLOCATABLE argument - bounds as specified before
+ subroutine foo3 (a, rnk, low, high, val)
+ integer, allocatable, intent(in), target :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (low(1) /= lbound(a,1)) call abort()
+ if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (low(i) /= lbound(a,i)) call abort()
+ if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call foo(a, rnk, low, high, val)
+ end subroutine
+end
--- /dev/null 2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_3.f90 2012-06-24 15:17:43.000000000 +0200
@@ -0,0 +1,19 @@
+! { dg-do run }
+! { dg-options "-fcheck=bounds" }
+! { dg-shouldfail "Array reference out of bounds" }
+!
+! PR fortran/48820
+!
+! Do assumed-rank bound checking
+
+implicit none
+integer :: a(4,4)
+call bar(a)
+contains
+ subroutine bar(x)
+ integer :: x(..)
+ print *, ubound(x,dim=3) ! << wrong dim
+ end subroutine
+end
+
+! { dg-output "Fortran runtime error: Array reference out of bounds" }
--- /dev/null 2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_4.f90 2012-06-24 15:17:46.000000000 +0200
@@ -0,0 +1,49 @@
+! { dg-do compile }
+! { dg-options "-std=f2008ts" }
+!
+! PR fortran/48820
+!
+! Assumed-rank constraint checks and other diagnostics
+!
+
+subroutine valid1a(x)
+ integer, intent(in), pointer, contiguous :: x(..)
+end subroutine valid1a
+
+subroutine valid1(x)
+ integer, intent(in) :: x(..)
+end subroutine valid1
+
+subroutine valid2(x)
+ type(*) :: x
+end subroutine valid2
+
+subroutine foo99(x)
+ integer x(99)
+ call valid1(x) ! { dg-error "Procedure 'valid1' at .1. with assumed-rank dummy argument 'x' must have an explicit interface" }
+ call valid2(x(1)) ! { dg-error "Procedure 'valid2' at .1. with assumed-type dummy argument 'x' must have an explicit interface" }
+end subroutine foo99
+
+subroutine foo(x)
+ integer :: x(..)
+ print *, ubound(x,dim=2000) ! { dg-error "is not a valid dimension index" }
+ call bar(x) ! { dg-error "Assumed-rank argument requires an explicit interface" }
+ call intnl(x) ! { dg-error "requires that the dummy argument 'x' has assumed-rank" }
+contains
+ subroutine intnl(x)
+ integer :: x(:)
+ end subroutine intnl
+end subroutine foo
+
+subroutine foo2(x)
+ integer :: x(..)
+ call valid3(x(:)) ! { dg-error "Assumed-rank variable x with designator" }
+contains
+ subroutine valid3(y)
+ integer :: y(..)
+ end subroutine
+end subroutine
+
+subroutine foo3()
+ integer :: x(..) ! { dg-error "Assumed-rank array at .1. must be a dummy argument" }
+end subroutine
--- /dev/null 2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_5.f90 2012-06-24 15:17:51.000000000 +0200
@@ -0,0 +1,9 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/48820
+!
+!
+subroutine foo(x)
+ integer :: x(..) ! { dg-error "TS 29113: Assumed-rank array" }
+end subroutine foo
--- /dev/null 2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_6.f90 2012-06-24 15:17:57.000000000 +0200
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/48820
+!
+! Assumed-rank constraint checks and other diagnostics
+!
+
+subroutine foo(x) ! { dg-error "Assumed-type variable x at .1. may not have the INTENT.OUT. attribute" }
+ type(*), intent(out) :: x
+end subroutine
+
+subroutine bar(x)
+ integer, intent(out) :: x(..)
+end subroutine bar
+
+subroutine foo3(y)
+ integer :: y(..)
+ y = 7 ! { dg-error "Invalid expression with assumed-rank variable" }
+ print *, y + 10 ! { dg-error "Invalid expression with assumed-rank variable" }
+ print *, y ! { dg-error "Invalid expression with assumed-rank variable" }
+end subroutine
+
+subroutine foo2(x, y)
+ integer :: x(..), y(..)
+ call valid3(x(:)) ! { dg-error "Assumed-rank variable x with designator" }
+contains
+ subroutine valid3(y)
+ integer :: y(..)
+ end subroutine
+end subroutine
+
+subroutine foo4(x) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
+ integer, codimension[*] :: x(..)
+end subroutine
+
+subroutine foo5(y) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
+ integer :: y(..)[*]
+end subroutine
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-06-24 15:48 ` Tobias Burnus
@ 2012-07-05 13:52 ` Mikael Morin
2012-07-06 21:13 ` Tobias Burnus
2012-07-13 7:51 ` Tobias Burnus
0 siblings, 2 replies; 18+ messages in thread
From: Mikael Morin @ 2012-07-05 13:52 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
On 24.06.2012 17:34, Tobias Burnus wrote:
> Tobias Burnus wrote:
>> To cleanup my local trees; I had the patch lingering there for a many
>> weeks. User visible, it only adds parsing support for "dimension(..)"
>> and a sorry message.
>
> I have now updated the patch. Changes:
>
Hello,
some commen^Wbike shedding below. Overall it looks good.
I may have missed the point about the way you handle diagnostics.
Mikael
> diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
> index 7d505d5..b0c4b28 100644
> --- a/gcc/fortran/check.c
> +++ b/gcc/fortran/check.c
> @@ -619,6 +619,10 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
> else
> rank = array->rank;
>
> + /* Assumed-rank array. */
> + if (rank == -1)
> + rank = GFC_MAX_DIMENSIONS;
> +
I think the assumed-rank => rank == -1 convention should be documented
in gfortran.h, at least for the gfc_array_spec::rank field.
> @@ -2990,6 +3008,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
> gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
> return;
> }
> +
> + /* TS 29113, C407b. */
> + if (a->expr && a->expr->expr_type == EXPR_VARIABLE
> + && symbol_rank (a->expr->symtree->n.sym) == -1)
> + {
> + gfc_error ("Assumed-rank argument requires an explicit interface "
> + "at %L", &a->expr->where);
> + return;
> + }
> }
>
> return;
Doesn't this duplicates the other explicit interface diagnostic below...
> @@ -2194,6 +2206,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
> sym->name, &sym->declared_at, arg->sym->name);
> break;
> }
> + /* TS 29113, 6.2. */
> + else if (arg->sym && arg->sym->as
> + && arg->sym->as->type == AS_ASSUMED_RANK)
> + {
> + gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
> + "argument '%s' must have an explicit interface",
> + sym->name, &sym->declared_at, arg->sym->name);
> + break;
> + }
> /* F2008, 12.4.2.2 (2c) */
> else if (arg->sym->attr.codimension)
> {
... here?
> @@ -5067,13 +5097,26 @@ resolve_variable (gfc_expr *e)
> sym = e->symtree->n.sym;
>
> /* TS 29113, 407b. */
> - if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
> + if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed)
> {
> gfc_error ("Invalid expression with assumed-type variable %s at %L",
> sym->name, &e->where);
> return FAILURE;
> }
I'm not sure I understand the logic with the mixed assumed rank/type
flag. According to C407c, shouldn't we check that e is assumed rank/shape?
>
> + /* TS 29113, C535b. */
> + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
> + && CLASS_DATA (sym)->as
> + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
> + || (sym->ts.type != BT_CLASS && sym->as
> + && sym->as->type == AS_ASSUMED_RANK))
> + && !assumed_rank_type_expr_allowed)
> + {
> + gfc_error ("Invalid expression with assumed-rank variable %s at %L",
> + sym->name, &e->where);
The error message could be made more helpful. ;-)
> @@ -5084,6 +5127,22 @@ resolve_variable (gfc_expr *e)
> return FAILURE;
> }
>
> + /* TS 29113, C535b. */
> + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
> + && CLASS_DATA (sym)->as
> + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
> + || (sym->ts.type != BT_CLASS && sym->as
> + && sym->as->type == AS_ASSUMED_RANK))
> + && e->ref
> + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
> + && e->ref->next == NULL))
> + {
> + gfc_error ("Assumed-rank variable %s with designator at %L",
> + sym->name, &e->ref->u.ar.where);
Ditto here. And I think that C535b is more about the context of the
expression rather than the expression itself.
> diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
> index f135af1..6c58a8e 100644
> --- a/gcc/fortran/trans-array.c
> +++ b/gcc/fortran/trans-array.c
> @@ -8319,12 +8323,15 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
> break;
>
> case AR_FULL:
> - newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
> + newss = gfc_get_array_ss (ss, expr,
> + ar->as->rank < 0 ? GFC_MAX_DIMENSIONS
> + : ar->as->rank,
> + GFC_SS_SECTION);
> newss->info->data.array.ref = ref;
>
> /* Make sure array is the same as array(:,:), this way
> we don't need to special case all the time. */
> - ar->dimen = ar->as->rank;
> + ar->dimen = ar->as->rank < 0 ? GFC_MAX_DIMENSIONS : ar->as->rank;
> for (n = 0; n < ar->dimen; n++)
> {
> ar->dimen_type[n] = DIMEN_RANGE;
I would rather avoid that if possible.
The scalarizer assumes the rank is known, and all hell breaks loose if
it's not the case.
After quickly browsing through TS29113, I couldn't tell whether
expressions like (ar + 1) would be valid as assumed rank actual argument.
In case it is, gfc_conv_expr_descriptor won't work correctly, as it will
hardcode exactly GFC_MAX_DIMENSIONS loops to set the temporary,
accessing the array descriptor's fields (i.e. bounds, etc) beyond the
maximal dimension.
In case it's not, then everything is fine I guess, though I prefer
avoiding polluting the scalarizer with assumed rank stuff ;-).
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-05 13:52 ` Mikael Morin
@ 2012-07-06 21:13 ` Tobias Burnus
2012-07-12 19:40 ` Mikael Morin
2012-07-13 7:51 ` Tobias Burnus
1 sibling, 1 reply; 18+ messages in thread
From: Tobias Burnus @ 2012-07-06 21:13 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran
Hi Mikael, hi all,
Mikael Morin wrote:
>> index f135af1..6c58a8e 100644
>> --- a/gcc/fortran/trans-array.c
>> +++ b/gcc/fortran/trans-array.c
>> @@ -8319,12 +8323,15 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr *
>> expr, gfc_ref * ref)
>> break;
>>
>> case AR_FULL:
>> - newss = gfc_get_array_ss (ss, expr, ar->as->rank,
>> GFC_SS_SECTION);
>> + newss = gfc_get_array_ss (ss, expr,
>> + ar->as->rank < 0 ? GFC_MAX_DIMENSIONS
>> + : ar->as->rank,
>> + GFC_SS_SECTION);
>> newss->info->data.array.ref = ref;
>>
>> /* Make sure array is the same as array(:,:), this way
>> we don't need to special case all the time. */
>> - ar->dimen = ar->as->rank;
>> + ar->dimen = ar->as->rank < 0 ? GFC_MAX_DIMENSIONS : ar->as->rank;
>> for (n = 0; n < ar->dimen; n++)
>> {
>> ar->dimen_type[n] = DIMEN_RANGE;
> diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
>
> I would rather avoid that if possible.
Maybe it is. However, the following has to work:
- ubound(assumed_rank, dim=i), ditto for lbound
- size(ar), size(ar, dim=i)
(That works with the current patch.) Furthermore, but unsupported, the
following has to work:
- ubound(ar), lbound(ar) and shape(ar)
- Passing a class-actual assumed-rank variable to a derived-type
assumed-rank dummy argument. (Required for packing - at least if the
dummy is contiguous).
And for internal use for the FINAL wrapper function, but invalid
according to the Technical Specification:
- call elemental_subroutine(ar)
> The scalarizer assumes the rank is known, and all hell breaks loose if
> it's not the case.
> After quickly browsing through TS29113, I couldn't tell whether
> expressions like (ar + 1) would be valid as assumed rank actual argument.
No, you are only allowed to do very few things with assumed rank arrays:
* Passing them as first argument to the intrinsic inquiry functions like
PRESENT, ALLOCATED, ASSOCIATED, UBOUND, LBOUND, SHAPE and SIZE. (And
some more like KIND but they aren't interesting.)
* Passing them to an assumed-rank procedure. (Here, allowed are:
class->type, type->class, class->class, type->type and also
non-simply-contiguous -> CONTIGUOUS, which implies a packing for the
argument).
* As first argument to C_LOC
All other impressions and anything like "ar(:)" or "ar(1)" etc. aren't
allowed.
> In case it's not, then everything is fine I guess, though I prefer
> avoiding polluting the scalarizer with assumed rank stuff ;-).
It still will get worse, see above. Though, I wouldn't mind if you could
modify the scalarizer. My next patch will be to pass scalars to assumed
rank. It is mostly done, but it still has some issues.
Tobias
PS: I will reply later to the other issues raised in your review.
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-06 21:13 ` Tobias Burnus
@ 2012-07-12 19:40 ` Mikael Morin
2012-07-12 20:08 ` Tobias Burnus
0 siblings, 1 reply; 18+ messages in thread
From: Mikael Morin @ 2012-07-12 19:40 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
On 06/07/2012 23:13, Tobias Burnus wrote:
>> In case it's not, then everything is fine I guess, though I prefer
>> avoiding polluting the scalarizer with assumed rank stuff ;-).
>
> It still will get worse, see above. Though, I wouldn't mind if you could
> modify the scalarizer.
I don't see how I could. The scalarizer's purpose is translating array
statements like foo(:,:) = bar(:,:), where the rank at least is supposed
known, so that we know how many nested loops we have to generate. If
the number of loops is known at runtime only, hem, I don't see what code
we could generate. We could probably produce something with complex
conditions and gotos in a single loop, but it seems to me far too
convoluted, and too big a change, in an area that already doesn't lack
complexity without it.
On the other hand, if I look at what should be supported, it doesn't
look that bad. There are only full array references, so
gfc_conv_expr_descriptor with the flag se->descriptor_only should do the
right thing (i.e. nothing). Class vs. type should be (correct me if I'm
wrong) a matter of decorating/undecorating with a class container. As
for the contiguous/non-contiguous matter, I propose using libgfortran's
internal_{,un}pack and away with it.
Now about the implementation, I guess the devil is in the details.
I'll see if there is something that I obviously forgot or something to
do in gfc_conv_expr_descriptor. Maybe that one (not the whole
scalarizer) could use a fix.
Mikael
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-12 19:40 ` Mikael Morin
@ 2012-07-12 20:08 ` Tobias Burnus
0 siblings, 0 replies; 18+ messages in thread
From: Tobias Burnus @ 2012-07-12 20:08 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran
Mikael Morin wrote:
> I don't see how I could. The scalarizer's purpose is translating array
> statements like foo(:,:) = bar(:,:), where the rank at least is supposed
> known, so that we know how many nested loops we have to generate. If
> the number of loops is known at runtime only, hem, I don't see what code
> we could generate. We could probably produce something with complex
> conditions and gotos in a single loop, but it seems to me far too
> convoluted, and too big a change, in an area that already doesn't lack
> complexity without it.
>
> On the other hand, if I look at what should be supported, it doesn't
> look that bad.
Concurred to both.
> There are only full array references, so gfc_conv_expr_descriptor with the flag se->descriptor_only should do the right thing (i.e. nothing).
That looks kind of okay for SHAPE/LBOUND/UBOUND, but we still need to
create a single loop for filling the rank-one array with the values.
> Class vs. type should be (correct me if I'm wrong) a matter of decorating/undecorating with a class container.
No, that's only simple for TYPE -> CLASS.
Additionally, always if CLASS are involved for arrays with descriptor,
it is not that trival: gfortran has "_data, _vptr" in the class
container - and "_data" is the array descriptor. Hence, the offset from
the beginning of the class container to _vptr varies depending on the
size of the descriptor (i.e. its rank). However, with some copying
that's handled by my patch (approved part).
Worsed it the CLASS->TYPE: If the actual type is not the declared type
but one requires that the TYPE is packed ("contiguous" attribute), one
needs to pack the actual argument. That's currently done via the
scalarizer. (It is also done if the dummy is not contiguous as gfortran
only has a stride and not a byte-wise stride multiplier.)
> As for the contiguous/non-contiguous matter, I propose using libgfortran's
> internal_{,un}pack and away with it.
Hmm, maybe. I have to check the code.
Another item I really want to have implemented, but it is outside the
scope of the TS29113, but extremely handy internally is the following:
subroutine final_subroutine_wrapper (x)
type(t) :: x
if (rank(x) == 3) then
call rank_3_finalizer (x)
else
call scalar_elemental_finalizer (x)
end subroutine
end
Here, one has to walk "x" for the elemental subroutine. Though, it could
be probably simpler than I feared: "x" does not have component or array
references and it is a whole array. Thus, one can probably simple walk
the array by running
do i = 0, element_sizeof(x)-1
call scalar_elemental_finalizer (x->data + i*elem_sizeof(x))
end do
I have to think about issues with regards to contiguity and strides, but
semantically, "x" is contiguous - the question is only whether it can be
noncontiguous, e.g. when calling:
call parent_final_wrapper (x%parent)
One could do it by packing a temporary - we probably have to do so as we
do not have byte strides, otherwise, one could probably avoid it as only
the first stride multiplier matters.
> Now about the implementation, I guess the devil is in the details.
> I'll see if there is something that I obviously forgot or something to
> do in gfc_conv_expr_descriptor. Maybe that one (not the whole
> scalarizer) could use a fix.
I will try to generate a stripped down patch, which fixes the issues you
raised and ignores the scalarizer. That will make it easier to look at
the other parts as then the diff is more readable.
Thanks for your thoughts.
Tobias
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-05 13:52 ` Mikael Morin
2012-07-06 21:13 ` Tobias Burnus
@ 2012-07-13 7:51 ` Tobias Burnus
2012-07-14 13:26 ` Mikael Morin
1 sibling, 1 reply; 18+ messages in thread
From: Tobias Burnus @ 2012-07-13 7:51 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran
Hi Mikael, dear all,
On 07/05/2012 03:51 PM, Mikael Morin wrote:
> I think the assumed-rank => rank == -1 convention should be
> documented in gfortran.h, at least for the gfc_array_spec::rank field.
Okay. (Done in my version, which is not yet attached.)
>> @@ -2990,6 +3008,15 @@ gfc_procedure_use (gfc_symbol *sym,
>> gfc_actual_arglist **ap, + /* TS 29113, C407b. */
>> + if (a->expr && a->expr->expr_type == EXPR_VARIABLE
>> + && symbol_rank (a->expr->symtree->n.sym) == -1)
>> + gfc_error ("Assumed-rank argument requires an explicit
>> interface "
>> + "at %L", &a->expr->where);
> Doesn't this duplicates the other explicit interface diagnostic below...
>
>
>> @@ -2194,6 +2206,15 @@ resolve_global_procedure (gfc_symbol *sym,
>> locus *where,
>> + /* TS 29113, 6.2. */
>> + else if (arg->sym && arg->sym->as
>> + && arg->sym->as->type == AS_ASSUMED_RANK)
>> + gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
>> + "argument '%s' must have an explicit interface",
>> + sym->name, &sym->declared_at, arg->sym->name);
No, they are different. Example:
! resolve_global_procedure:
! From the global symbol information, one knows in "foo"
! that the dummy argument of "bar" is an assumed-rank array
!
! (the actual argument has no assumed rank)
!
! This check is weak as it only works if both procedures
! are in the same translation unit.
!----------------------
subroutine foo
integer :: x
call bar(x) ! <<< ERROR HERE
end subroutine foo
subroutine bar(y)
integer :: y(..)
end subroutine bar
! gfc_procedure_use:
! The actual argument is assumed rank. Then the dummy argument
! has to be assumed-rank, which requires that the interface must
! be explicit.
!
! Hence, that's a constraint check which has and can be diagnosed
! at compile time. (C407b)
!---------------------
subroutine foobar(z)
integer :: z(..)
call sub(z) ! << ERROR here
end subroutine foobar
!---------------------
>> @@ -5067,13 +5097,26 @@ resolve_variable (gfc_expr *e)
>> /* TS 29113, 407b. */
>> - if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
>> + if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed)
>> {
>> gfc_error ("Invalid expression with assumed-type variable %s
>> at %L",
>> sym->name, &e->where);
>> return FAILURE;
>> }
>
> I'm not sure I understand the logic with the mixed assumed rank/type
> flag. According to C407c, shouldn't we check that e is assumed rank/shape?
No, that check is not for assumed-rank arrays but for (e.g. scalar)
assumed type, TYPE(*). The check handles cases like:
type(*) :: x
print *, ubound(array, dim=x)
where "x" is not allowed, contrary to, e.g.,
type(*) :: x(:)
print *, ubound(x)
Thus, one needs to keep track whether "x" is allowed or is not allowed
in an expression. As that's the same for assumed type and for assumed
rank, I am using the same tracking variable, called
assumed_rank_type_expr_allowed. A better name would be:
assumed_rank_or_assumed_type_expr_allowed (or s/or/and/), however, I
found my version clear enough and while it is already long, that variant
would be even longer.
>>
>> + /* TS 29113, C535b. */
>> + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
>> + && CLASS_DATA (sym)->as
>> + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
>> + || (sym->ts.type != BT_CLASS && sym->as
>> + && sym->as->type == AS_ASSUMED_RANK))
>> + && !assumed_rank_type_expr_allowed)
>> + {
>> + gfc_error ("Invalid expression with assumed-rank variable %s
>> at %L",
>> + sym->name, &e->where);
>
> The error message could be made more helpful. ;-)
Suggestions welcome. Example use would be:
x = x +1
call foo(x+1)
call sin(x) ! Though that probably triggers elsewhere
I don't think the wording is that bad.
>> @@ -5084,6 +5127,22 @@ resolve_variable (gfc_expr *e)
>> return FAILURE;
>> }
>>
>> + /* TS 29113, C535b. */
>> + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
>> + && CLASS_DATA (sym)->as
>> + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
>> + || (sym->ts.type != BT_CLASS && sym->as
>> + && sym->as->type == AS_ASSUMED_RANK))
>> + && e->ref
>> + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
>> + && e->ref->next == NULL))
>> + {
>> + gfc_error ("Assumed-rank variable %s with designator at %L",
>> + sym->name, &e->ref->u.ar.where);
>
> Ditto here. And I think that C535b is more about the context of the
> expression rather than the expression itself.
Here, I am lost. The check is that
ubound(x(:))
call bar (x(1))
call bar2(x([1,3,5])
call bar3(x(1:5:2))
or similar does not occur if "x" is assumed rank. That "(:)" is an
(array) designator. Do you have a better suggestion? I could add the
word "array" before "designator", but I would like to avoid to list all
possible combinations.
From TS29113:
"C407b An assumed-type variable name shall not appear in a designator or
..."
From Fortran 2008:
"1.3.59 designator
name followed by zero or more component selectors, complex part
selectors, array section selectors, array element selectors, image
selectors, and substring selectors (6.1)"
[I think due to the arrayness, the '(:)' has to be inserted if one wants
to use component, complex part, or substring selectors, thus they should
be properly covered.]
Unless you have better wordings, I will later send a slightly updated
patch with some minor changes and the scalarizer part ripped off.
Tobias
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-13 7:51 ` Tobias Burnus
@ 2012-07-14 13:26 ` Mikael Morin
2012-07-15 19:14 ` Tobias Burnus
0 siblings, 1 reply; 18+ messages in thread
From: Mikael Morin @ 2012-07-14 13:26 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
Hello,
I somehow was reading this in the standard:
"An assumed-rank variable name shall not appear in a designator or
expression except as an actual
argument corresponding to a dummy argument that is assumed-rank..."
with "...except in..." instead of "...except as...".
Some of my comments were plain misunderstanding/misinterpretation on my
side.
The next comment iteration is below.
Mikael
On 13/07/2012 09:50, Tobias Burnus wrote:
>>> @@ -5067,13 +5097,26 @@ resolve_variable (gfc_expr *e)
>>> /* TS 29113, 407b. */
>>> - if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
>>> + if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed)
>>> {
>>> gfc_error ("Invalid expression with assumed-type variable %s
>>> at %L",
>>> sym->name, &e->where);
>>> return FAILURE;
>>> }
>>
>> I'm not sure I understand the logic with the mixed assumed rank/type
>> flag. According to C407c, shouldn't we check that e is assumed
>> rank/shape?
>
> No, that check is not for assumed-rank arrays but for (e.g. scalar)
> assumed type, TYPE(*). The check handles cases like:
>
> type(*) :: x
> print *, ubound(array, dim=x)
>
> where "x" is not allowed, contrary to, e.g.,
>
> type(*) :: x(:)
> print *, ubound(x)
>
> Thus, one needs to keep track whether "x" is allowed or is not allowed
> in an expression. As that's the same for assumed type and for assumed
> rank, I am using the same tracking variable, called
> assumed_rank_type_expr_allowed. A better name would be:
> assumed_rank_or_assumed_type_expr_allowed (or s/or/and/), however, I
> found my version clear enough and while it is already long, that variant
> would be even longer.
What about naming the flag in_actual_arg and moving the inquiry_argument
condition to the error condition?
>
>>>
>>> + /* TS 29113, C535b. */
>>> + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
>>> + && CLASS_DATA (sym)->as
>>> + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
>>> + || (sym->ts.type != BT_CLASS && sym->as
>>> + && sym->as->type == AS_ASSUMED_RANK))
>>> + && !assumed_rank_type_expr_allowed)
>>> + {
>>> + gfc_error ("Invalid expression with assumed-rank variable %s
>>> at %L",
>>> + sym->name, &e->where);
>>
>> The error message could be made more helpful. ;-)
>
> Suggestions welcome. Example use would be:
>
> x = x +1
> call foo(x+1)
> call sin(x) ! Though that probably triggers elsewhere
>
> I don't think the wording is that bad.
Well, my problem with it is that it doesn't tell what is invalid.
What do you think about "Assumed rank variable %s at %L can only be used
as an actual argument." ?
I think that currently your foo(x+1) case doesn't trigger an error.
It's not in your testcases at least.
>
>>> @@ -5084,6 +5127,22 @@ resolve_variable (gfc_expr *e)
>>> return FAILURE;
>>> }
>>>
>>> + /* TS 29113, C535b. */
>>> + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
>>> + && CLASS_DATA (sym)->as
>>> + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
>>> + || (sym->ts.type != BT_CLASS && sym->as
>>> + && sym->as->type == AS_ASSUMED_RANK))
>>> + && e->ref
>>> + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
>>> + && e->ref->next == NULL))
>>> + {
>>> + gfc_error ("Assumed-rank variable %s with designator at %L",
>>> + sym->name, &e->ref->u.ar.where);
>>
>> Ditto here. And I think that C535b is more about the context of the
>> expression rather than the expression itself.
>
> Here, I am lost. The check is that
> ubound(x(:))
> call bar (x(1))
> call bar2(x([1,3,5])
> call bar3(x(1:5:2))
> or similar does not occur if "x" is assumed rank. That "(:)" is an
> (array) designator. Do you have a better suggestion? I could add the
> word "array" before "designator", but I would like to avoid to list all
> possible combinations.
This one error is better as it tries to hint what's wrong. However, ...
>
> From TS29113:
> "C407b An assumed-type variable name shall not appear in a designator or
> ..."
>
> From Fortran 2008:
>
> "1.3.59 designator
> name followed by zero or more component selectors, complex part
> selectors, array section selectors, array element selectors, image
> selectors, and substring selectors (6.1)"
... according to this, a bare variable name is also a designator, and it
is valid. So issuing errors because the variable is/has a designator
seems confusing at best. I'm almost satisfied with this (maybe
s/with/in/ or s/be used with/???/) :
"Assumed-rank variable %s at %L cannot be used with a subobject reference."
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-14 13:26 ` Mikael Morin
@ 2012-07-15 19:14 ` Tobias Burnus
2012-07-19 15:58 ` Mikael Morin
0 siblings, 1 reply; 18+ messages in thread
From: Tobias Burnus @ 2012-07-15 19:14 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 2140 bytes --]
Hello,
attached is an updated version of the patch. Changes:
* Passing scalars to assumed-rank arrays works now.
* The scalarizer is now untouched, i.e. lbound/ubound don't work – not
even with dim=.
* Fixes according to review comments – and some other fixes
* Unrelated bug fixes, found when writing the test cases and thus included:
- Polymorphic variables: assumed-shape variables had an as->type of
AS_DEFERRED
- Polymorphic scalars: Allocatable and pointer couldn't be mixed (type
override issue)
- Polymorphic dummies: Passing null() to optional args – constraints
check didn't trigger properly
Still to be done:
* lbound/ubound/shape
* Class assumed-rank to (contiguous) type [i.e. packing]
* Assumed-size to assumed-rank, and checking some other combinations for
issues.
* Using assumed-rank arguments with elemental functions – for the
internal FINAL implementation
* CLASS(*) support
* C-binding changes: C_LOC etc.; implementation of IS_CONTIGUOUS
* New array descriptor ;-)
Mikael Morin wrote:
> What about naming the flag in_actual_arg and moving the
> inquiry_argument condition to the error condition?
That doesn't work as it is not only valid as inquiry argument but also
for other actual arguments – those which have an assumed-type or
assumed-rank dummy argument.
> Well, my problem with it is that it doesn't tell what is invalid.
> What do you think about "Assumed rank variable %s at %L can only be used
> as an actual argument." ?
I changed the error message along that way.
> I think that currently your foo(x+1) case doesn't trigger an error.
> It's not in your testcases at least.
Fixed that – and added a test case.
> ... according to this, a bare variable name is also a designator, and it
> is valid. So issuing errors because the variable is/has a designator
> seems confusing at best. I'm almost satisfied with this (maybe
> s/with/in/ or s/be used with/???/) :
> "Assumed-rank variable %s at %L cannot be used with a subobject reference."
I modified the error message to be similar to your proposal.
The patch was build and regtested on x86-64-linux.
OK for the trunk?
Tobias
[-- Attachment #2: assumed-rank-2012-07-15.diff --]
[-- Type: text/x-patch, Size: 72864 bytes --]
2012-07-15 Tobias Burnus <burnus@net-b.de>
PR fortran/48820
* array.c (match_array_element_spec, gfc_match_array_spec,
spec_size, gfc_array_dimen_size): Add support for
assumed-rank arrays.
* check.c (dim_rank_check): Ditto.
* class.c (gfc_add_component_ref): Ditto.
(gfc_build_class_symbol): Regard assumed-rank arrays
as having GFC_MAX_DIMENSIONS. And build extra class
container for a scalar pointer class.
* decl.c (merge_array_spec): Add support for
assumed-rank arrays.
* dump-parse-tree.c (show_array_spec): Ditto.
* expr.c (gfc_is_simply_contiguous): Ditto.
* gfortran.h (array_type): Ditto.
(gfc_array_spec, gfc_expr): Add comment to "rank" field.
* interface.c (compare_type_rank, compare_parameter,
argument_rank_mismatch, gfc_procedure_use): Ditto.
(compare_actual_formal): Fix NULL() to optional-dummy
handling for polymorphic dummies.
* module.c (mio_typespec): Add support for
assumed-rank arrays.
* resolve.c (resolve_formal_arglist, resolve_global_procedure,
expression_shape, resolve_variable, resolve_symbol,
resolve_fl_var_and_proc, resolve_actual_arglist,
resolve_elemental_actual, update_ppc_arglist,
check_typebound_baseobject, gfc_resolve_finalizers,
resolve_typebound_procedure, gfc_resolve_expr,
gfc_resolve_finalizers): Ditto.
(assumed_rank_type_expr_allowed): Renamed static variable
from assumed_type_expr_allowed.
* simplify.c (simplify_bound, gfc_simplify_range): Add
support for assumed-rank arrays.
* trans-array.c (gfc_conv_array_parameter): Ditto.
(gfc_get_descriptor_dimension): New function, which returns
the descriptor.
(gfc_conv_descriptor_dimension): Use it.
(gfc_conv_descriptor_stride_get, gfc_conv_array_parameter):
Handle GFC_ARRAY_ASSUMED_RANK_CONT and AS_ASSUMED_RANK.
* trans-array.h (gfc_get_descriptor_dimension): New prototype.
* trans-decl. (gfc_build_dummy_array_decl,
gfc_trans_deferred_vars, add_argument_checking): Add
support for assumed-rank arrays.
* trans-expr.c (gfc_conv_expr_present, gfc_conv_variable,
gfc_conv_procedure_call): Ditto.
(get_scalar_to_descriptor_type, class_array_data_assign,
conv_scalar_to_descriptor): New static functions.
(gfc_conv_derived_to_class, gfc_conv_class_to_class): Use
them.
* trans-intrinsic.c (get_rank_from_desc): New function.
(gfc_conv_intrinsic_rank, gfc_conv_associated): Use it.
* trans-types.c (gfc_array_descriptor_base_caf,
gfc_array_descriptor_base): Make space for scalar array.
(gfc_is_nodesc_array, gfc_is_nodesc_array,
gfc_build_array_type, gfc_get_array_descriptor_base): Add
support for assumed-rank arrays.
* trans.h (gfc_array_kind): Add GFC_ARRAY_ASSUMED_RANK and
GFC_ARRAY_ASSUMED_RANK_CONT.
2012-07-15 Tobias Burnus <burnus@net-b.de>
PR fortran/48820
* gfortran.dg/assumed_rank_1.f90: New.
* gfortran.dg/assumed_rank_1_c.c: New.
* gfortran.dg/assumed_rank_2.f90: New.
* gfortran.dg/assumed_rank_4.f90: New.
* gfortran.dg/assumed_rank_5.f90: New.
* gfortran.dg/assumed_rank_6.f90: New.
* gfortran.dg/assumed_rank_7.f90: New.
* gfortran.dg/assumed_rank_8.f90: New.
* gfortran.dg/assumed_rank_8_c.c: New.
* gfortran.dg/assumed_rank_9.f90: New.
* gfortran.dg/assumed_rank_10.f90: New.
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 51528b4..e1fa4b2 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -390,9 +390,11 @@ match_array_element_spec (gfc_array_spec *as)
{
gfc_expr **upper, **lower;
match m;
+ int rank;
- lower = &as->lower[as->rank + as->corank - 1];
- upper = &as->upper[as->rank + as->corank - 1];
+ rank = as->rank == -1 ? 0 : as->rank;
+ lower = &as->lower[rank + as->corank - 1];
+ upper = &as->upper[rank + as->corank - 1];
if (gfc_match_char ('*') == MATCH_YES)
{
@@ -458,6 +460,20 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
goto coarray;
}
+ if (gfc_match (" .. )") == MATCH_YES)
+ {
+ as->type = AS_ASSUMED_RANK;
+ as->rank = -1;
+
+ if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed-rank array "
+ "at %C") == FAILURE)
+ goto cleanup;
+
+ if (!match_codim)
+ goto done;
+ goto coarray;
+ }
+
for (;;)
{
as->rank++;
@@ -536,6 +552,9 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
gfc_error ("Bad specification for assumed size array at %C");
goto cleanup;
+
+ case AS_ASSUMED_RANK:
+ gcc_unreachable ();
}
if (gfc_match_char (')') == MATCH_YES)
@@ -642,6 +661,9 @@ coarray:
case AS_ASSUMED_SIZE:
gfc_error ("Bad specification for assumed size array at %C");
goto cleanup;
+
+ case AS_ASSUMED_RANK:
+ gcc_unreachable ();
}
if (gfc_match_char (']') == MATCH_YES)
@@ -1960,6 +1982,9 @@ spec_size (gfc_array_spec *as, mpz_t *result)
mpz_t size;
int d;
+ if (as->type == AS_ASSUMED_RANK)
+ return FAILURE;
+
mpz_init_set_ui (*result, 1);
for (d = 0; d < as->rank; d++)
@@ -2116,6 +2141,9 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
if (array->ts.type == BT_CLASS)
return FAILURE;
+ if (array->rank == -1)
+ return FAILURE;
+
if (dimen < 0 || array == NULL || dimen > array->rank - 1)
gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 407052f..404a534 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -620,6 +620,10 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
else
rank = array->rank;
+ /* Assumed-rank array. */
+ if (rank == -1)
+ rank = GFC_MAX_DIMENSIONS;
+
if (array->expr_type == EXPR_VARIABLE)
{
ar = gfc_find_array_ref (array);
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index fc083dc..21a91ba 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -220,7 +220,7 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
void
gfc_add_class_array_ref (gfc_expr *e)
{
- int rank = CLASS_DATA (e)->as->rank;
+ int rank = CLASS_DATA (e)->as->rank;
gfc_array_spec *as = CLASS_DATA (e)->as;
gfc_ref *ref = NULL;
gfc_add_component_ref (e, "_data");
@@ -498,6 +498,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
+ int rank;
if (as && *as && (*as)->type == AS_ASSUMED_SIZE)
{
@@ -518,11 +519,14 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
return SUCCESS;
/* Determine the name of the encapsulating type. */
+ rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
get_unique_hashed_string (tname, ts->u.derived);
if ((*as) && attr->allocatable)
- sprintf (name, "__class_%s_%d_%da", tname, (*as)->rank, (*as)->corank);
+ sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank);
+ else if ((*as) && attr->pointer)
+ sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank);
else if ((*as))
- sprintf (name, "__class_%s_%d_%d", tname, (*as)->rank, (*as)->corank);
+ sprintf (name, "__class_%s_%d_%d", tname, rank, (*as)->corank);
else if (attr->pointer)
sprintf (name, "__class_%s_p", tname);
else if (attr->allocatable)
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index c3644b6..959a57b 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -594,7 +594,7 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
{
int i;
- if (to->rank == 0 && from->rank > 0)
+ if (to->rank == 0 && from->rank != 0)
{
to->rank = from->rank;
to->type = from->type;
@@ -622,20 +622,24 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
}
else if (to->corank == 0 && from->corank > 0)
{
+ int rank;
+
to->corank = from->corank;
to->cotype = from->cotype;
+ rank = to->rank == -1 ? 0 : to->rank;
+
for (i = 0; i < from->corank; i++)
{
if (copy)
{
- to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
- to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
+ to->lower[rank + i] = gfc_copy_expr (from->lower[i]);
+ to->upper[rank + i] = gfc_copy_expr (from->upper[i]);
}
else
{
- to->lower[to->rank + i] = from->lower[i];
- to->upper[to->rank + i] = from->upper[i];
+ to->lower[rank + i] = from->lower[i];
+ to->upper[rank + i] = from->upper[i];
}
}
}
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 26c5201..681dc8d 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -166,7 +166,7 @@ show_array_spec (gfc_array_spec *as)
fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
- if (as->rank + as->corank > 0)
+ if (as->rank + as->corank > 0 || as->rank == -1)
{
switch (as->type)
{
@@ -174,6 +174,7 @@ show_array_spec (gfc_array_spec *as)
case AS_DEFERRED: c = "AS_DEFERRED"; break;
case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
+ case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break;
default:
gfc_internal_error ("show_array_spec(): Unhandled array shape "
"type.");
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index a107369..6afd9f3 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4442,7 +4442,8 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
|| (!part_ref
&& !sym->attr.contiguous
&& (sym->attr.pointer
- || sym->as->type == AS_ASSUMED_SHAPE))))
+ || sym->as->type == AS_ASSUMED_RANK
+ || sym->as->type == AS_ASSUMED_SHAPE))))
return false;
if (!ar || ar->type == AR_FULL)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6d75e63..03c306a 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -135,7 +135,8 @@ expr_t;
/* Array types. */
typedef enum
{ AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED,
- AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_UNKNOWN
+ AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_ASSUMED_RANK,
+ AS_UNKNOWN
}
array_type;
@@ -917,7 +918,7 @@ gfc_typespec;
/* Array specification. */
typedef struct
{
- int rank; /* A rank of zero means that a variable is a scalar. */
+ int rank; /* A scalar has a rank of 0, an assumed-rank array has -1. */
int corank;
array_type type, cotype;
struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS];
@@ -1694,7 +1695,7 @@ typedef struct gfc_expr
gfc_typespec ts; /* These two refer to the overall expression */
- int rank;
+ int rank; /* 0 indicates a scalar, -1 an assumed-rank array. */
mpz_t *shape; /* Can be NULL if shape is unknown at compile time */
/* Nonnull for functions and structure constructors, may also used to hold the
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 6f40ba7..64efbcb 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -512,7 +512,9 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
r1 = (s1->as != NULL) ? s1->as->rank : 0;
r2 = (s2->as != NULL) ? s2->as->rank : 0;
- if (r1 != r2)
+ if (r1 != r2
+ && (!s1->as || s1->as->type != AS_ASSUMED_RANK)
+ && (!s2->as || s2->as->type != AS_ASSUMED_RANK))
return 0; /* Ranks differ. */
return gfc_compare_types (&s1->ts, &s2->ts)
@@ -1635,7 +1637,14 @@ static void
argument_rank_mismatch (const char *name, locus *where,
int rank1, int rank2)
{
- if (rank1 == 0)
+
+ /* TS 29113, C407b. */
+ if (rank2 == -1)
+ {
+ gfc_error ("The assumed-rank array at %L requires that the dummy argument"
+ " '%s' has assumed-rank", where, name);
+ }
+ else if (rank1 == 0)
{
gfc_error ("Rank mismatch in argument '%s' at %L "
"(scalar and rank-%d)", name, where, rank2);
@@ -1743,7 +1752,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
}
/* F2008, 12.5.2.5; IR F08/0073. */
- if (formal->ts.type == BT_CLASS
+ if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL
&& ((CLASS_DATA (formal)->attr.class_pointer
&& !formal->attr.intent == INTENT_IN)
|| CLASS_DATA (formal)->attr.allocatable))
@@ -1860,7 +1869,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
" is modified", &actual->where, formal->name);
}
- if (symbol_rank (formal) == actual->rank)
+ /* If the rank is the same or the formal argument has assumed-rank. */
+ if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
return 1;
if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
@@ -2289,11 +2299,21 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
return 0;
}
- if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
- && (f->sym->attr.allocatable || !f->sym->attr.optional
- || (gfc_option.allow_std & GFC_STD_F2008) == 0))
- {
- if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
+ if (a->expr->expr_type == EXPR_NULL
+ && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
+ && (f->sym->attr.allocatable || !f->sym->attr.optional
+ || (gfc_option.allow_std & GFC_STD_F2008) == 0))
+ || (f->sym->ts.type == BT_CLASS
+ && !CLASS_DATA (f->sym)->attr.class_pointer
+ && (CLASS_DATA (f->sym)->attr.allocatable
+ || !f->sym->attr.optional
+ || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
+ {
+ if (where
+ && (!f->sym->attr.optional
+ || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->attr.allocatable)))
gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
where, f->sym->name);
else if (where)
@@ -2991,6 +3011,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
return;
}
+
+ /* TS 29113, C407b. */
+ if (a->expr && a->expr->expr_type == EXPR_VARIABLE
+ && symbol_rank (a->expr->symtree->n.sym) == -1)
+ {
+ gfc_error ("Assumed-rank argument requires an explicit interface "
+ "at %L", &a->expr->where);
+ return;
+ }
}
return;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 6fe23a2..4a5a869 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -2341,6 +2341,7 @@ mio_typespec (gfc_typespec *ts)
static const mstring array_spec_types[] = {
minit ("EXPLICIT", AS_EXPLICIT),
+ minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
minit ("DEFERRED", AS_DEFERRED),
minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 5be1857..3534e63 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -64,7 +64,8 @@ static code_stack *cs_base = NULL;
static int forall_flag;
static int do_concurrent_flag;
-static bool assumed_type_expr_allowed = false;
+/* Nonzero for assumed rank and for assumed type. */
+static bool assumed_rank_type_expr_allowed = false;
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
@@ -240,7 +241,7 @@ resolve_formal_arglist (gfc_symbol *proc)
if (gfc_elemental (proc)
|| sym->attr.pointer || sym->attr.allocatable
- || (sym->as && sym->as->rank > 0))
+ || (sym->as && sym->as->rank != 0))
{
proc->attr.always_explicit = 1;
sym->attr.always_explicit = 1;
@@ -251,6 +252,7 @@ resolve_formal_arglist (gfc_symbol *proc)
for (f = proc->formal; f; f = f->next)
{
sym = f->sym;
+ gfc_array_spec *as;
if (sym == NULL)
{
@@ -284,23 +286,34 @@ resolve_formal_arglist (gfc_symbol *proc)
gfc_set_default_type (sym, 1, sym->ns);
}
- gfc_resolve_array_spec (sym->as, 0);
+ as = sym->ts.type == BT_CLASS && sym->attr.class_ok
+ ? CLASS_DATA (sym)->as : sym->as;
+
+ gfc_resolve_array_spec (as, 0);
/* We can't tell if an array with dimension (:) is assumed or deferred
shape until we know if it has the pointer or allocatable attributes.
*/
- if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
- && !(sym->attr.pointer || sym->attr.allocatable)
+ if (as && as->rank > 0 && as->type == AS_DEFERRED
+ && ((sym->ts.type != BT_CLASS
+ && !(sym->attr.pointer || sym->attr.allocatable))
+ || (sym->ts.type == BT_CLASS
+ && !(CLASS_DATA (sym)->attr.class_pointer
+ || CLASS_DATA (sym)->attr.allocatable)))
&& sym->attr.flavor != FL_PROCEDURE)
{
- sym->as->type = AS_ASSUMED_SHAPE;
- for (i = 0; i < sym->as->rank; i++)
- sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, 1);
+ as->type = AS_ASSUMED_SHAPE;
+ for (i = 0; i < as->rank; i++)
+ as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
}
- if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
+ if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
+ || (as && as->type == AS_ASSUMED_RANK)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && (CLASS_DATA (sym)->attr.class_pointer
+ || CLASS_DATA (sym)->attr.allocatable
+ || CLASS_DATA (sym)->attr.target))
|| sym->attr.optional)
{
proc->attr.always_explicit = 1;
@@ -1600,7 +1613,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_expr *e;
int save_need_full_assumed_size;
- assumed_type_expr_allowed = true;
+ assumed_rank_type_expr_allowed = true;
for (; arg; arg = arg->next)
{
@@ -1833,8 +1846,18 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
"component", &e->where);
return FAILURE;
}
+
+ /* TS29113, C407b and C535b: Assumed-type and assumed-rank are only
+ allowed for the first argument.
+ Cf. http://j3-fortran.org/pipermail/j3/2012-June/005419.html
+ FIXME: It doesn't work reliably as inquiry_argument is not set
+ for all inquiry functions in resolve_function; the reason is that
+ the function-name resolution happens too late in that function. */
+ if (inquiry_argument)
+ assumed_rank_type_expr_allowed = false;
+
}
- assumed_type_expr_allowed = false;
+ assumed_rank_type_expr_allowed = false;
return SUCCESS;
}
@@ -1896,7 +1919,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
/* The rank of an elemental is the rank of its array argument(s). */
for (arg = arg0; arg; arg = arg->next)
{
- if (arg->expr != NULL && arg->expr->rank > 0)
+ if (arg->expr != NULL && arg->expr->rank != 0)
{
rank = arg->expr->rank;
if (arg->expr->expr_type == EXPR_VARIABLE
@@ -2195,6 +2218,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* TS 29113, 6.2. */
+ else if (arg->sym && arg->sym->as
+ && arg->sym->as->type == AS_ASSUMED_RANK)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
/* F2008, 12.4.2.2 (2c) */
else if (arg->sym->attr.codimension)
{
@@ -2220,6 +2252,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* As assumed-type is unlimited polymorphic (cf. above).
+ See also TS 29113, Note 6.1. */
+ else if (arg->sym->ts.type == BT_ASSUMED)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-type dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
}
if (def_sym->attr.function)
@@ -4965,7 +5006,7 @@ expression_shape (gfc_expr *e)
mpz_t array[GFC_MAX_DIMENSIONS];
int i;
- if (e->rank == 0 || e->shape != NULL)
+ if (e->rank <= 0 || e->shape != NULL)
return;
for (i = 0; i < e->rank; i++)
@@ -5068,13 +5109,26 @@ resolve_variable (gfc_expr *e)
sym = e->symtree->n.sym;
/* TS 29113, 407b. */
- if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
+ if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed)
{
gfc_error ("Invalid expression with assumed-type variable %s at %L",
sym->name, &e->where);
return FAILURE;
}
+ /* TS 29113, C535b. */
+ if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || (sym->ts.type != BT_CLASS && sym->as
+ && sym->as->type == AS_ASSUMED_RANK))
+ && !assumed_rank_type_expr_allowed)
+ {
+ gfc_error ("Assumed-rank variable %s at %L may only be used as actual "
+ "argument", sym->name, &e->where);
+ return FAILURE;
+ }
+
/* TS 29113, 407b. */
if (e->ts.type == BT_ASSUMED && e->ref
&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
@@ -5085,6 +5139,22 @@ resolve_variable (gfc_expr *e)
return FAILURE;
}
+ /* TS 29113, C535b. */
+ if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || (sym->ts.type != BT_CLASS && sym->as
+ && sym->as->type == AS_ASSUMED_RANK))
+ && e->ref
+ && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+ && e->ref->next == NULL))
+ {
+ gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
+ "reference", sym->name, &e->ref->u.ar.where);
+ return FAILURE;
+ }
+
+
/* If this is an associate-name, it may be parsed with an array reference
in error even though the target is scalar. Fail directly in this case.
TODO Understand why class scalar expressions must be excluded. */
@@ -5585,7 +5655,7 @@ update_ppc_arglist (gfc_expr* e)
return FAILURE;
/* F08:R739. */
- if (po->rank > 0)
+ if (po->rank != 0)
{
gfc_error ("Passed-object at %L must be scalar", &e->where);
return FAILURE;
@@ -5633,7 +5703,7 @@ check_typebound_baseobject (gfc_expr* e)
/* F08:C1230. If the procedure called is NOPASS,
the base object must be scalar. */
- if (e->value.compcall.tbp->nopass && base->rank > 0)
+ if (e->value.compcall.tbp->nopass && base->rank != 0)
{
gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
" be scalar", &e->where);
@@ -6295,15 +6365,20 @@ gfc_try
gfc_resolve_expr (gfc_expr *e)
{
gfc_try t;
- bool inquiry_save;
+ bool inquiry_save, assumed_rank_type_save;
if (e == NULL)
return SUCCESS;
/* inquiry_argument only applies to variables. */
inquiry_save = inquiry_argument;
+ assumed_rank_type_save = assumed_rank_type_expr_allowed;
+
if (e->expr_type != EXPR_VARIABLE)
- inquiry_argument = false;
+ {
+ inquiry_argument = false;
+ assumed_rank_type_expr_allowed = false;
+ }
switch (e->expr_type)
{
@@ -6393,6 +6468,7 @@ gfc_resolve_expr (gfc_expr *e)
fixup_charlen (e);
inquiry_argument = inquiry_save;
+ assumed_rank_type_expr_allowed = assumed_rank_type_save;
return t;
}
@@ -10320,10 +10396,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
if (allocatable)
{
- if (dimension)
+ if (dimension && as->type != AS_ASSUMED_RANK)
{
- gfc_error ("Allocatable array '%s' at %L must have "
- "a deferred shape", sym->name, &sym->declared_at);
+ gfc_error ("Allocatable array '%s' at %L must have a deferred "
+ "shape or assumed rank", sym->name, &sym->declared_at);
return FAILURE;
}
else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
@@ -10332,10 +10408,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
return FAILURE;
}
- if (pointer && dimension)
+ if (pointer && dimension && as->type != AS_ASSUMED_RANK)
{
- gfc_error ("Array pointer '%s' at %L must have a deferred shape",
- sym->name, &sym->declared_at);
+ gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
+ "deferred rank", sym->name, &sym->declared_at);
return FAILURE;
}
}
@@ -10949,7 +11025,7 @@ gfc_resolve_finalizers (gfc_symbol* derived)
}
/* Warn if the procedure is non-scalar and not assumed shape. */
- if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
+ if (gfc_option.warn_surprising && arg->as && arg->as->rank != 0
&& arg->as->type != AS_ASSUMED_SHAPE)
gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
" shape argument", &arg->declared_at);
@@ -11478,7 +11554,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
}
gcc_assert (me_arg->ts.type == BT_CLASS);
- if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
+ if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
{
gfc_error ("Passed-object dummy argument of '%s' at %L must be"
" scalar", proc->name, &where);
@@ -12492,6 +12568,20 @@ resolve_symbol (gfc_symbol *sym)
&sym->declared_at);
return;
}
+ /* TS 29113, C535a. */
+ if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy)
+ {
+ gfc_error ("Assumed-rank array at %L must be a dummy argument",
+ &sym->declared_at);
+ return;
+ }
+ if (as->type == AS_ASSUMED_RANK
+ && (sym->attr.codimension || sym->attr.value))
+ {
+ gfc_error ("Assumed-rank array at %L may not have the VALUE or "
+ "CODIMENSION attribute", &sym->declared_at);
+ return;
+ }
}
/* Make sure symbols with known intent or optional are really dummy
@@ -12564,6 +12654,13 @@ resolve_symbol (gfc_symbol *sym)
sym->name, &sym->declared_at);
return;
}
+ if (sym->attr.intent == INTENT_OUT)
+ {
+ gfc_error ("Assumed-type variable %s at %L may not have the "
+ "INTENT(OUT) attribute",
+ sym->name, &sym->declared_at);
+ return;
+ }
if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
{
gfc_error ("Assumed-type variable %s at %L shall not be an "
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index c7145d6..afc4bc4 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2935,7 +2935,6 @@ gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
}
-
gfc_expr *
gfc_simplify_is_iostat_end (gfc_expr *x)
{
@@ -3381,7 +3380,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
done:
- if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
+ if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
+ || as->type == AS_ASSUMED_RANK))
return NULL;
if (dim == NULL)
@@ -3443,13 +3443,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
d = mpz_get_si (dim->value.integer);
- if (d < 1 || d > array->rank
+ if ((d < 1 || d > array->rank)
|| (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
{
gfc_error ("DIM argument at %L is out of bounds", &dim->where);
return &gfc_bad_expr;
}
+ if (as && as->type == AS_ASSUMED_RANK)
+ return NULL;
+
return simplify_bound_dim (array, kind, d, upper, as, ref, false);
}
}
@@ -4780,6 +4783,10 @@ gfc_simplify_range (gfc_expr *e)
gfc_expr *
gfc_simplify_rank (gfc_expr *e)
{
+ /* Assumed rank. */
+ if (e->rank == -1)
+ return NULL;
+
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
}
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index d289ac3..ba108dc 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -81,7 +81,7 @@ along with GCC; see the file COPYING3. If not see
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "gimple.h"
+#include "gimple.h" /* For create_tmp_var_name. */
#include "diagnostic-core.h" /* For internal_error/fatal_error. */
#include "flags.h"
#include "gfortran.h"
@@ -247,12 +247,11 @@ gfc_conv_descriptor_dtype (tree desc)
desc, field, NULL_TREE);
}
-static tree
-gfc_conv_descriptor_dimension (tree desc, tree dim)
+
+tree
+gfc_get_descriptor_dimension (tree desc)
{
- tree field;
- tree type;
- tree tmp;
+ tree type, field;
type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
@@ -262,10 +261,19 @@ gfc_conv_descriptor_dimension (tree desc, tree dim)
&& TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- desc, field, NULL_TREE);
- tmp = gfc_build_array_ref (tmp, dim, NULL);
- return tmp;
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+}
+
+
+static tree
+gfc_conv_descriptor_dimension (tree desc, tree dim)
+{
+ tree tmp;
+
+ tmp = gfc_get_descriptor_dimension (desc);
+
+ return gfc_build_array_ref (tmp, dim, NULL);
}
@@ -311,6 +319,7 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim)
if (integer_zerop (dim)
&& (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_ASSUMED_RANK_CONT
||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
return gfc_index_one_node;
@@ -6900,9 +6909,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
}
if (!sym->attr.pointer
- && sym->as
- && sym->as->type != AS_ASSUMED_SHAPE
- && !sym->attr.allocatable)
+ && sym->as
+ && sym->as->type != AS_ASSUMED_SHAPE
+ && sym->as->type != AS_ASSUMED_RANK
+ && !sym->attr.allocatable)
{
/* Some variables are declared directly, others are declared as
pointers and allocated on the heap. */
@@ -6938,10 +6948,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
no_pack = ((sym && sym->as
&& !sym->attr.pointer
&& sym->as->type != AS_DEFERRED
+ && sym->as->type != AS_ASSUMED_RANK
&& sym->as->type != AS_ASSUMED_SHAPE)
||
(ref && ref->u.ar.as
&& ref->u.ar.as->type != AS_DEFERRED
+ && ref->u.ar.as->type != AS_ASSUMED_RANK
&& ref->u.ar.as->type != AS_ASSUMED_SHAPE)
||
gfc_is_simply_contiguous (expr, false));
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 9bafb94..b7ab806 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -154,6 +154,7 @@ tree gfc_conv_descriptor_data_get (tree);
tree gfc_conv_descriptor_data_addr (tree);
tree gfc_conv_descriptor_offset_get (tree);
tree gfc_conv_descriptor_dtype (tree);
+tree gfc_get_descriptor_dimension (tree);
tree gfc_conv_descriptor_stride_get (tree, tree);
tree gfc_conv_descriptor_lbound_get (tree, tree);
tree gfc_conv_descriptor_ubound_get (tree, tree);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 75a2160..f1b7444 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -933,7 +933,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
int n;
bool known_size;
- if (sym->attr.pointer || sym->attr.allocatable)
+ if (sym->attr.pointer || sym->attr.allocatable
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
return dummy;
/* Add to list of variables if not a fake result variable. */
@@ -3669,6 +3670,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
break;
+ case AS_ASSUMED_RANK:
case AS_DEFERRED:
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, block);
@@ -4782,7 +4784,8 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
dummy argument is an array. (See "Sequence association" in
Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
if (fsym->attr.pointer || fsym->attr.allocatable
- || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
+ || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK)))
{
comparison = NE_EXPR;
message = _("Actual string length does not match the declared one"
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 34e0f69..7ec40b1 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -42,6 +42,48 @@ along with GCC; see the file COPYING3. If not see
#include "dependency.h"
+/* Convert a scalar to an array descriptor. To be used for assumed-rank
+ arrays. */
+
+static tree
+get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
+{
+ enum gfc_array_kind akind;
+
+ if (attr.pointer)
+ akind = GFC_ARRAY_POINTER_CONT;
+ else if (attr.allocatable)
+ akind = GFC_ARRAY_ALLOCATABLE;
+ else
+ akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
+
+ return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
+ akind, !(attr.pointer || attr.target));
+}
+
+static tree
+conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
+{
+ tree desc, type;
+
+ type = get_scalar_to_descriptor_type (scalar, attr);
+ desc = gfc_create_var (type, "desc");
+ DECL_ARTIFICIAL (desc) = 1;
+ gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype (type));
+ gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
+
+ /* Copy pointer address back - but only if it could have changed and
+ if the actual argument is a pointer and not, e.g., NULL(). */
+ if ((attr.pointer || attr.allocatable)
+ && attr.intent != INTENT_IN && POINTER_TYPE_P (TREE_TYPE (scalar)))
+ gfc_add_modify (&se->post, scalar,
+ fold_convert (TREE_TYPE (scalar),
+ gfc_conv_descriptor_data_get (desc)));
+ return desc;
+}
+
+
/* This is the seed for an eventual trans-class.c
The following parameters should not be used directly since they might
@@ -158,7 +200,34 @@ gfc_get_vptr_from_expr (tree expr)
tmp = gfc_class_vptr_get (tmp);
return tmp;
}
-
+
+
+static void
+class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
+ bool lhs_type)
+{
+ tree tmp, tmp2, type;
+
+ gfc_conv_descriptor_data_set (block, lhs_desc,
+ gfc_conv_descriptor_data_get (rhs_desc));
+ gfc_conv_descriptor_offset_set (block, lhs_desc,
+ gfc_conv_descriptor_offset_get (rhs_desc));
+
+ gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
+ gfc_conv_descriptor_dtype (rhs_desc));
+
+ /* Assign the dimension as range-ref. */
+ tmp = gfc_get_descriptor_dimension (lhs_desc);
+ tmp2 = gfc_get_descriptor_dimension (rhs_desc);
+
+ type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
+ tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
+ gfc_index_zero_node, NULL_TREE, NULL_TREE);
+ tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
+ gfc_index_zero_node, NULL_TREE, NULL_TREE);
+ gfc_add_modify (block, tmp, tmp2);
+}
+
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. If vptr is not NULL, this is
@@ -215,14 +284,33 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
{
parmse->ss = NULL;
gfc_conv_expr_reference (parmse, e);
- tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
- gfc_add_modify (&parmse->pre, ctree, tmp);
+
+ /* Scalar to an assumed-rank array. */
+ if (class_ts.u.derived->components->as)
+ {
+ tree type;
+ type = get_scalar_to_descriptor_type (parmse->expr,
+ gfc_expr_attr (e));
+ gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
+ gfc_get_dtype (type));
+ gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
+ }
+ else
+ {
+ tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
}
else
{
parmse->ss = ss;
gfc_conv_expr_descriptor (parmse, e, ss);
- gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+
+ if (e->rank != class_ts.u.derived->components->as->rank)
+ class_array_data_assign (&parmse->pre, ctree, parmse->expr,
+ TREE_TYPE (parmse->expr));
+ else
+ gfc_add_modify (&parmse->pre, ctree, parmse->expr);
}
}
@@ -260,7 +348,9 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
break;
}
- if (ref == NULL || class_ref == ref)
+ if ((ref == NULL || class_ref == ref)
+ && (!class_ts.u.derived->components->as
+ || class_ts.u.derived->components->as->rank != -1))
return;
/* Test for FULL_ARRAY. */
@@ -273,13 +363,42 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
/* Set the data. */
ctree = gfc_class_data_get (var);
- gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+ if (class_ts.u.derived->components->as
+ && e->rank != class_ts.u.derived->components->as->rank)
+ {
+ if (e->rank == 0)
+ {
+ tree type = get_scalar_to_descriptor_type (parmse->expr,
+ gfc_expr_attr (e));
+ gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
+ gfc_get_dtype (type));
+ gfc_conv_descriptor_data_set (&parmse->pre, ctree,
+ gfc_class_data_get (parmse->expr));
+
+ }
+ else
+ class_array_data_assign (&parmse->pre, ctree, parmse->expr, false);
+ }
+ else
+ gfc_add_modify (&parmse->pre, ctree, parmse->expr);
/* Return the data component, except in the case of scalarized array
references, where nullification of the cannot occur and so there
is no need. */
if (!elemental && full_array)
- gfc_add_modify (&parmse->post, parmse->expr, ctree);
+ {
+ if (class_ts.u.derived->components->as
+ && e->rank != class_ts.u.derived->components->as->rank)
+ {
+ if (e->rank == 0)
+ gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
+ gfc_conv_descriptor_data_get (ctree));
+ else
+ class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
+ }
+ else
+ gfc_add_modify (&parmse->post, parmse->expr, ctree);
+ }
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
@@ -730,7 +849,8 @@ gfc_conv_expr_present (gfc_symbol * sym)
as actual argument to denote absent dummies. For array descriptors,
we thus also need to check the array descriptor. */
if (!sym->attr.pointer && !sym->attr.allocatable
- && sym->as && sym->as->type == AS_ASSUMED_SHAPE
+ && sym->as && (sym->as->type == AS_ASSUMED_SHAPE
+ || sym->as->type == AS_ASSUMED_RANK)
&& (gfc_option.allow_std & GFC_STD_F2008) != 0)
{
tree tmp;
@@ -1325,7 +1445,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
/* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
if ((sym->attr.pointer || sym->attr.allocatable
- || gfc_is_associate_pointer (sym))
+ || gfc_is_associate_pointer (sym)
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result
@@ -3620,10 +3741,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
}
}
- else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
+ else if (arg->expr->expr_type == EXPR_NULL
+ && fsym && !fsym->attr.pointer
+ && (fsym->ts.type != BT_CLASS
+ || !CLASS_DATA (fsym)->attr.class_pointer))
{
/* Pass a NULL pointer to denote an absent arg. */
- gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
+ gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
+ && (fsym->ts.type != BT_CLASS
+ || !CLASS_DATA (fsym)->attr.allocatable));
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
if (arg->missing_arg_type == BT_CHARACTER)
@@ -3764,7 +3890,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
class object, if the formal argument is a class object. */
if (fsym && fsym->ts.type == BT_CLASS
&& e->ts.type == BT_CLASS
- && CLASS_DATA (e)->attr.dimension)
+ && ((CLASS_DATA (fsym)->as
+ && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+ || CLASS_DATA (e)->attr.dimension))
gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
if (fsym && (fsym->ts.type == BT_DERIVED
@@ -3808,7 +3936,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_add_expr_to_block (&se->pre, tmp);
}
- if (fsym && e->expr_type != EXPR_NULL
+ /* Wrap scalar variable in a descriptor. We need to convert
+ the address of a pointer back to the pointer itself before,
+ we can assign it to the data field. */
+
+ if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
+ && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
+ {
+ tmp = parmse.expr;
+ if (TREE_CODE (tmp) == ADDR_EXPR
+ && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
+ tmp = TREE_OPERAND (tmp, 0);
+ parmse.expr = conv_scalar_to_descriptor (se, tmp,
+ fsym->attr);
+ parmse.expr = gfc_build_addr_expr (NULL_TREE,
+ parmse.expr);
+ }
+ else if (fsym && e->expr_type != EXPR_NULL
&& ((fsym->attr.pointer
&& fsym->attr.flavor != FL_PROCEDURE)
|| (fsym->attr.proc_pointer
@@ -3850,7 +3994,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
bool f;
f = (fsym != NULL)
&& !(fsym->attr.pointer || fsym->attr.allocatable)
- && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
+ && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE
+ && fsym->as->type != AS_ASSUMED_RANK;
if (comp)
f = f || !comp->attr.always_explicit;
else
@@ -3959,12 +4104,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
but do not always set fsym. */
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional
- && ((e->rank > 0 && sym->attr.elemental)
+ && ((e->rank != 0 && sym->attr.elemental)
|| e->representation.length || e->ts.type == BT_CHARACTER
- || (e->rank > 0
+ || (e->rank != 0
&& (fsym == NULL
|| (fsym-> as
&& (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK
|| fsym->as->type == AS_DEFERRED))))))
gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
e->representation.length);
@@ -4210,7 +4356,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp = caf_decl;
}
- if (fsym->as->type == AS_ASSUMED_SHAPE)
+ if (fsym->as->type == AS_ASSUMED_SHAPE
+ || (fsym->as->type == AS_ASSUMED_RANK && !fsym->attr.pointer
+ && !fsym->attr.allocatable))
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index e4905ff..be94219 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1315,29 +1315,37 @@ trans_num_images (gfc_se * se)
}
+static tree
+get_rank_from_desc (tree desc)
+{
+ tree tmp;
+ tree dtype;
+
+ dtype = gfc_conv_descriptor_dtype (desc);
+ tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
+ tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
+ dtype, tmp);
+ return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+}
+
+
static void
gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
{
gfc_se argse;
gfc_ss *ss;
- tree dtype, tmp;
ss = gfc_walk_expr (expr->value.function.actual->expr);
gcc_assert (ss != gfc_ss_terminator);
gfc_init_se (&argse, NULL);
argse.data_not_needed = 1;
- argse.want_pointer = 1;
+ argse.descriptor_only = 1;
gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr);
- argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr);
- dtype = gfc_conv_descriptor_dtype (argse.expr);
- tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
- tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
- dtype, tmp);
- se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+
+ se->expr = get_rank_from_desc (argse.expr);
}
@@ -5855,8 +5863,15 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
present. */
arg1se.descriptor_only = 1;
gfc_conv_expr_lhs (&arg1se, arg1->expr);
- tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
- gfc_rank_cst[arg1->expr->rank - 1]);
+ if (arg1->expr->rank == -1)
+ {
+ tmp = get_rank_from_desc (arg1se.expr);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE (tmp), tmp, gfc_index_one_node);
+ }
+ else
+ tmp = gfc_rank_cst[arg1->expr->rank - 1];
+ tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index aa50e3d..d96f5e6 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -80,8 +80,8 @@ bool gfc_real16_is_float128 = false;
static GTY(()) tree gfc_desc_dim_type;
static GTY(()) tree gfc_max_array_element_size;
-static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS];
-static GTY(()) tree gfc_array_descriptor_base_caf[2 * GFC_MAX_DIMENSIONS];
+static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
+static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
/* Arrays for all integral and real kinds. We'll fill this in at runtime
after the target has a chance to process command-line options. */
@@ -1277,7 +1277,8 @@ gfc_is_nodesc_array (gfc_symbol * sym)
return 0;
if (sym->attr.dummy)
- return sym->as->type != AS_ASSUMED_SHAPE;
+ return sym->as->type != AS_ASSUMED_SHAPE
+ && sym->as->type != AS_ASSUMED_RANK;
if (sym->attr.result || sym->attr.function)
return 0;
@@ -1299,6 +1300,13 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
tree ubound[GFC_MAX_DIMENSIONS];
int n;
+ if (as->type == AS_ASSUMED_RANK)
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ {
+ lbound[n] = NULL_TREE;
+ ubound[n] = NULL_TREE;
+ }
+
for (n = 0; n < as->rank; n++)
{
/* Create expressions for the known bounds of the array. */
@@ -1323,7 +1331,12 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
if (as->type == AS_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,
+ else if (as->type == AS_ASSUMED_RANK)
+ akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
+ : GFC_ARRAY_ASSUMED_RANK;
+ return gfc_get_array_type_bounds (type, as->rank == -1
+ ? GFC_MAX_DIMENSIONS : as->rank,
+ as->corank, lbound,
ubound, 0, akind, restricted);
}
\f
@@ -1682,9 +1695,15 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
{
tree fat_type, decl, arraytype, *chain = NULL;
char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
- int idx = 2 * (codimen + dimen - 1) + restricted;
+ int idx;
+
+ /* Assumed-rank array. */
+ if (dimen == -1)
+ dimen = GFC_MAX_DIMENSIONS;
+
+ idx = 2 * (codimen + dimen) + restricted;
- gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
+ gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS);
if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)
{
@@ -1721,16 +1740,18 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
TREE_NO_WARNING (decl) = 1;
/* Build the array type for the stride and bound components. */
- arraytype =
- build_array_type (gfc_get_desc_dim_type (),
- build_range_type (gfc_array_index_type,
- gfc_index_zero_node,
- gfc_rank_cst[codimen + dimen - 1]));
+ if (dimen + codimen > 0)
+ {
+ arraytype =
+ build_array_type (gfc_get_desc_dim_type (),
+ build_range_type (gfc_array_index_type,
+ gfc_index_zero_node,
+ gfc_rank_cst[codimen + dimen - 1]));
- decl = gfc_add_field_to_struct_1 (fat_type,
- get_identifier ("dim"),
- arraytype, &chain);
- TREE_NO_WARNING (decl) = 1;
+ decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"),
+ arraytype, &chain);
+ TREE_NO_WARNING (decl) = 1;
+ }
if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen
&& akind == GFC_ARRAY_ALLOCATABLE)
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 3b77281..d4092f7 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -765,6 +765,8 @@ enum gfc_array_kind
GFC_ARRAY_UNKNOWN,
GFC_ARRAY_ASSUMED_SHAPE,
GFC_ARRAY_ASSUMED_SHAPE_CONT,
+ GFC_ARRAY_ASSUMED_RANK,
+ GFC_ARRAY_ASSUMED_RANK_CONT,
GFC_ARRAY_ALLOCATABLE,
GFC_ARRAY_POINTER,
GFC_ARRAY_POINTER_CONT
--- /dev/null 2012-07-14 08:59:06.947592273 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_1.f90 2012-07-13 16:36:03.000000000 +0200
@@ -0,0 +1,147 @@
+! { dg-do run }
+! { dg-additional-sources assumed_rank_1_c.c }
+!
+! PR fortran/48820
+!
+! Assumed-rank tests
+!
+! FIXME: The ubound/lbound checks have to be re-enabled when
+! after they are supported
+
+implicit none
+
+interface
+ subroutine check_value(b, n, val)
+ integer :: b(..)
+ integer, value :: n
+ integer :: val(n)
+ end subroutine
+end interface
+
+integer, target :: x(2:5,4:7), y(-4:4)
+integer, allocatable, target :: z(:,:,:,:)
+integer, allocatable :: val(:)
+integer :: i
+
+allocate(z(1:4, -2:5, 4, 10:11))
+
+if (rank(x) /= 2) call abort ()
+val = [(2*i+3, i = 1, size(x))]
+x = reshape (val, shape(x))
+call foo(x, rank(x), lbound(x), ubound(x), val)
+call foo2(x, rank(x), lbound(x), ubound(x), val)
+call bar(x,x,.true.)
+call bar(x,prsnt=.false.)
+
+if (rank(y) /= 1) call abort ()
+val = [(2*i+7, i = 1, size(y))]
+y = reshape (val, shape(y))
+call foo(y, rank(y), lbound(y), ubound(y), val)
+call foo2(y, rank(y), lbound(y), ubound(y), val)
+call bar(y,y,.true.)
+call bar(y,prsnt=.false.)
+
+if (rank(z) /= 4) call abort ()
+val = [(2*i+5, i = 1, size(z))]
+z(:,:,:,:) = reshape (val, shape(z))
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo2(z, rank(z), lbound(z), ubound(z), val)
+call bar(z,z,.true.)
+call bar(z,prsnt=.false.)
+
+contains
+ subroutine bar(a,b, prsnt)
+ integer, pointer, optional, intent(in) :: a(..),b(..)
+ logical, value :: prsnt
+ ! The following is not valid, but it goes past the constraint check
+ ! Technically, it could be allowed and might be in Fortran 2015:
+ if (.not. associated(a)) call abort()
+ if (present(b)) then
+ if (.not. associated(a,b)) call abort()
+ else
+ if (.not. associated(a)) call abort()
+ end if
+ if (.not. present(a)) call abort()
+ if (prsnt .neqv. present(b)) call abort()
+ end subroutine
+
+ ! POINTER argument - bounds as specified before
+ subroutine foo(a, rnk, low, high, val)
+ integer,pointer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (low(1) /= lbound(a,1)) call abort()
+ if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (low(i) /= lbound(a,i)) call abort()
+ if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call check_value (a, rnk, val)
+ call foo2(a, rnk, low, high, val)
+ end subroutine
+
+ ! Non-pointer, non-allocatable bounds. lbound == 1
+ subroutine foo2(a, rnk, low, high, val)
+ integer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+! if (1 /= lbound(a,1)) call abort()
+! if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+! if (1 /= lbound(a,i)) call abort()
+! if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call check_value (a, rnk, val)
+ end subroutine foo2
+
+ ! ALLOCATABLE argument - bounds as specified before
+ subroutine foo3 (a, rnk, low, high, val)
+ integer, allocatable, intent(in), target :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+! if (low(1) /= lbound(a,1)) call abort()
+! if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+! if (low(i) /= lbound(a,i)) call abort()
+! if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call check_value (a, rnk, val)
+ call foo(a, rnk, low, high, val)
+ end subroutine
+end
--- /dev/null 2012-07-14 08:59:06.947592273 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_1_c.c 2012-06-24 12:58:44.000000000 +0200
@@ -0,0 +1,16 @@
+/* Called by assumed_rank_1.f90. */
+
+#include <stdlib.h> /* For abort(). */
+
+struct array {
+ int *data;
+};
+
+void check_value_ (struct array *b, int n, int val[])
+{
+ int i;
+
+ for (i = 0; i < n; i++)
+ if (b->data[i] != val[i])
+ abort ();
+}
--- /dev/null 2012-07-14 08:59:06.947592273 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_2.f90 2012-07-13 16:37:19.000000000 +0200
@@ -0,0 +1,137 @@
+! { dg-do run }
+! { dg-options "-fcheck=all" }
+!
+! PR fortran/48820
+!
+! Assumed-rank tests - same as assumed_rank_1.f90,
+! but with bounds checks and w/o call to C function
+!
+! FIXME: The ubound/lbound checks have to be re-enabled when
+! after they are supported
+
+implicit none
+
+integer, target :: x(2:5,4:7), y(-4:4)
+integer, allocatable, target :: z(:,:,:,:)
+integer, allocatable :: val(:)
+integer :: i
+
+allocate(z(1:4, -2:5, 4, 10:11))
+
+if (rank(x) /= 2) call abort ()
+val = [(2*i+3, i = 1, size(x))]
+x = reshape (val, shape(x))
+call foo(x, rank(x), lbound(x), ubound(x), val)
+call foo2(x, rank(x), lbound(x), ubound(x), val)
+call bar(x,x,.true.)
+call bar(x,prsnt=.false.)
+
+if (rank(y) /= 1) call abort ()
+val = [(2*i+7, i = 1, size(y))]
+y = reshape (val, shape(y))
+call foo(y, rank(y), lbound(y), ubound(y), val)
+call foo2(y, rank(y), lbound(y), ubound(y), val)
+call bar(y,y,.true.)
+call bar(y,prsnt=.false.)
+
+if (rank(z) /= 4) call abort ()
+val = [(2*i+5, i = 1, size(z))]
+z(:,:,:,:) = reshape (val, shape(z))
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo2(z, rank(z), lbound(z), ubound(z), val)
+call bar(z,z,.true.)
+call bar(z,prsnt=.false.)
+
+contains
+ subroutine bar(a,b, prsnt)
+ integer, pointer, optional, intent(in) :: a(..),b(..)
+ logical, value :: prsnt
+ ! The following is not valid, but it goes past the constraint check
+ ! Technically, it could be allowed and might be in Fortran 2015:
+ if (.not. associated(a)) call abort()
+ if (present(b)) then
+ if (.not. associated(a,b)) call abort()
+ else
+ if (.not. associated(a)) call abort()
+ end if
+ if (.not. present(a)) call abort()
+ if (prsnt .neqv. present(b)) call abort()
+ end subroutine
+
+ ! POINTER argument - bounds as specified before
+ subroutine foo(a, rnk, low, high, val)
+ integer,pointer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+! if (low(1) /= lbound(a,1)) call abort()
+! if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+! if (low(i) /= lbound(a,i)) call abort()
+! if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call foo2(a, rnk, low, high, val)
+ end subroutine
+
+ ! Non-pointer, non-allocatable bounds. lbound == 1
+ subroutine foo2(a, rnk, low, high, val)
+ integer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+! if (1 /= lbound(a,1)) call abort()
+! if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+! if (1 /= lbound(a,i)) call abort()
+! if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ end subroutine foo2
+
+ ! ALLOCATABLE argument - bounds as specified before
+ subroutine foo3 (a, rnk, low, high, val)
+ integer, allocatable, intent(in), target :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+! if (low(1) /= lbound(a,1)) call abort()
+! if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+! if (low(i) /= lbound(a,i)) call abort()
+! if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call foo(a, rnk, low, high, val)
+ end subroutine
+end
--- /dev/null 2012-07-14 08:59:06.947592273 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_4.f90 2012-07-15 19:30:19.000000000 +0200
@@ -0,0 +1,50 @@
+! { dg-do compile }
+! { dg-options "-std=f2008ts" }
+!
+! PR fortran/48820
+!
+! Assumed-rank constraint checks and other diagnostics
+!
+
+subroutine valid1a(x)
+ integer, intent(in), pointer, contiguous :: x(..)
+end subroutine valid1a
+
+subroutine valid1(x)
+ integer, intent(in) :: x(..)
+end subroutine valid1
+
+subroutine valid2(x)
+ type(*) :: x
+end subroutine valid2
+
+subroutine foo99(x)
+ integer x(99)
+ call valid1(x) ! { dg-error "Procedure 'valid1' at .1. with assumed-rank dummy argument 'x' must have an explicit interface" }
+ call valid2(x(1)) ! { dg-error "Procedure 'valid2' at .1. with assumed-type dummy argument 'x' must have an explicit interface" }
+end subroutine foo99
+
+subroutine foo(x)
+ integer :: x(..)
+ print *, ubound(x,dim=2000) ! { dg-error "is not a valid dimension index" }
+ call bar(x) ! { dg-error "Assumed-rank argument requires an explicit interface" }
+ call intnl(x) ! { dg-error "requires that the dummy argument 'x' has assumed-rank" }
+contains
+ subroutine intnl(x)
+ integer :: x(:)
+ end subroutine intnl
+end subroutine foo
+
+subroutine foo2(x)
+ integer :: x(..)
+ call valid3(x(:)) ! { dg-error "Assumed-rank variable x at .1. shall not have a subobject reference" }
+ call valid3(x+1) ! { dg-error "Assumed-rank variable x at .1. may only be used as actual argument" }
+contains
+ subroutine valid3(y)
+ integer :: y(..)
+ end subroutine
+end subroutine
+
+subroutine foo3()
+ integer :: x(..) ! { dg-error "Assumed-rank array at .1. must be a dummy argument" }
+end subroutine
--- /dev/null 2012-07-14 08:59:06.947592273 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_5.f90 2012-06-24 15:17:51.000000000 +0200
@@ -0,0 +1,9 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/48820
+!
+!
+subroutine foo(x)
+ integer :: x(..) ! { dg-error "TS 29113: Assumed-rank array" }
+end subroutine foo
--- /dev/null 2012-07-14 08:59:06.947592273 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_6.f90 2012-07-15 19:29:22.000000000 +0200
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/48820
+!
+! Assumed-rank constraint checks and other diagnostics
+!
+
+subroutine foo(x) ! { dg-error "Assumed-type variable x at .1. may not have the INTENT.OUT. attribute" }
+ type(*), intent(out) :: x
+end subroutine
+
+subroutine bar(x)
+ integer, intent(out) :: x(..)
+end subroutine bar
+
+subroutine foo3(y)
+ integer :: y(..)
+ y = 7 ! { dg-error "Assumed-rank variable y at .1. may only be used as actual argument" }
+ print *, y + 10 ! { dg-error "Assumed-rank variable y at .1. may only be used as actual argument" }
+ print *, y ! { dg-error "Assumed-rank variable y at .1. may only be used as actual argument" }
+end subroutine
+
+subroutine foo2(x, y)
+ integer :: x(..), y(..)
+ call valid3(x(:)) ! { dg-error "Assumed-rank variable x at .1. shall not have a subobject reference" }
+contains
+ subroutine valid3(y)
+ integer :: y(..)
+ end subroutine
+end subroutine
+
+subroutine foo4(x) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
+ integer, codimension[*] :: x(..)
+end subroutine
+
+subroutine foo5(y) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
+ integer :: y(..)[*]
+end subroutine
--- /dev/null 2012-07-14 08:59:06.947592273 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_7.f90 2012-07-13 16:38:43.000000000 +0200
@@ -0,0 +1,66 @@
+! { dg-do run }
+!
+! PR fortran/48820
+!
+! Handle type/class for assumed-rank arrays
+!
+! FIXME: The ubound/lbound checks have to be re-enabled when
+! after they are supported.
+! FIXME: Passing a CLASS to a CLASS has to be re-enabled.
+implicit none
+type t
+ integer :: i
+end type
+
+class(T), allocatable :: ac(:,:)
+type(T), allocatable :: at(:,:)
+integer :: i
+
+allocate(ac(2:3,2:4))
+allocate(at(2:3,2:4))
+
+i = 0
+call foo(ac)
+call foo(at)
+call bar(ac)
+call bar(at)
+if (i /= 12) call abort()
+
+contains
+ subroutine bar(x)
+ type(t) :: x(..)
+! if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+ if (size(x) /= 6) call abort()
+ if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+! if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+ i = i + 1
+ call foo(x)
+ call bar2(x)
+ end subroutine
+ subroutine bar2(x)
+ type(t) :: x(..)
+! if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+ if (size(x) /= 6) call abort()
+ if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+! if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+ i = i + 1
+ end subroutine
+ subroutine foo(x)
+ class(t) :: x(..)
+! if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+ if (size(x) /= 6) call abort()
+ if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+! if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+ i = i + 1
+ call foo2(x)
+! call bar2(x) ! Passing a CLASS to a TYPE does not yet work
+ end subroutine
+ subroutine foo2(x)
+ class(t) :: x(..)
+! if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+ if (size(x) /= 6) call abort()
+ if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+! if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+ i = i + 1
+ end subroutine
+end
--- /dev/null 2012-07-14 08:59:06.947592273 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_8.f90 2012-07-15 19:35:32.000000000 +0200
@@ -0,0 +1,71 @@
+! { dg-do run }
+! { dg-additional-sources assumed_rank_8_c.c }
+!
+! PR fortran/48820
+!
+! Scalars to assumed-rank tests
+!
+program main
+ implicit none
+
+ interface
+ subroutine check (x)
+ integer :: x(..)
+ end subroutine check
+ end interface
+
+ integer, target :: ii, j
+ integer, allocatable :: kk
+ integer, pointer :: ll
+ ii = 489
+ j = 0
+ call f (ii)
+ call f (489)
+ call f ()
+ call f (null())
+ call f (kk)
+ if (j /= 2) call abort()
+
+ j = 0
+ nullify (ll)
+ call g (null())
+ call g (ll)
+ call g (ii)
+ if (j /= 1) call abort()
+
+ j = 0
+ call h (kk)
+ kk = 489
+ call h (kk)
+ if (j /= 1) call abort()
+
+contains
+
+ subroutine f (x)
+ integer, optional :: x(..)
+
+ if (.not. present (x)) return
+ if (rank (x) /= 0) call abort
+ call check (x)
+ j = j + 1
+ end subroutine
+
+ subroutine g (x)
+ integer, pointer, intent(in) :: x(..)
+
+ if (.not. associated (x)) return
+ if (rank (x) /= 0) call abort ()
+ call check (x)
+ j = j + 1
+ end subroutine
+
+ subroutine h (x)
+ integer, allocatable :: x(..)
+
+ if (.not. allocated (x)) return
+ if (rank (x) /= 0) call abort
+ call check (x)
+ j = j + 1
+ end subroutine
+
+end program main
--- /dev/null 2012-07-14 08:59:06.947592273 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_8_c.c 2012-07-15 19:34:46.000000000 +0200
@@ -0,0 +1,25 @@
+/* Called by assumed_rank_8.f90 and assumed_rank_9.f90. */
+
+#include <stdlib.h> /* For abort(). */
+
+struct a {
+ int *dat;
+};
+
+struct b {
+ struct a _data;
+};
+
+
+void check_ (struct a *x)
+{
+ if (*x->dat != 489)
+ abort ();
+}
+
+
+void check2_ (struct b *x)
+{
+ if (*x->_data.dat != 489)
+ abort ();
+}
--- /dev/null 2012-07-14 08:59:06.947592273 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_9.f90 2012-07-15 19:35:37.000000000 +0200
@@ -0,0 +1,139 @@
+! { dg-do run }
+! { dg-additional-sources assumed_rank_8_c.c }
+!
+! PR fortran/48820
+!
+! Scalars to assumed-rank tests
+!
+program main
+ implicit none
+
+ type t
+ integer :: i
+ end type t
+
+ interface
+ subroutine check (x)
+ integer :: x(..)
+ end subroutine check
+ subroutine check2 (x)
+ import t
+ class(t) :: x(..)
+ end subroutine check2
+ end interface
+
+ integer :: j
+
+ type(t), target :: y
+ class(t), allocatable, target :: yac
+
+ y%i = 489
+ allocate (yac)
+ yac%i = 489
+ j = 0
+ call fc()
+ call fc(null())
+ call fc(y)
+ call fc(yac)
+ if (j /= 2) call abort ()
+
+ j = 0
+ call gc(null())
+ call gc(y)
+ call gc(yac)
+ deallocate (yac)
+ call gc(yac)
+ if (j /= 2) call abort ()
+
+ j = 0
+ call hc(yac)
+ allocate (yac)
+ yac%i = 489
+ call hc(yac)
+ if (j /= 1) call abort ()
+
+ j = 0
+ call ft()
+ call ft(null())
+ call ft(y)
+ call ft(yac)
+ if (j /= 2) call abort ()
+
+ j = 0
+ call gt(null())
+ call gt(y)
+ call gt(yac)
+ deallocate (yac)
+ call gt(yac)
+ if (j /= 2) call abort ()
+
+ j = 0
+ call ht(yac)
+ allocate (yac)
+ yac%i = 489
+ call ht(yac)
+ if (j /= 1) call abort ()
+
+contains
+
+ subroutine fc (x)
+ class(t), optional :: x(..)
+
+ if (.not. present (x)) return
+ if (.not. SAME_TYPE_AS (x, yac)) call abort ()
+ if (rank (x) /= 0) call abort
+ call check2 (x)
+ j = j + 1
+ end subroutine
+
+ subroutine gc (x)
+ class(t), pointer, intent(in) :: x(..)
+
+ if (.not. associated (x)) return
+ if (.not. SAME_TYPE_AS (x, yac)) call abort ()
+ if (rank (x) /= 0) call abort ()
+ call check2 (x)
+ j = j + 1
+ end subroutine
+
+ subroutine hc (x)
+ class(t), allocatable :: x(..)
+
+ if (.not. allocated (x)) return
+ if (.not. SAME_TYPE_AS (x, yac)) call abort ()
+ if (rank (x) /= 0) call abort
+ call check2 (x)
+ j = j + 1
+ end subroutine
+
+ subroutine ft (x)
+ type(t), optional :: x(..)
+
+ if (.not. present (x)) return
+ if (.not. SAME_TYPE_AS (x, yac)) call abort ()
+ if (rank (x) /= 0) call abort
+ call check2 (x)
+ j = j + 1
+ end subroutine
+
+ subroutine gt (x)
+ type(t), pointer, intent(in) :: x(..)
+
+ if (.not. associated (x)) return
+ if (.not. SAME_TYPE_AS (x, yac)) call abort ()
+ if (rank (x) /= 0) call abort ()
+ call check2 (x)
+ j = j + 1
+ end subroutine
+
+ subroutine ht (x)
+ type(t), allocatable :: x(..)
+
+ if (.not. allocated (x)) return
+ if (.not. SAME_TYPE_AS (x, yac)) call abort ()
+ if (rank (x) /= 0) call abort
+ call check2 (x)
+ j = j + 1
+ end subroutine
+
+end program main
--- /dev/null 2012-07-14 08:59:06.947592273 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 2012-07-15 20:34:21.000000000 +0200
@@ -0,0 +1,106 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/48820
+!
+! Ensure that the value of scalars to assumed-rank arrays is
+! copied back, if and only its pointer address could have changed.
+!
+program test
+ implicit none
+ type t
+ integer :: aa
+ end type t
+
+ integer, allocatable :: iia
+ integer, pointer :: iip
+
+ type(t), allocatable :: jja
+ type(t), pointer :: jjp
+
+ logical :: is_present
+
+ is_present = .true.
+
+ allocate (iip, jjp)
+
+ iia = 7
+ iip = 7
+ jja = t(88)
+ jjp = t(88)
+
+ call faa(iia, jja) ! Copy back
+ if (iia /= 7 .and. jja%aa /= 88) call abort ()
+ call fai(iia, jja) ! No copy back
+ if (iia /= 7 .and. jja%aa /= 88) call abort ()
+
+ call fpa(iip, jjp) ! Copy back
+ if (iip /= 7 .and. jjp%aa /= 88) call abort ()
+ call fpi(iip, jjp) ! No copy back
+ if (iip /= 7 .and. jjp%aa /= 88) call abort ()
+
+ call fnn(iia, jja) ! No copy back
+ if (iia /= 7 .and. jja%aa /= 88) call abort ()
+ call fno(iia, jja) ! No copy back
+ if (iia /= 7 .and. jja%aa /= 88) call abort ()
+ call fnn(iip, jjp) ! No copy back
+ if (iip /= 7 .and. jjp%aa /= 88) call abort ()
+ call fno(iip, jjp) ! No copy back
+ if (iip /= 7 .and. jjp%aa /= 88) call abort ()
+
+ is_present = .false.
+
+ call fpa(null(), null()) ! No copy back
+ call fpi(null(), null()) ! No copy back
+ call fno(null(), null()) ! No copy back
+
+ call fno() ! No copy back
+
+contains
+
+ subroutine faa (xx1, yy1)
+ integer, allocatable :: xx1(..)
+ type(t), allocatable :: yy1(..)
+ if (.not. allocated (xx1)) call abort ()
+ if (.not. allocated (yy1)) call abort ()
+ end subroutine faa
+ subroutine fai (xx1, yy1)
+ integer, allocatable, intent(in) :: xx1(..)
+ type(t), allocatable, intent(in) :: yy1(..)
+ if (.not. allocated (xx1)) call abort ()
+ if (.not. allocated (yy1)) call abort ()
+ end subroutine fai
+ subroutine fpa (xx1, yy1)
+ integer, pointer :: xx1(..)
+ type(t), pointer :: yy1(..)
+ if (is_present .neqv. associated (xx1)) call abort ()
+ if (is_present .neqv. associated (yy1)) call abort ()
+ end subroutine fpa
+
+ subroutine fpi (xx1, yy1)
+ integer, pointer, intent(in) :: xx1(..)
+ type(t), pointer, intent(in) :: yy1(..)
+ if (is_present .neqv. associated (xx1)) call abort ()
+ if (is_present .neqv. associated (yy1)) call abort ()
+ end subroutine fpi
+
+ subroutine fnn(xx2,yy2)
+ integer :: xx2(..)
+ type(t) :: yy2(..)
+ end subroutine fnn
+
+ subroutine fno(xx2,yy2)
+ integer, optional :: xx2(..)
+ type(t), optional :: yy2(..)
+ if (is_present .neqv. present (xx2)) call abort ()
+ if (is_present .neqv. present (yy2)) call abort ()
+ end subroutine fno
+end program test
+
+! We should have exactly one copy back per variable
+!
+! { dg-final { scan-tree-dump-times "iip = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "iia = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "jjp = .struct t .. desc.\[0-9\]+.data;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "jja = .struct t .. desc.\[0-9\]+.data;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-15 19:14 ` Tobias Burnus
@ 2012-07-19 15:58 ` Mikael Morin
2012-07-19 17:39 ` Mikael Morin
` (2 more replies)
0 siblings, 3 replies; 18+ messages in thread
From: Mikael Morin @ 2012-07-19 15:58 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 10344 bytes --]
On 15/07/2012 21:13, Tobias Burnus wrote:
> Hello,
>
> attached is an updated version of the patch. Changes:
>
Updated version of comments:
> diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
> index c3644b6..959a57b 100644
> --- a/gcc/fortran/decl.c
> +++ b/gcc/fortran/decl.c
> @@ -594,7 +594,7 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
> {
> int i;
>
> - if (to->rank == 0 && from->rank > 0)
> + if (to->rank == 0 && from->rank != 0)
> {
> to->rank = from->rank;
> to->type = from->type;
I'm not sure it is relevant to support assumed rank here, as it is
mutually exclusive with codimensions.
If it is, I think there may be a problem as we are using from->rank to
index lower and upper bounds, which is bogus if from->rank == -1.
Maybe add:
gcc_assert (from->rank != -1 || to->corank == 0);
> @@ -622,20 +622,24 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
> }
> else if (to->corank == 0 && from->corank > 0)
> {
> + int rank;
> +
> to->corank = from->corank;
> to->cotype = from->cotype;
>
> + rank = to->rank == -1 ? 0 : to->rank;
> +
> for (i = 0; i < from->corank; i++)
> {
> if (copy)
> {
> - to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
> - to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
> + to->lower[rank + i] = gfc_copy_expr (from->lower[i]);
> + to->upper[rank + i] = gfc_copy_expr (from->upper[i]);
> }
> else
> {
> - to->lower[to->rank + i] = from->lower[i];
> - to->upper[to->rank + i] = from->upper[i];
> + to->lower[rank + i] = from->lower[i];
> + to->upper[rank + i] = from->upper[i];
> }
> }
> }
Access to lower and upper bounds is OK, but again maybe we could
just assert here.
> diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
> index 6f40ba7..64efbcb 100644
> --- a/gcc/fortran/interface.c
> +++ b/gcc/fortran/interface.c
> @@ -1743,7 +1752,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
> }
>
> /* F2008, 12.5.2.5; IR F08/0073. */
> - if (formal->ts.type == BT_CLASS
> + if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL
> && ((CLASS_DATA (formal)->attr.class_pointer
> && !formal->attr.intent == INTENT_IN)
> || CLASS_DATA (formal)->attr.allocatable))
About this hunk, ...
> @@ -2289,11 +2299,21 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
> return 0;
> }
>
> - if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
> - && (f->sym->attr.allocatable || !f->sym->attr.optional
> - || (gfc_option.allow_std & GFC_STD_F2008) == 0))
> - {
> - if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
> + if (a->expr->expr_type == EXPR_NULL
> + && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
> + && (f->sym->attr.allocatable || !f->sym->attr.optional
> + || (gfc_option.allow_std & GFC_STD_F2008) == 0))
> + || (f->sym->ts.type == BT_CLASS
> + && !CLASS_DATA (f->sym)->attr.class_pointer
> + && (CLASS_DATA (f->sym)->attr.allocatable
> + || !f->sym->attr.optional
> + || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
> + {
> + if (where
> + && (!f->sym->attr.optional
> + || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
> + || (f->sym->ts.type == BT_CLASS
> + && CLASS_DATA (f->sym)->attr.allocatable)))
> gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
> where, f->sym->name);
> else if (where)
... this hunk, ...
> diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
> index 5be1857..3534e63 100644
> --- a/gcc/fortran/resolve.c
> +++ b/gcc/fortran/resolve.c
> @@ -284,23 +286,34 @@ resolve_formal_arglist (gfc_symbol *proc)
> gfc_set_default_type (sym, 1, sym->ns);
> }
>
> - gfc_resolve_array_spec (sym->as, 0);
> + as = sym->ts.type == BT_CLASS && sym->attr.class_ok
> + ? CLASS_DATA (sym)->as : sym->as;
> +
> + gfc_resolve_array_spec (as, 0);
>
> /* We can't tell if an array with dimension (:) is assumed or deferred
> shape until we know if it has the pointer or allocatable attributes.
> */
> - if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
> - && !(sym->attr.pointer || sym->attr.allocatable)
> + if (as && as->rank > 0 && as->type == AS_DEFERRED
> + && ((sym->ts.type != BT_CLASS
> + && !(sym->attr.pointer || sym->attr.allocatable))
> + || (sym->ts.type == BT_CLASS
> + && !(CLASS_DATA (sym)->attr.class_pointer
> + || CLASS_DATA (sym)->attr.allocatable)))
> && sym->attr.flavor != FL_PROCEDURE)
> {
> - sym->as->type = AS_ASSUMED_SHAPE;
> - for (i = 0; i < sym->as->rank; i++)
> - sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
> - NULL, 1);
> + as->type = AS_ASSUMED_SHAPE;
> + for (i = 0; i < as->rank; i++)
> + as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
> }
>
> - if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
> + if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
> + || (as && as->type == AS_ASSUMED_RANK)
> || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
> + || (sym->ts.type == BT_CLASS && sym->attr.class_ok
> + && (CLASS_DATA (sym)->attr.class_pointer
> + || CLASS_DATA (sym)->attr.allocatable
> + || CLASS_DATA (sym)->attr.target))
> || sym->attr.optional)
> {
> proc->attr.always_explicit = 1;
... this hunk with the AS_ASSUMED_RANK line removed, ...
> diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
> index 34e0f69..7ec40b1 100644
> --- a/gcc/fortran/trans-expr.c
> +++ b/gcc/fortran/trans-expr.c
> @@ -3620,10 +3741,15 @@ gfc_conv_procedure_call (gfc_se * se,
gfc_symbol * sym,
> parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
> }
> }
> - else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
> + else if (arg->expr->expr_type == EXPR_NULL
> + && fsym && !fsym->attr.pointer
> + && (fsym->ts.type != BT_CLASS
> + || !CLASS_DATA (fsym)->attr.class_pointer))
> {
> /* Pass a NULL pointer to denote an absent arg. */
> - gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
> + gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
> + && (fsym->ts.type != BT_CLASS
> + || !CLASS_DATA (fsym)->attr.allocatable));
> gfc_init_se (&parmse, NULL);
> parmse.expr = null_pointer_node;
> if (arg->missing_arg_type == BT_CHARACTER)
... and this hunk:
The four of them are not directly related to the assumed rank stuff, and
thus deserve a separate commit.
As you said:
> * Unrelated bug fixes, found when writing the test cases and thus
included:
I assume they don't need testcases of their own, so that they are
approved as is.
> @@ -10332,10 +10408,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
> return FAILURE;
> }
>
> - if (pointer && dimension)
> + if (pointer && dimension && as->type != AS_ASSUMED_RANK)
> {
> - gfc_error ("Array pointer '%s' at %L must have a deferred shape",
> - sym->name, &sym->declared_at);
> + gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
> + "deferred rank", sym->name, &sym->declared_at);
> return FAILURE;
> }
> }
s/deferred rank/assumed rank/ ?
> diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
> index 34e0f69..7ec40b1 100644
> --- a/gcc/fortran/trans-expr.c
> +++ b/gcc/fortran/trans-expr.c
> @@ -3808,7 +3936,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
> gfc_add_expr_to_block (&se->pre, tmp);
> }
>
> - if (fsym && e->expr_type != EXPR_NULL
> + /* Wrap scalar variable in a descriptor. We need to convert
> + the address of a pointer back to the pointer itself before,
> + we can assign it to the data field. */
> +
> + if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
> + && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
> + {
> + tmp = parmse.expr;
> + if (TREE_CODE (tmp) == ADDR_EXPR
> + && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
This looks fragile. If you have {tmp = &ptr; value = tmp;} instead of
{value = &ptr;} it doesn't work anymore.
You can rely on fsym->attr.{pointer,allocatable,...) instead, or can't you?
> + tmp = TREE_OPERAND (tmp, 0);
> + parmse.expr = conv_scalar_to_descriptor (se, tmp,
> + fsym->attr);
> + parmse.expr = gfc_build_addr_expr (NULL_TREE,
> + parmse.expr);
> + }
> + else if (fsym && e->expr_type != EXPR_NULL
> && ((fsym->attr.pointer
> && fsym->attr.flavor != FL_PROCEDURE)
> || (fsym->attr.proc_pointer
Now about:
> Mikael Morin wrote:
>> What about naming the flag in_actual_arg and moving the
>> inquiry_argument condition to the error condition?
>
> That doesn't work as it is not only valid as inquiry argument but also
> for other actual arguments – those which have an assumed-type or
> assumed-rank dummy argument.
>
I didn't mean changing the semantics.
This assumed_type_rank_allowed flag is cleared in a function, set in
another, and used in a third, which makes it difficult to understand
what it does (the name, initially OK, doesn't help when assumed rank
gets in the mix). I was proposing using some flags (as I don't see how
to do without) with more trivial meaning, and get to the same result by
assembling them.
I attach a patch showing what I had in mind. I think it is equivalent;
it passes your assumed rank testcases at least. As a cherry on the cake,
it brings a small diagnostic improvement regarding assumed type/rank and
inquiry functions. Let's hope you like the wording.
As second attachment, there is a patch restoring the flags in case of
failure, as that was making me uncomfortable.
I'm regression testing them, and if they work and are fine to you, let's
go with these patches.
Regarding the assumed rank patch, it is in pretty good shape. I think
modulo the few nits outlined above, it is ready to go in.
Mikael
[-- Attachment #2: assumed_rank_flags.diff --]
[-- Type: text/x-patch, Size: 6198 bytes --]
diff --git a/resolve.c b/resolve.c
index 10593ac..ccaa098 100644
--- a/resolve.c
+++ b/resolve.c
@@ -64,8 +64,13 @@ static code_stack *cs_base = NULL;
static int forall_flag;
static int do_concurrent_flag;
-/* Nonzero for assumed rank and for assumed type. */
-static bool assumed_rank_type_expr_allowed = false;
+/* True when we are resolving an expression that is an actual argument to
+ a procedure. */
+static bool actual_arg = false;
+/* True when we are resolving an expression that is the first actual argument
+ to a procedure. */
+static bool first_actual_arg = false;
+
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
@@ -87,6 +92,7 @@ static bitmap_obstack labels_obstack;
/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
static bool inquiry_argument = false;
+
int
gfc_is_formal_arg (void)
{
@@ -1612,8 +1618,10 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
+ bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
- assumed_rank_type_expr_allowed = true;
+ actual_arg = true;
+ first_actual_arg = true;
for (; arg; arg = arg->next)
{
@@ -1630,6 +1638,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
return FAILURE;
}
}
+ first_actual_arg = false;
continue;
}
@@ -1847,17 +1856,10 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
return FAILURE;
}
- /* TS29113, C407b and C535b: Assumed-type and assumed-rank are only
- allowed for the first argument.
- Cf. http://j3-fortran.org/pipermail/j3/2012-June/005419.html
- FIXME: It doesn't work reliably as inquiry_argument is not set
- for all inquiry functions in resolve_function; the reason is that
- the function-name resolution happens too late in that function. */
- if (inquiry_argument)
- assumed_rank_type_expr_allowed = false;
-
+ first_actual_arg = false;
}
- assumed_rank_type_expr_allowed = false;
+ actual_arg = actual_arg_sav;
+ first_actual_arg = first_actual_arg_sav;
return SUCCESS;
}
@@ -5109,33 +5111,60 @@ resolve_variable (gfc_expr *e)
sym = e->symtree->n.sym;
/* TS 29113, 407b. */
- if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed)
+ if (e->ts.type == BT_ASSUMED)
{
- gfc_error ("Invalid expression with assumed-type variable %s at %L",
- sym->name, &e->where);
- return FAILURE;
+ if (!actual_arg)
+ {
+ gfc_error ("Assumed-type variable %s at %L may only be used "
+ "as actual argument", sym->name, &e->where);
+ return FAILURE;
+ }
+ else if (inquiry_argument && !first_actual_arg)
+ {
+ /* FIXME: It doesn't work reliably as inquiry_argument is not set
+ for all inquiry functions in resolve_function; the reason is
+ that the function-name resolution happens too late in that
+ function. */
+ gfc_error ("Assumed-type variable %s at %L as actual argument to "
+ "an inquiry function shall be the first argument",
+ sym->name, &e->where);
+ return FAILURE;
+ }
}
/* TS 29113, C535b. */
- if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
&& CLASS_DATA (sym)->as
&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
|| (sym->ts.type != BT_CLASS && sym->as
&& sym->as->type == AS_ASSUMED_RANK))
- && !assumed_rank_type_expr_allowed)
{
- gfc_error ("Assumed-rank variable %s at %L may only be used as actual "
- "argument", sym->name, &e->where);
- return FAILURE;
+ if (!actual_arg)
+ {
+ gfc_error ("Assumed-rank variable %s at %L may only be used as "
+ "actual argument", sym->name, &e->where);
+ return FAILURE;
+ }
+ else if (inquiry_argument && !first_actual_arg)
+ {
+ /* FIXME: It doesn't work reliably as inquiry_argument is not set
+ for all inquiry functions in resolve_function; the reason is
+ that the function-name resolution happens too late in that
+ function. */
+ gfc_error ("Assumed-rank variable %s at %L as actual argument "
+ "to an inquiry function shall be the first argument",
+ sym->name, &e->where);
+ return FAILURE;
+ }
}
/* TS 29113, 407b. */
if (e->ts.type == BT_ASSUMED && e->ref
&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
- && e->ref->next == NULL))
+ && e->ref->next == NULL))
{
- gfc_error ("Assumed-type variable %s with designator at %L",
- sym->name, &e->ref->u.ar.where);
+ gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
+ "reference", sym->name, &e->ref->u.ar.where);
return FAILURE;
}
@@ -5147,7 +5176,7 @@ resolve_variable (gfc_expr *e)
&& sym->as->type == AS_ASSUMED_RANK))
&& e->ref
&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
- && e->ref->next == NULL))
+ && e->ref->next == NULL))
{
gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
"reference", sym->name, &e->ref->u.ar.where);
@@ -6365,19 +6394,21 @@ gfc_try
gfc_resolve_expr (gfc_expr *e)
{
gfc_try t;
- bool inquiry_save, assumed_rank_type_save;
+ bool inquiry_save, actual_arg_save, first_actual_arg_save;
if (e == NULL)
return SUCCESS;
/* inquiry_argument only applies to variables. */
inquiry_save = inquiry_argument;
- assumed_rank_type_save = assumed_rank_type_expr_allowed;
+ actual_arg_save = actual_arg;
+ first_actual_arg_save = first_actual_arg;
if (e->expr_type != EXPR_VARIABLE)
{
inquiry_argument = false;
- assumed_rank_type_expr_allowed = false;
+ actual_arg = false;
+ first_actual_arg = false;
}
switch (e->expr_type)
@@ -6468,7 +6499,8 @@ gfc_resolve_expr (gfc_expr *e)
fixup_charlen (e);
inquiry_argument = inquiry_save;
- assumed_rank_type_expr_allowed = assumed_rank_type_save;
+ actual_arg = actual_arg_save;
+ first_actual_arg = first_actual_arg_save;
return t;
}
[-- Attachment #3: assumed_rank_flags_cleanup.diff --]
[-- Type: text/x-patch, Size: 5119 bytes --]
diff --git a/resolve.c b/resolve.c
index ccaa098..76a1e2c 100644
--- a/resolve.c
+++ b/resolve.c
@@ -1618,6 +1618,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
+ gfc_try return_value = FAILURE;
bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
actual_arg = true;
@@ -1635,7 +1636,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("Label %d referenced at %L is never defined",
arg->label->value, &arg->label->where);
- return FAILURE;
+ goto cleanup;
}
}
first_actual_arg = false;
@@ -1646,7 +1647,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
&& e->symtree->n.sym->attr.generic
&& no_formal_args
&& count_specific_procs (e) != 1)
- return FAILURE;
+ goto cleanup;
if (e->ts.type != BT_PROCEDURE)
{
@@ -1654,7 +1655,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
- return FAILURE;
+ goto cleanup;
need_full_assumed_size = save_need_full_assumed_size;
goto argument_list;
}
@@ -1698,7 +1699,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
"Fortran 2008: Internal procedure '%s' is"
" used as actual argument at %L",
sym->name, &e->where) == FAILURE)
- return FAILURE;
+ goto cleanup;
}
if (sym->attr.elemental && !sym->attr.intrinsic)
@@ -1711,8 +1712,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
/* Check if a generic interface has a specific procedure
with the same name before emitting an error. */
if (sym->attr.generic && count_specific_procs (e) != 1)
- return FAILURE;
-
+ goto cleanup;
+
/* Just in case a specific was found for the expression. */
sym = e->symtree->n.sym;
@@ -1733,7 +1734,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_error ("Unable to find a specific INTRINSIC procedure "
"for the reference '%s' at %L", sym->name,
&e->where);
- return FAILURE;
+ goto cleanup;
}
sym->ts = isym->ts;
sym->attr.intrinsic = 1;
@@ -1741,7 +1742,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
}
if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
+ goto cleanup;
goto argument_list;
}
@@ -1753,7 +1754,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
{
gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
- return FAILURE;
+ goto cleanup;
}
if (parent_st == NULL)
@@ -1767,7 +1768,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
|| sym->attr.external)
{
if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
+ goto cleanup;
goto argument_list;
}
@@ -1795,7 +1796,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
- return FAILURE;
+ goto cleanup;
need_full_assumed_size = save_need_full_assumed_size;
argument_list:
@@ -1809,14 +1810,14 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("By-value argument at %L is not of numeric "
"type", &e->where);
- return FAILURE;
+ goto cleanup;
}
if (e->rank)
{
gfc_error ("By-value argument at %L cannot be an array or "
"an array section", &e->where);
- return FAILURE;
+ goto cleanup;
}
/* Intrinsics are still PROC_UNKNOWN here. However,
@@ -1830,7 +1831,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("By-value argument at %L is not allowed "
"in this context", &e->where);
- return FAILURE;
+ goto cleanup;
}
}
@@ -1842,26 +1843,30 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("Passing internal procedure at %L by location "
"not allowed", &e->where);
- return FAILURE;
+ goto cleanup;
}
}
}
/* Fortran 2008, C1237. */
if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
- && gfc_has_ultimate_pointer (e))
- {
- gfc_error ("Coindexed actual argument at %L with ultimate pointer "
+ && gfc_has_ultimate_pointer (e))
+ {
+ gfc_error ("Coindexed actual argument at %L with ultimate pointer "
"component", &e->where);
- return FAILURE;
- }
+ goto cleanup;
+ }
first_actual_arg = false;
}
+
+ return_value = SUCCESS;
+
+cleanup:
actual_arg = actual_arg_sav;
first_actual_arg = first_actual_arg_sav;
- return SUCCESS;
+ return return_value;
}
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-19 15:58 ` Mikael Morin
@ 2012-07-19 17:39 ` Mikael Morin
2012-07-19 20:21 ` Tobias Burnus
2012-07-19 21:36 ` Tobias Burnus
2 siblings, 0 replies; 18+ messages in thread
From: Mikael Morin @ 2012-07-19 17:39 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 204 bytes --]
On 19/07/2012 17:55, Mikael Morin wrote:
> I'm regression testing them, and if they work and are fine to you, let's
> go with these patches.
>
They work with the following testsuite adjustment.
Mikael
[-- Attachment #2: assumed_type_3.diff --]
[-- Type: text/x-patch, Size: 819 bytes --]
diff --git a/gcc/testsuite/gfortran.dg/assumed_type_3.f90 b/gcc/testsuite/gfortran.dg/assumed_type_3.f90
index d88da34..8d2be25 100644
--- a/gcc/testsuite/gfortran.dg/assumed_type_3.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_type_3.f90
@@ -31,7 +31,7 @@ end subroutine six
subroutine seven(y)
type(*) :: y(:)
- call a7(y(3:5)) ! { dg-error "Assumed-type variable y with designator" }
+ call a7(y(3:5)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" }
contains
subroutine a7(x)
type(*) :: x(*)
@@ -115,5 +115,5 @@ end subroutine thirteen
subroutine fourteen(x)
type(*) :: x
- x = x ! { dg-error "Invalid expression with assumed-type variable" }
+ x = x ! { dg-error "Assumed-type variable x at .1. may only be used as actual argument" }
end subroutine fourteen
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-19 15:58 ` Mikael Morin
2012-07-19 17:39 ` Mikael Morin
@ 2012-07-19 20:21 ` Tobias Burnus
2012-07-19 21:36 ` Tobias Burnus
2 siblings, 0 replies; 18+ messages in thread
From: Tobias Burnus @ 2012-07-19 20:21 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 819 bytes --]
Mikael Morin wrote:
> The four of them are not directly related to the assumed rank stuff, and
> thus deserve a separate commit.
> As you said:
>> >* Unrelated bug fixes, found when writing the test cases and thus
> included:
> I assume they don't need testcases of their own, so that they are
> approved as is.
>
Thanks for the review. I have committed them – after regtesting – as
Rev. 189669 (interface.c) and Rev. 189678 (resolve.c, interface.c).
I will now have a look at the other review comments and your patch.
Thanks for walking through the big patch.
* * *
Patches with pending review:
* Allowed assumed-shape with bind(C) [TS29113]:
http://gcc.gnu.org/ml/fortran/2012-07/msg00086.html
* C_F_POINTER changes for the fortran-dev branch:
http://gcc.gnu.org/ml/fortran/2012-07/msg00045.html
Tobias
[-- Attachment #2: commit-Rev189669.diff --]
[-- Type: text/x-patch, Size: 2036 bytes --]
Index: interface.c
===================================================================
--- interface.c (Revision 189668)
+++ interface.c (Arbeitskopie)
@@ -1743,7 +1743,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *a
}
/* F2008, 12.5.2.5; IR F08/0073. */
- if (formal->ts.type == BT_CLASS
+ if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL
&& ((CLASS_DATA (formal)->attr.class_pointer
&& !formal->attr.intent == INTENT_IN)
|| CLASS_DATA (formal)->attr.allocatable))
@@ -2289,11 +2289,21 @@ compare_actual_formal (gfc_actual_arglist **ap, gf
return 0;
}
- if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
- && (f->sym->attr.allocatable || !f->sym->attr.optional
- || (gfc_option.allow_std & GFC_STD_F2008) == 0))
+ if (a->expr->expr_type == EXPR_NULL
+ && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
+ && (f->sym->attr.allocatable || !f->sym->attr.optional
+ || (gfc_option.allow_std & GFC_STD_F2008) == 0))
+ || (f->sym->ts.type == BT_CLASS
+ && !CLASS_DATA (f->sym)->attr.class_pointer
+ && (CLASS_DATA (f->sym)->attr.allocatable
+ || !f->sym->attr.optional
+ || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
{
- if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
+ if (where
+ && (!f->sym->attr.optional
+ || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->attr.allocatable)))
gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
where, f->sym->name);
else if (where)
Index: ChangeLog
===================================================================
--- ChangeLog (Revision 189668)
+++ ChangeLog (Arbeitskopie)
@@ -1,3 +1,8 @@
+2012-07-19 Tobias Burnus <burnus@net-b.de>
+
+ * interface.c (compare_parameter, compare_actual_formal): Fix
+ handling of polymorphic arguments.
+
2012-07-17 Janus Weil <janus@gcc.gnu.org>
PR fortran/51081
[-- Attachment #3: commit-Rev189678.diff --]
[-- Type: text/x-patch, Size: 3550 bytes --]
Index: trans-expr.c
===================================================================
--- trans-expr.c (Revision 189675)
+++ trans-expr.c (Arbeitskopie)
@@ -3620,10 +3620,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
}
}
- else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
+ else if (arg->expr->expr_type == EXPR_NULL
+ && fsym && !fsym->attr.pointer
+ && (fsym->ts.type != BT_CLASS
+ || !CLASS_DATA (fsym)->attr.class_pointer))
{
/* Pass a NULL pointer to denote an absent arg. */
- gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
+ gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
+ && (fsym->ts.type != BT_CLASS
+ || !CLASS_DATA (fsym)->attr.allocatable));
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
if (arg->missing_arg_type == BT_CHARACTER)
Index: ChangeLog
===================================================================
--- ChangeLog (Revision 189675)
+++ ChangeLog (Arbeitskopie)
@@ -1,5 +1,12 @@
2012-07-19 Tobias Burnus <burnus@net-b.de>
+ * trans-expr.c (gfc_conv_procedure_call): Fix handling
+ of polymorphic arguments.
+ * resolve.c (resolve_formal_arglist): Ditto, mark polymorphic
+ assumed-shape arrays as such.
+
+2012-07-19 Tobias Burnus <burnus@net-b.de>
+
* interface.c (compare_parameter, compare_actual_formal): Fix
handling of polymorphic arguments.
Index: resolve.c
===================================================================
--- resolve.c (Revision 189675)
+++ resolve.c (Arbeitskopie)
@@ -251,6 +251,7 @@ resolve_formal_arglist (gfc_symbol *proc)
for (f = proc->formal; f; f = f->next)
{
sym = f->sym;
+ gfc_array_spec *as;
if (sym == NULL)
{
@@ -284,23 +285,33 @@ resolve_formal_arglist (gfc_symbol *proc)
gfc_set_default_type (sym, 1, sym->ns);
}
- gfc_resolve_array_spec (sym->as, 0);
+ as = sym->ts.type == BT_CLASS && sym->attr.class_ok
+ ? CLASS_DATA (sym)->as : sym->as;
+ gfc_resolve_array_spec (as, 0);
+
/* We can't tell if an array with dimension (:) is assumed or deferred
shape until we know if it has the pointer or allocatable attributes.
*/
- if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
- && !(sym->attr.pointer || sym->attr.allocatable)
+ if (as && as->rank > 0 && as->type == AS_DEFERRED
+ && ((sym->ts.type != BT_CLASS
+ && !(sym->attr.pointer || sym->attr.allocatable))
+ || (sym->ts.type == BT_CLASS
+ && !(CLASS_DATA (sym)->attr.class_pointer
+ || CLASS_DATA (sym)->attr.allocatable)))
&& sym->attr.flavor != FL_PROCEDURE)
{
- sym->as->type = AS_ASSUMED_SHAPE;
- for (i = 0; i < sym->as->rank; i++)
- sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, 1);
+ as->type = AS_ASSUMED_SHAPE;
+ for (i = 0; i < as->rank; i++)
+ as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
}
- if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
+ if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && (CLASS_DATA (sym)->attr.class_pointer
+ || CLASS_DATA (sym)->attr.allocatable
+ || CLASS_DATA (sym)->attr.target))
|| sym->attr.optional)
{
proc->attr.always_explicit = 1;
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-19 15:58 ` Mikael Morin
2012-07-19 17:39 ` Mikael Morin
2012-07-19 20:21 ` Tobias Burnus
@ 2012-07-19 21:36 ` Tobias Burnus
2012-07-20 5:58 ` Tobias Burnus
2 siblings, 1 reply; 18+ messages in thread
From: Tobias Burnus @ 2012-07-19 21:36 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran
Am 19.07.2012 17:55, schrieb Mikael Morin:
> Maybe add: gcc_assert (from->rank != -1 || to->corank == 0);
> Access to lower and upper bounds is OK, but again maybe we could just
> assert here.
I will add the asserts – and undo the patch.
> s/deferred rank/assumed rank/ ?
Of course. Well spotted!
>> - if (fsym && e->expr_type != EXPR_NULL
>> + /* Wrap scalar variable in a descriptor. We need to convert
>> + the address of a pointer back to the pointer itself before,
>> + we can assign it to the data field. */
>> +
>> + if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
>> + && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
>> + {
>> + tmp = parmse.expr;
>> + if (TREE_CODE (tmp) == ADDR_EXPR
>> + && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
> This looks fragile. If you have {tmp = &ptr; value = tmp;} instead of
> {value = &ptr;} it doesn't work anymore.
> You can rely on fsym->attr.{pointer,allocatable,...) instead, or can't you?
No, I cannot if I use "if (attr.pointer)" I exactly run into the problem
I want to avoid: Taking the address of the temporary variable, which I
don't want. (Well, actually via TREE_OPERAND, I won't: I get an ICE.)
However, with the current code, I get:
D.1874 = f ();
desc.0.dtype = 600;
desc.0.data = (void *) D.1874;
sub (&desc.0);
D.1874 = (integer(kind=4) *) desc.0.data;
which looks fine.
Thus, I intent to keep my version.
>> Mikael Morin wrote:
>>> What about naming the flag in_actual_arg and moving the
>>> inquiry_argument condition to the error condition?
> I didn't mean changing the semantics.
>
> I attach a patch showing what I had in mind. I think it is equivalent;
> it passes your assumed rank testcases at least. As a cherry on the cake,
> it brings a small diagnostic improvement regarding assumed type/rank and
> inquiry functions. Let's hope you like the wording.
> As second attachment, there is a patch restoring the flags in case of
> failure, as that was making me uncomfortable.
>
> I'm regression testing them, and if they work and are fine to you, let's
> go with these patches.
I will now regtest everything, read through the whole patch – your part
and mine, update the ChangeLog and commit it tomorrow.
Thanks for the review!
Tobias
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-19 21:36 ` Tobias Burnus
@ 2012-07-20 5:58 ` Tobias Burnus
[not found] ` <0EFAB2BDD0F67E4FB6CCC8B9F87D756915E859A4@IRSMSX101.ger.corp.intel.com>
2012-07-20 23:24 ` Andreas Schwab
0 siblings, 2 replies; 18+ messages in thread
From: Tobias Burnus @ 2012-07-20 5:58 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 250 bytes --]
Tobias Burnus wrote:
> I will now regtest everything, read through the whole patch – your
> part and mine, update the ChangeLog and commit it tomorrow.
I have now committed the attached version as Rev. 189700!
Thanks agai for the review!
Tobias
[-- Attachment #2: assumed-rank-2012-07-20.diff --]
[-- Type: text/x-patch, Size: 75681 bytes --]
2012-07-20 Tobias Burnus <burnus@net-b.de>
PR fortran/48820
* array.c (match_array_element_spec, gfc_match_array_spec,
spec_size, gfc_array_dimen_size): Add support for
assumed-rank arrays.
* check.c (dim_rank_check): Ditto.
* class.c (gfc_add_component_ref): Ditto.
(gfc_build_class_symbol): Regard assumed-rank arrays
as having GFC_MAX_DIMENSIONS. And build extra class
container for a scalar pointer class.
* decl.c (merge_array_spec): Add assert.
* dump-parse-tree.c (show_array_spec): Add support for
assumed-rank arrays.
* expr.c (gfc_is_simply_contiguous): Ditto.
* gfortran.h (array_type): Ditto.
(gfc_array_spec, gfc_expr): Add comment to "rank" field.
* interface.c (compare_type_rank, argument_rank_mismatch,
compare_parameter, gfc_procedure_use): Ditto.
(compare_actual_formal): Fix NULL() to optional-dummy
handling for polymorphic dummies.
* module.c (mio_typespec): Add support for
assumed-rank arrays.
* resolve.c (resolve_formal_arglist, resolve_actual_arglist,
resolve_elemental_actual, resolve_global_procedure,
expression_shape, resolve_variable, update_ppc_arglist,
check_typebound_baseobject, gfc_resolve_expr,
resolve_fl_var_and_proc, gfc_resolve_finalizers,
resolve_typebound_procedure, resolve_symbol): Ditto.
(assumed_type_expr_allowed): Remove static variable.
(actual_arg, first_actual_arg): New static variables.
* simplify.c (simplify_bound, gfc_simplify_range): Add
support for assumed-rank arrays.
* trans-array.c (gfc_conv_array_parameter): Ditto.
(gfc_get_descriptor_dimension): New function, which returns
the descriptor.
(gfc_conv_descriptor_dimension): Use it.
(gfc_conv_descriptor_stride_get, gfc_conv_array_parameter):
Handle GFC_ARRAY_ASSUMED_RANK_CONT and AS_ASSUMED_RANK.
* trans-array.h (gfc_get_descriptor_dimension): New prototype.
* trans-decl. (gfc_build_dummy_array_decl,
gfc_trans_deferred_vars, add_argument_checking): Add
support for assumed-rank arrays.
* trans-expr.c (gfc_conv_expr_present, gfc_conv_variable,
gfc_conv_procedure_call): Ditto.
(get_scalar_to_descriptor_type, class_array_data_assign,
conv_scalar_to_descriptor): New static functions.
(gfc_conv_derived_to_class, gfc_conv_class_to_class): Use
them.
* trans-intrinsic.c (get_rank_from_desc): New function.
(gfc_conv_intrinsic_rank, gfc_conv_associated): Use it.
* trans-types.c (gfc_array_descriptor_base_caf,
gfc_array_descriptor_base): Make space for scalar array.
(gfc_is_nodesc_array, gfc_is_nodesc_array,
gfc_build_array_type, gfc_get_array_descriptor_base): Add
support for assumed-rank arrays.
* trans.h (gfc_array_kind): Add GFC_ARRAY_ASSUMED_RANK and
GFC_ARRAY_ASSUMED_RANK_CONT.
2012-07-20 Tobias Burnus <burnus@net-b.de>
PR fortran/48820
* gfortran.dg/assumed_type_3.f90: Update dg-error.
* gfortran.dg/assumed_rank_1.f90: New.
* gfortran.dg/assumed_rank_1_c.c: New.
* gfortran.dg/assumed_rank_2.f90: New.
* gfortran.dg/assumed_rank_4.f90: New.
* gfortran.dg/assumed_rank_5.f90: New.
* gfortran.dg/assumed_rank_6.f90: New.
* gfortran.dg/assumed_rank_7.f90: New.
* gfortran.dg/assumed_rank_8.f90: New.
* gfortran.dg/assumed_rank_8_c.c: New.
* gfortran.dg/assumed_rank_9.f90: New.
* gfortran.dg/assumed_rank_10.f90: New.
* gfortran.dg/assumed_rank_12.f90: New.
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index b852362..acae59f 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -390,9 +390,11 @@ match_array_element_spec (gfc_array_spec *as)
{
gfc_expr **upper, **lower;
match m;
+ int rank;
- lower = &as->lower[as->rank + as->corank - 1];
- upper = &as->upper[as->rank + as->corank - 1];
+ rank = as->rank == -1 ? 0 : as->rank;
+ lower = &as->lower[rank + as->corank - 1];
+ upper = &as->upper[rank + as->corank - 1];
if (gfc_match_char ('*') == MATCH_YES)
{
@@ -458,6 +460,20 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
goto coarray;
}
+ if (gfc_match (" .. )") == MATCH_YES)
+ {
+ as->type = AS_ASSUMED_RANK;
+ as->rank = -1;
+
+ if (gfc_notify_std (GFC_STD_F2008_TS, "Assumed-rank array at %C")
+ == FAILURE)
+ goto cleanup;
+
+ if (!match_codim)
+ goto done;
+ goto coarray;
+ }
+
for (;;)
{
as->rank++;
@@ -536,6 +552,9 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
gfc_error ("Bad specification for assumed size array at %C");
goto cleanup;
+
+ case AS_ASSUMED_RANK:
+ gcc_unreachable ();
}
if (gfc_match_char (')') == MATCH_YES)
@@ -642,6 +661,9 @@ coarray:
case AS_ASSUMED_SIZE:
gfc_error ("Bad specification for assumed size array at %C");
goto cleanup;
+
+ case AS_ASSUMED_RANK:
+ gcc_unreachable ();
}
if (gfc_match_char (']') == MATCH_YES)
@@ -1960,6 +1982,9 @@ spec_size (gfc_array_spec *as, mpz_t *result)
mpz_t size;
int d;
+ if (as->type == AS_ASSUMED_RANK)
+ return FAILURE;
+
mpz_init_set_ui (*result, 1);
for (d = 0; d < as->rank; d++)
@@ -2116,6 +2141,9 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
if (array->ts.type == BT_CLASS)
return FAILURE;
+ if (array->rank == -1)
+ return FAILURE;
+
if (dimen < 0 || array == NULL || dimen > array->rank - 1)
gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index bfd1205..c5bf79b 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -620,6 +620,10 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
else
rank = array->rank;
+ /* Assumed-rank array. */
+ if (rank == -1)
+ rank = GFC_MAX_DIMENSIONS;
+
if (array->expr_type == EXPR_VARIABLE)
{
ar = gfc_find_array_ref (array);
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index fc083dc..21a91ba 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -220,7 +220,7 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
void
gfc_add_class_array_ref (gfc_expr *e)
{
- int rank = CLASS_DATA (e)->as->rank;
+ int rank = CLASS_DATA (e)->as->rank;
gfc_array_spec *as = CLASS_DATA (e)->as;
gfc_ref *ref = NULL;
gfc_add_component_ref (e, "_data");
@@ -498,6 +498,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
+ int rank;
if (as && *as && (*as)->type == AS_ASSUMED_SIZE)
{
@@ -518,11 +519,14 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
return SUCCESS;
/* Determine the name of the encapsulating type. */
+ rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
get_unique_hashed_string (tname, ts->u.derived);
if ((*as) && attr->allocatable)
- sprintf (name, "__class_%s_%d_%da", tname, (*as)->rank, (*as)->corank);
+ sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank);
+ else if ((*as) && attr->pointer)
+ sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank);
else if ((*as))
- sprintf (name, "__class_%s_%d_%d", tname, (*as)->rank, (*as)->corank);
+ sprintf (name, "__class_%s_%d_%d", tname, rank, (*as)->corank);
else if (attr->pointer)
sprintf (name, "__class_%s_p", tname);
else if (attr->allocatable)
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 01693ad..28e5a5b 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -594,6 +594,9 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
{
int i;
+ gcc_assert (from->rank != -1 || to->corank == 0);
+ gcc_assert (to->rank != -1 || from->corank == 0);
+
if (to->rank == 0 && from->rank > 0)
{
to->rank = from->rank;
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 26c5201..681dc8d 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -166,7 +166,7 @@ show_array_spec (gfc_array_spec *as)
fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
- if (as->rank + as->corank > 0)
+ if (as->rank + as->corank > 0 || as->rank == -1)
{
switch (as->type)
{
@@ -174,6 +174,7 @@ show_array_spec (gfc_array_spec *as)
case AS_DEFERRED: c = "AS_DEFERRED"; break;
case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
+ case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break;
default:
gfc_internal_error ("show_array_spec(): Unhandled array shape "
"type.");
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 88a59bc..6109607 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4443,7 +4443,8 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
|| (!part_ref
&& !sym->attr.contiguous
&& (sym->attr.pointer
- || sym->as->type == AS_ASSUMED_SHAPE))))
+ || sym->as->type == AS_ASSUMED_RANK
+ || sym->as->type == AS_ASSUMED_SHAPE))))
return false;
if (!ar || ar->type == AR_FULL)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index fa06883..98bfa8a 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -135,7 +135,8 @@ expr_t;
/* Array types. */
typedef enum
{ AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED,
- AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_UNKNOWN
+ AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_ASSUMED_RANK,
+ AS_UNKNOWN
}
array_type;
@@ -917,7 +918,7 @@ gfc_typespec;
/* Array specification. */
typedef struct
{
- int rank; /* A rank of zero means that a variable is a scalar. */
+ int rank; /* A scalar has a rank of 0, an assumed-rank array has -1. */
int corank;
array_type type, cotype;
struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS];
@@ -1694,7 +1695,7 @@ typedef struct gfc_expr
gfc_typespec ts; /* These two refer to the overall expression */
- int rank;
+ int rank; /* 0 indicates a scalar, -1 an assumed-rank array. */
mpz_t *shape; /* Can be NULL if shape is unknown at compile time */
/* Nonnull for functions and structure constructors, may also used to hold the
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 2e181c9..7dd4b83 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -512,7 +512,9 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
r1 = (s1->as != NULL) ? s1->as->rank : 0;
r2 = (s2->as != NULL) ? s2->as->rank : 0;
- if (r1 != r2)
+ if (r1 != r2
+ && (!s1->as || s1->as->type != AS_ASSUMED_RANK)
+ && (!s2->as || s2->as->type != AS_ASSUMED_RANK))
return 0; /* Ranks differ. */
return gfc_compare_types (&s1->ts, &s2->ts)
@@ -1635,7 +1637,14 @@ static void
argument_rank_mismatch (const char *name, locus *where,
int rank1, int rank2)
{
- if (rank1 == 0)
+
+ /* TS 29113, C407b. */
+ if (rank2 == -1)
+ {
+ gfc_error ("The assumed-rank array at %L requires that the dummy argument"
+ " '%s' has assumed-rank", where, name);
+ }
+ else if (rank1 == 0)
{
gfc_error ("Rank mismatch in argument '%s' at %L "
"(scalar and rank-%d)", name, where, rank2);
@@ -1860,7 +1869,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
" is modified", &actual->where, formal->name);
}
- if (symbol_rank (formal) == actual->rank)
+ /* If the rank is the same or the formal argument has assumed-rank. */
+ if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
return 1;
if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
@@ -3001,6 +3011,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
return;
}
+
+ /* TS 29113, C407b. */
+ if (a->expr && a->expr->expr_type == EXPR_VARIABLE
+ && symbol_rank (a->expr->symtree->n.sym) == -1)
+ {
+ gfc_error ("Assumed-rank argument requires an explicit interface "
+ "at %L", &a->expr->where);
+ return;
+ }
}
return;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 88519b7..a3b9088 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -2341,6 +2341,7 @@ mio_typespec (gfc_typespec *ts)
static const mstring array_spec_types[] = {
minit ("EXPLICIT", AS_EXPLICIT),
+ minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
minit ("DEFERRED", AS_DEFERRED),
minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 753f1c7..7e2d621 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -64,7 +64,13 @@ static code_stack *cs_base = NULL;
static int forall_flag;
static int do_concurrent_flag;
-static bool assumed_type_expr_allowed = false;
+/* True when we are resolving an expression that is an actual argument to
+ a procedure. */
+static bool actual_arg = false;
+/* True when we are resolving an expression that is the first actual argument
+ to a procedure. */
+static bool first_actual_arg = false;
+
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
@@ -86,6 +92,7 @@ static bitmap_obstack labels_obstack;
/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
static bool inquiry_argument = false;
+
int
gfc_is_formal_arg (void)
{
@@ -240,7 +247,7 @@ resolve_formal_arglist (gfc_symbol *proc)
if (gfc_elemental (proc)
|| sym->attr.pointer || sym->attr.allocatable
- || (sym->as && sym->as->rank > 0))
+ || (sym->as && sym->as->rank != 0))
{
proc->attr.always_explicit = 1;
sym->attr.always_explicit = 1;
@@ -307,6 +314,7 @@ resolve_formal_arglist (gfc_symbol *proc)
}
if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
+ || (as && as->type == AS_ASSUMED_RANK)
|| sym->attr.pointer || sym->attr.allocatable || sym->attr.target
|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
&& (CLASS_DATA (sym)->attr.class_pointer
@@ -1610,8 +1618,11 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
+ gfc_try return_value = FAILURE;
+ bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
- assumed_type_expr_allowed = true;
+ actual_arg = true;
+ first_actual_arg = true;
for (; arg; arg = arg->next)
{
@@ -1625,9 +1636,10 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("Label %d referenced at %L is never defined",
arg->label->value, &arg->label->where);
- return FAILURE;
+ goto cleanup;
}
}
+ first_actual_arg = false;
continue;
}
@@ -1635,7 +1647,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
&& e->symtree->n.sym->attr.generic
&& no_formal_args
&& count_specific_procs (e) != 1)
- return FAILURE;
+ goto cleanup;
if (e->ts.type != BT_PROCEDURE)
{
@@ -1643,7 +1655,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
- return FAILURE;
+ goto cleanup;
need_full_assumed_size = save_need_full_assumed_size;
goto argument_list;
}
@@ -1687,7 +1699,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
"Internal procedure '%s' is"
" used as actual argument at %L",
sym->name, &e->where) == FAILURE)
- return FAILURE;
+ goto cleanup;
}
if (sym->attr.elemental && !sym->attr.intrinsic)
@@ -1700,8 +1712,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
/* Check if a generic interface has a specific procedure
with the same name before emitting an error. */
if (sym->attr.generic && count_specific_procs (e) != 1)
- return FAILURE;
-
+ goto cleanup;
+
/* Just in case a specific was found for the expression. */
sym = e->symtree->n.sym;
@@ -1722,7 +1734,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_error ("Unable to find a specific INTRINSIC procedure "
"for the reference '%s' at %L", sym->name,
&e->where);
- return FAILURE;
+ goto cleanup;
}
sym->ts = isym->ts;
sym->attr.intrinsic = 1;
@@ -1730,7 +1742,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
}
if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
+ goto cleanup;
goto argument_list;
}
@@ -1742,7 +1754,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
{
gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
- return FAILURE;
+ goto cleanup;
}
if (parent_st == NULL)
@@ -1756,7 +1768,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
|| sym->attr.external)
{
if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
+ goto cleanup;
goto argument_list;
}
@@ -1784,7 +1796,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
- return FAILURE;
+ goto cleanup;
need_full_assumed_size = save_need_full_assumed_size;
argument_list:
@@ -1798,14 +1810,14 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("By-value argument at %L is not of numeric "
"type", &e->where);
- return FAILURE;
+ goto cleanup;
}
if (e->rank)
{
gfc_error ("By-value argument at %L cannot be an array or "
"an array section", &e->where);
- return FAILURE;
+ goto cleanup;
}
/* Intrinsics are still PROC_UNKNOWN here. However,
@@ -1819,7 +1831,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("By-value argument at %L is not allowed "
"in this context", &e->where);
- return FAILURE;
+ goto cleanup;
}
}
@@ -1831,23 +1843,30 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("Passing internal procedure at %L by location "
"not allowed", &e->where);
- return FAILURE;
+ goto cleanup;
}
}
}
/* Fortran 2008, C1237. */
if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
- && gfc_has_ultimate_pointer (e))
- {
- gfc_error ("Coindexed actual argument at %L with ultimate pointer "
+ && gfc_has_ultimate_pointer (e))
+ {
+ gfc_error ("Coindexed actual argument at %L with ultimate pointer "
"component", &e->where);
- return FAILURE;
- }
+ goto cleanup;
+ }
+
+ first_actual_arg = false;
}
- assumed_type_expr_allowed = false;
- return SUCCESS;
+ return_value = SUCCESS;
+
+cleanup:
+ actual_arg = actual_arg_sav;
+ first_actual_arg = first_actual_arg_sav;
+
+ return return_value;
}
@@ -1907,7 +1926,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
/* The rank of an elemental is the rank of its array argument(s). */
for (arg = arg0; arg; arg = arg->next)
{
- if (arg->expr != NULL && arg->expr->rank > 0)
+ if (arg->expr != NULL && arg->expr->rank != 0)
{
rank = arg->expr->rank;
if (arg->expr->expr_type == EXPR_VARIABLE
@@ -2206,6 +2225,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* TS 29113, 6.2. */
+ else if (arg->sym && arg->sym->as
+ && arg->sym->as->type == AS_ASSUMED_RANK)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
/* F2008, 12.4.2.2 (2c) */
else if (arg->sym->attr.codimension)
{
@@ -2231,6 +2259,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
sym->name, &sym->declared_at, arg->sym->name);
break;
}
+ /* As assumed-type is unlimited polymorphic (cf. above).
+ See also TS 29113, Note 6.1. */
+ else if (arg->sym->ts.type == BT_ASSUMED)
+ {
+ gfc_error ("Procedure '%s' at %L with assumed-type dummy "
+ "argument '%s' must have an explicit interface",
+ sym->name, &sym->declared_at, arg->sym->name);
+ break;
+ }
}
if (def_sym->attr.function)
@@ -4976,7 +5013,7 @@ expression_shape (gfc_expr *e)
mpz_t array[GFC_MAX_DIMENSIONS];
int i;
- if (e->rank == 0 || e->shape != NULL)
+ if (e->rank <= 0 || e->shape != NULL)
return;
for (i = 0; i < e->rank; i++)
@@ -5079,23 +5116,79 @@ resolve_variable (gfc_expr *e)
sym = e->symtree->n.sym;
/* TS 29113, 407b. */
- if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
+ if (e->ts.type == BT_ASSUMED)
{
- gfc_error ("Invalid expression with assumed-type variable %s at %L",
- sym->name, &e->where);
- return FAILURE;
+ if (!actual_arg)
+ {
+ gfc_error ("Assumed-type variable %s at %L may only be used "
+ "as actual argument", sym->name, &e->where);
+ return FAILURE;
+ }
+ else if (inquiry_argument && !first_actual_arg)
+ {
+ /* FIXME: It doesn't work reliably as inquiry_argument is not set
+ for all inquiry functions in resolve_function; the reason is
+ that the function-name resolution happens too late in that
+ function. */
+ gfc_error ("Assumed-type variable %s at %L as actual argument to "
+ "an inquiry function shall be the first argument",
+ sym->name, &e->where);
+ return FAILURE;
+ }
+ }
+
+ /* TS 29113, C535b. */
+ if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || (sym->ts.type != BT_CLASS && sym->as
+ && sym->as->type == AS_ASSUMED_RANK))
+ {
+ if (!actual_arg)
+ {
+ gfc_error ("Assumed-rank variable %s at %L may only be used as "
+ "actual argument", sym->name, &e->where);
+ return FAILURE;
+ }
+ else if (inquiry_argument && !first_actual_arg)
+ {
+ /* FIXME: It doesn't work reliably as inquiry_argument is not set
+ for all inquiry functions in resolve_function; the reason is
+ that the function-name resolution happens too late in that
+ function. */
+ gfc_error ("Assumed-rank variable %s at %L as actual argument "
+ "to an inquiry function shall be the first argument",
+ sym->name, &e->where);
+ return FAILURE;
+ }
}
/* TS 29113, 407b. */
if (e->ts.type == BT_ASSUMED && e->ref
&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
- && e->ref->next == NULL))
+ && e->ref->next == NULL))
+ {
+ gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
+ "reference", sym->name, &e->ref->u.ar.where);
+ return FAILURE;
+ }
+
+ /* TS 29113, C535b. */
+ if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || (sym->ts.type != BT_CLASS && sym->as
+ && sym->as->type == AS_ASSUMED_RANK))
+ && e->ref
+ && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+ && e->ref->next == NULL))
{
- gfc_error ("Assumed-type variable %s with designator at %L",
- sym->name, &e->ref->u.ar.where);
+ gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
+ "reference", sym->name, &e->ref->u.ar.where);
return FAILURE;
}
+
/* If this is an associate-name, it may be parsed with an array reference
in error even though the target is scalar. Fail directly in this case.
TODO Understand why class scalar expressions must be excluded. */
@@ -5596,7 +5689,7 @@ update_ppc_arglist (gfc_expr* e)
return FAILURE;
/* F08:R739. */
- if (po->rank > 0)
+ if (po->rank != 0)
{
gfc_error ("Passed-object at %L must be scalar", &e->where);
return FAILURE;
@@ -5644,7 +5737,7 @@ check_typebound_baseobject (gfc_expr* e)
/* F08:C1230. If the procedure called is NOPASS,
the base object must be scalar. */
- if (e->value.compcall.tbp->nopass && base->rank > 0)
+ if (e->value.compcall.tbp->nopass && base->rank != 0)
{
gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
" be scalar", &e->where);
@@ -6306,15 +6399,22 @@ gfc_try
gfc_resolve_expr (gfc_expr *e)
{
gfc_try t;
- bool inquiry_save;
+ bool inquiry_save, actual_arg_save, first_actual_arg_save;
if (e == NULL)
return SUCCESS;
/* inquiry_argument only applies to variables. */
inquiry_save = inquiry_argument;
+ actual_arg_save = actual_arg;
+ first_actual_arg_save = first_actual_arg;
+
if (e->expr_type != EXPR_VARIABLE)
- inquiry_argument = false;
+ {
+ inquiry_argument = false;
+ actual_arg = false;
+ first_actual_arg = false;
+ }
switch (e->expr_type)
{
@@ -6404,6 +6504,8 @@ gfc_resolve_expr (gfc_expr *e)
fixup_charlen (e);
inquiry_argument = inquiry_save;
+ actual_arg = actual_arg_save;
+ first_actual_arg = first_actual_arg_save;
return t;
}
@@ -10332,10 +10434,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
if (allocatable)
{
- if (dimension)
+ if (dimension && as->type != AS_ASSUMED_RANK)
{
- gfc_error ("Allocatable array '%s' at %L must have "
- "a deferred shape", sym->name, &sym->declared_at);
+ gfc_error ("Allocatable array '%s' at %L must have a deferred "
+ "shape or assumed rank", sym->name, &sym->declared_at);
return FAILURE;
}
else if (gfc_notify_std (GFC_STD_F2003, "Scalar object "
@@ -10344,10 +10446,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
return FAILURE;
}
- if (pointer && dimension)
+ if (pointer && dimension && as->type != AS_ASSUMED_RANK)
{
- gfc_error ("Array pointer '%s' at %L must have a deferred shape",
- sym->name, &sym->declared_at);
+ gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
+ "assumed rank", sym->name, &sym->declared_at);
return FAILURE;
}
}
@@ -10961,7 +11063,7 @@ gfc_resolve_finalizers (gfc_symbol* derived)
}
/* Warn if the procedure is non-scalar and not assumed shape. */
- if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
+ if (gfc_option.warn_surprising && arg->as && arg->as->rank != 0
&& arg->as->type != AS_ASSUMED_SHAPE)
gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
" shape argument", &arg->declared_at);
@@ -11490,7 +11592,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
}
gcc_assert (me_arg->ts.type == BT_CLASS);
- if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
+ if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
{
gfc_error ("Passed-object dummy argument of '%s' at %L must be"
" scalar", proc->name, &where);
@@ -12504,6 +12606,20 @@ resolve_symbol (gfc_symbol *sym)
&sym->declared_at);
return;
}
+ /* TS 29113, C535a. */
+ if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy)
+ {
+ gfc_error ("Assumed-rank array at %L must be a dummy argument",
+ &sym->declared_at);
+ return;
+ }
+ if (as->type == AS_ASSUMED_RANK
+ && (sym->attr.codimension || sym->attr.value))
+ {
+ gfc_error ("Assumed-rank array at %L may not have the VALUE or "
+ "CODIMENSION attribute", &sym->declared_at);
+ return;
+ }
}
/* Make sure symbols with known intent or optional are really dummy
@@ -12576,6 +12692,13 @@ resolve_symbol (gfc_symbol *sym)
sym->name, &sym->declared_at);
return;
}
+ if (sym->attr.intent == INTENT_OUT)
+ {
+ gfc_error ("Assumed-type variable %s at %L may not have the "
+ "INTENT(OUT) attribute",
+ sym->name, &sym->declared_at);
+ return;
+ }
if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
{
gfc_error ("Assumed-type variable %s at %L shall not be an "
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index c7145d6..afc4bc4 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2935,7 +2935,6 @@ gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
}
-
gfc_expr *
gfc_simplify_is_iostat_end (gfc_expr *x)
{
@@ -3381,7 +3380,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
done:
- if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
+ if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
+ || as->type == AS_ASSUMED_RANK))
return NULL;
if (dim == NULL)
@@ -3443,13 +3443,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
d = mpz_get_si (dim->value.integer);
- if (d < 1 || d > array->rank
+ if ((d < 1 || d > array->rank)
|| (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
{
gfc_error ("DIM argument at %L is out of bounds", &dim->where);
return &gfc_bad_expr;
}
+ if (as && as->type == AS_ASSUMED_RANK)
+ return NULL;
+
return simplify_bound_dim (array, kind, d, upper, as, ref, false);
}
}
@@ -4780,6 +4783,10 @@ gfc_simplify_range (gfc_expr *e)
gfc_expr *
gfc_simplify_rank (gfc_expr *e)
{
+ /* Assumed rank. */
+ if (e->rank == -1)
+ return NULL;
+
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
}
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index d289ac3..ba108dc 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -81,7 +81,7 @@ along with GCC; see the file COPYING3. If not see
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "gimple.h"
+#include "gimple.h" /* For create_tmp_var_name. */
#include "diagnostic-core.h" /* For internal_error/fatal_error. */
#include "flags.h"
#include "gfortran.h"
@@ -247,12 +247,11 @@ gfc_conv_descriptor_dtype (tree desc)
desc, field, NULL_TREE);
}
-static tree
-gfc_conv_descriptor_dimension (tree desc, tree dim)
+
+tree
+gfc_get_descriptor_dimension (tree desc)
{
- tree field;
- tree type;
- tree tmp;
+ tree type, field;
type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
@@ -262,10 +261,19 @@ gfc_conv_descriptor_dimension (tree desc, tree dim)
&& TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- desc, field, NULL_TREE);
- tmp = gfc_build_array_ref (tmp, dim, NULL);
- return tmp;
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+}
+
+
+static tree
+gfc_conv_descriptor_dimension (tree desc, tree dim)
+{
+ tree tmp;
+
+ tmp = gfc_get_descriptor_dimension (desc);
+
+ return gfc_build_array_ref (tmp, dim, NULL);
}
@@ -311,6 +319,7 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim)
if (integer_zerop (dim)
&& (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_ASSUMED_RANK_CONT
||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
return gfc_index_one_node;
@@ -6900,9 +6909,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
}
if (!sym->attr.pointer
- && sym->as
- && sym->as->type != AS_ASSUMED_SHAPE
- && !sym->attr.allocatable)
+ && sym->as
+ && sym->as->type != AS_ASSUMED_SHAPE
+ && sym->as->type != AS_ASSUMED_RANK
+ && !sym->attr.allocatable)
{
/* Some variables are declared directly, others are declared as
pointers and allocated on the heap. */
@@ -6938,10 +6948,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
no_pack = ((sym && sym->as
&& !sym->attr.pointer
&& sym->as->type != AS_DEFERRED
+ && sym->as->type != AS_ASSUMED_RANK
&& sym->as->type != AS_ASSUMED_SHAPE)
||
(ref && ref->u.ar.as
&& ref->u.ar.as->type != AS_DEFERRED
+ && ref->u.ar.as->type != AS_ASSUMED_RANK
&& ref->u.ar.as->type != AS_ASSUMED_SHAPE)
||
gfc_is_simply_contiguous (expr, false));
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 9bafb94..b7ab806 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -154,6 +154,7 @@ tree gfc_conv_descriptor_data_get (tree);
tree gfc_conv_descriptor_data_addr (tree);
tree gfc_conv_descriptor_offset_get (tree);
tree gfc_conv_descriptor_dtype (tree);
+tree gfc_get_descriptor_dimension (tree);
tree gfc_conv_descriptor_stride_get (tree, tree);
tree gfc_conv_descriptor_lbound_get (tree, tree);
tree gfc_conv_descriptor_ubound_get (tree, tree);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 75a2160..f1b7444 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -933,7 +933,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
int n;
bool known_size;
- if (sym->attr.pointer || sym->attr.allocatable)
+ if (sym->attr.pointer || sym->attr.allocatable
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
return dummy;
/* Add to list of variables if not a fake result variable. */
@@ -3669,6 +3670,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
break;
+ case AS_ASSUMED_RANK:
case AS_DEFERRED:
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, block);
@@ -4782,7 +4784,8 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
dummy argument is an array. (See "Sequence association" in
Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
if (fsym->attr.pointer || fsym->attr.allocatable
- || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
+ || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK)))
{
comparison = NE_EXPR;
message = _("Actual string length does not match the declared one"
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 17964bb..f5ed4e3 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -42,6 +42,48 @@ along with GCC; see the file COPYING3. If not see
#include "dependency.h"
+/* Convert a scalar to an array descriptor. To be used for assumed-rank
+ arrays. */
+
+static tree
+get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
+{
+ enum gfc_array_kind akind;
+
+ if (attr.pointer)
+ akind = GFC_ARRAY_POINTER_CONT;
+ else if (attr.allocatable)
+ akind = GFC_ARRAY_ALLOCATABLE;
+ else
+ akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
+
+ return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
+ akind, !(attr.pointer || attr.target));
+}
+
+static tree
+conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
+{
+ tree desc, type;
+
+ type = get_scalar_to_descriptor_type (scalar, attr);
+ desc = gfc_create_var (type, "desc");
+ DECL_ARTIFICIAL (desc) = 1;
+ gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype (type));
+ gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
+
+ /* Copy pointer address back - but only if it could have changed and
+ if the actual argument is a pointer and not, e.g., NULL(). */
+ if ((attr.pointer || attr.allocatable)
+ && attr.intent != INTENT_IN && POINTER_TYPE_P (TREE_TYPE (scalar)))
+ gfc_add_modify (&se->post, scalar,
+ fold_convert (TREE_TYPE (scalar),
+ gfc_conv_descriptor_data_get (desc)));
+ return desc;
+}
+
+
/* This is the seed for an eventual trans-class.c
The following parameters should not be used directly since they might
@@ -158,7 +200,34 @@ gfc_get_vptr_from_expr (tree expr)
tmp = gfc_class_vptr_get (tmp);
return tmp;
}
-
+
+
+static void
+class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
+ bool lhs_type)
+{
+ tree tmp, tmp2, type;
+
+ gfc_conv_descriptor_data_set (block, lhs_desc,
+ gfc_conv_descriptor_data_get (rhs_desc));
+ gfc_conv_descriptor_offset_set (block, lhs_desc,
+ gfc_conv_descriptor_offset_get (rhs_desc));
+
+ gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
+ gfc_conv_descriptor_dtype (rhs_desc));
+
+ /* Assign the dimension as range-ref. */
+ tmp = gfc_get_descriptor_dimension (lhs_desc);
+ tmp2 = gfc_get_descriptor_dimension (rhs_desc);
+
+ type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
+ tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
+ gfc_index_zero_node, NULL_TREE, NULL_TREE);
+ tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
+ gfc_index_zero_node, NULL_TREE, NULL_TREE);
+ gfc_add_modify (block, tmp, tmp2);
+}
+
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. If vptr is not NULL, this is
@@ -215,14 +284,33 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
{
parmse->ss = NULL;
gfc_conv_expr_reference (parmse, e);
- tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
- gfc_add_modify (&parmse->pre, ctree, tmp);
+
+ /* Scalar to an assumed-rank array. */
+ if (class_ts.u.derived->components->as)
+ {
+ tree type;
+ type = get_scalar_to_descriptor_type (parmse->expr,
+ gfc_expr_attr (e));
+ gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
+ gfc_get_dtype (type));
+ gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
+ }
+ else
+ {
+ tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
}
else
{
parmse->ss = ss;
gfc_conv_expr_descriptor (parmse, e, ss);
- gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+
+ if (e->rank != class_ts.u.derived->components->as->rank)
+ class_array_data_assign (&parmse->pre, ctree, parmse->expr,
+ TREE_TYPE (parmse->expr));
+ else
+ gfc_add_modify (&parmse->pre, ctree, parmse->expr);
}
}
@@ -260,7 +348,9 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
break;
}
- if (ref == NULL || class_ref == ref)
+ if ((ref == NULL || class_ref == ref)
+ && (!class_ts.u.derived->components->as
+ || class_ts.u.derived->components->as->rank != -1))
return;
/* Test for FULL_ARRAY. */
@@ -273,13 +363,42 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
/* Set the data. */
ctree = gfc_class_data_get (var);
- gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+ if (class_ts.u.derived->components->as
+ && e->rank != class_ts.u.derived->components->as->rank)
+ {
+ if (e->rank == 0)
+ {
+ tree type = get_scalar_to_descriptor_type (parmse->expr,
+ gfc_expr_attr (e));
+ gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
+ gfc_get_dtype (type));
+ gfc_conv_descriptor_data_set (&parmse->pre, ctree,
+ gfc_class_data_get (parmse->expr));
+
+ }
+ else
+ class_array_data_assign (&parmse->pre, ctree, parmse->expr, false);
+ }
+ else
+ gfc_add_modify (&parmse->pre, ctree, parmse->expr);
/* Return the data component, except in the case of scalarized array
references, where nullification of the cannot occur and so there
is no need. */
if (!elemental && full_array)
- gfc_add_modify (&parmse->post, parmse->expr, ctree);
+ {
+ if (class_ts.u.derived->components->as
+ && e->rank != class_ts.u.derived->components->as->rank)
+ {
+ if (e->rank == 0)
+ gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
+ gfc_conv_descriptor_data_get (ctree));
+ else
+ class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
+ }
+ else
+ gfc_add_modify (&parmse->post, parmse->expr, ctree);
+ }
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
@@ -730,7 +849,8 @@ gfc_conv_expr_present (gfc_symbol * sym)
as actual argument to denote absent dummies. For array descriptors,
we thus also need to check the array descriptor. */
if (!sym->attr.pointer && !sym->attr.allocatable
- && sym->as && sym->as->type == AS_ASSUMED_SHAPE
+ && sym->as && (sym->as->type == AS_ASSUMED_SHAPE
+ || sym->as->type == AS_ASSUMED_RANK)
&& (gfc_option.allow_std & GFC_STD_F2008) != 0)
{
tree tmp;
@@ -1325,7 +1445,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
/* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
if ((sym->attr.pointer || sym->attr.allocatable
- || gfc_is_associate_pointer (sym))
+ || gfc_is_associate_pointer (sym)
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result
@@ -3769,7 +3890,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
class object, if the formal argument is a class object. */
if (fsym && fsym->ts.type == BT_CLASS
&& e->ts.type == BT_CLASS
- && CLASS_DATA (e)->attr.dimension)
+ && ((CLASS_DATA (fsym)->as
+ && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+ || CLASS_DATA (e)->attr.dimension))
gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
if (fsym && (fsym->ts.type == BT_DERIVED
@@ -3813,7 +3936,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_add_expr_to_block (&se->pre, tmp);
}
- if (fsym && e->expr_type != EXPR_NULL
+ /* Wrap scalar variable in a descriptor. We need to convert
+ the address of a pointer back to the pointer itself before,
+ we can assign it to the data field. */
+
+ if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
+ && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
+ {
+ tmp = parmse.expr;
+ if (TREE_CODE (tmp) == ADDR_EXPR
+ && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
+ tmp = TREE_OPERAND (tmp, 0);
+ parmse.expr = conv_scalar_to_descriptor (&parmse, tmp,
+ fsym->attr);
+ parmse.expr = gfc_build_addr_expr (NULL_TREE,
+ parmse.expr);
+ }
+ else if (fsym && e->expr_type != EXPR_NULL
&& ((fsym->attr.pointer
&& fsym->attr.flavor != FL_PROCEDURE)
|| (fsym->attr.proc_pointer
@@ -3855,7 +3994,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
bool f;
f = (fsym != NULL)
&& !(fsym->attr.pointer || fsym->attr.allocatable)
- && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
+ && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE
+ && fsym->as->type != AS_ASSUMED_RANK;
if (comp)
f = f || !comp->attr.always_explicit;
else
@@ -3964,12 +4104,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
but do not always set fsym. */
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional
- && ((e->rank > 0 && sym->attr.elemental)
+ && ((e->rank != 0 && sym->attr.elemental)
|| e->representation.length || e->ts.type == BT_CHARACTER
- || (e->rank > 0
+ || (e->rank != 0
&& (fsym == NULL
|| (fsym-> as
&& (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK
|| fsym->as->type == AS_DEFERRED))))))
gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
e->representation.length);
@@ -4215,7 +4356,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp = caf_decl;
}
- if (fsym->as->type == AS_ASSUMED_SHAPE)
+ if (fsym->as->type == AS_ASSUMED_SHAPE
+ || (fsym->as->type == AS_ASSUMED_RANK && !fsym->attr.pointer
+ && !fsym->attr.allocatable))
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index e4905ff..be94219 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1315,29 +1315,37 @@ trans_num_images (gfc_se * se)
}
+static tree
+get_rank_from_desc (tree desc)
+{
+ tree tmp;
+ tree dtype;
+
+ dtype = gfc_conv_descriptor_dtype (desc);
+ tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
+ tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
+ dtype, tmp);
+ return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+}
+
+
static void
gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
{
gfc_se argse;
gfc_ss *ss;
- tree dtype, tmp;
ss = gfc_walk_expr (expr->value.function.actual->expr);
gcc_assert (ss != gfc_ss_terminator);
gfc_init_se (&argse, NULL);
argse.data_not_needed = 1;
- argse.want_pointer = 1;
+ argse.descriptor_only = 1;
gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr);
- argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr);
- dtype = gfc_conv_descriptor_dtype (argse.expr);
- tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
- tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
- dtype, tmp);
- se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+
+ se->expr = get_rank_from_desc (argse.expr);
}
@@ -5855,8 +5863,15 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
present. */
arg1se.descriptor_only = 1;
gfc_conv_expr_lhs (&arg1se, arg1->expr);
- tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
- gfc_rank_cst[arg1->expr->rank - 1]);
+ if (arg1->expr->rank == -1)
+ {
+ tmp = get_rank_from_desc (arg1se.expr);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE (tmp), tmp, gfc_index_one_node);
+ }
+ else
+ tmp = gfc_rank_cst[arg1->expr->rank - 1];
+ tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index aa50e3d..d96f5e6 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -80,8 +80,8 @@ bool gfc_real16_is_float128 = false;
static GTY(()) tree gfc_desc_dim_type;
static GTY(()) tree gfc_max_array_element_size;
-static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS];
-static GTY(()) tree gfc_array_descriptor_base_caf[2 * GFC_MAX_DIMENSIONS];
+static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
+static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
/* Arrays for all integral and real kinds. We'll fill this in at runtime
after the target has a chance to process command-line options. */
@@ -1277,7 +1277,8 @@ gfc_is_nodesc_array (gfc_symbol * sym)
return 0;
if (sym->attr.dummy)
- return sym->as->type != AS_ASSUMED_SHAPE;
+ return sym->as->type != AS_ASSUMED_SHAPE
+ && sym->as->type != AS_ASSUMED_RANK;
if (sym->attr.result || sym->attr.function)
return 0;
@@ -1299,6 +1300,13 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
tree ubound[GFC_MAX_DIMENSIONS];
int n;
+ if (as->type == AS_ASSUMED_RANK)
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ {
+ lbound[n] = NULL_TREE;
+ ubound[n] = NULL_TREE;
+ }
+
for (n = 0; n < as->rank; n++)
{
/* Create expressions for the known bounds of the array. */
@@ -1323,7 +1331,12 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
if (as->type == AS_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,
+ else if (as->type == AS_ASSUMED_RANK)
+ akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
+ : GFC_ARRAY_ASSUMED_RANK;
+ return gfc_get_array_type_bounds (type, as->rank == -1
+ ? GFC_MAX_DIMENSIONS : as->rank,
+ as->corank, lbound,
ubound, 0, akind, restricted);
}
\f
@@ -1682,9 +1695,15 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
{
tree fat_type, decl, arraytype, *chain = NULL;
char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
- int idx = 2 * (codimen + dimen - 1) + restricted;
+ int idx;
+
+ /* Assumed-rank array. */
+ if (dimen == -1)
+ dimen = GFC_MAX_DIMENSIONS;
+
+ idx = 2 * (codimen + dimen) + restricted;
- gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
+ gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS);
if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)
{
@@ -1721,16 +1740,18 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
TREE_NO_WARNING (decl) = 1;
/* Build the array type for the stride and bound components. */
- arraytype =
- build_array_type (gfc_get_desc_dim_type (),
- build_range_type (gfc_array_index_type,
- gfc_index_zero_node,
- gfc_rank_cst[codimen + dimen - 1]));
+ if (dimen + codimen > 0)
+ {
+ arraytype =
+ build_array_type (gfc_get_desc_dim_type (),
+ build_range_type (gfc_array_index_type,
+ gfc_index_zero_node,
+ gfc_rank_cst[codimen + dimen - 1]));
- decl = gfc_add_field_to_struct_1 (fat_type,
- get_identifier ("dim"),
- arraytype, &chain);
- TREE_NO_WARNING (decl) = 1;
+ decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"),
+ arraytype, &chain);
+ TREE_NO_WARNING (decl) = 1;
+ }
if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen
&& akind == GFC_ARRAY_ALLOCATABLE)
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 3b77281..d4092f7 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -765,6 +765,8 @@ enum gfc_array_kind
GFC_ARRAY_UNKNOWN,
GFC_ARRAY_ASSUMED_SHAPE,
GFC_ARRAY_ASSUMED_SHAPE_CONT,
+ GFC_ARRAY_ASSUMED_RANK,
+ GFC_ARRAY_ASSUMED_RANK_CONT,
GFC_ARRAY_ALLOCATABLE,
GFC_ARRAY_POINTER,
GFC_ARRAY_POINTER_CONT
diff --git a/gcc/testsuite/gfortran.dg/assumed_type_3.f90 b/gcc/testsuite/gfortran.dg/assumed_type_3.f90
index d88da34..8d2be25 100644
--- a/gcc/testsuite/gfortran.dg/assumed_type_3.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_type_3.f90
@@ -31,7 +31,7 @@ end subroutine six
subroutine seven(y)
type(*) :: y(:)
- call a7(y(3:5)) ! { dg-error "Assumed-type variable y with designator" }
+ call a7(y(3:5)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" }
contains
subroutine a7(x)
type(*) :: x(*)
@@ -115,5 +115,5 @@ end subroutine thirteen
subroutine fourteen(x)
type(*) :: x
- x = x ! { dg-error "Invalid expression with assumed-type variable" }
+ x = x ! { dg-error "Assumed-type variable x at .1. may only be used as actual argument" }
end subroutine fourteen
--- /dev/null 2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_1.f90 2012-07-13 16:36:03.000000000 +0200
@@ -0,0 +1,147 @@
+! { dg-do run }
+! { dg-additional-sources assumed_rank_1_c.c }
+!
+! PR fortran/48820
+!
+! Assumed-rank tests
+!
+! FIXME: The ubound/lbound checks have to be re-enabled when
+! after they are supported
+
+implicit none
+
+interface
+ subroutine check_value(b, n, val)
+ integer :: b(..)
+ integer, value :: n
+ integer :: val(n)
+ end subroutine
+end interface
+
+integer, target :: x(2:5,4:7), y(-4:4)
+integer, allocatable, target :: z(:,:,:,:)
+integer, allocatable :: val(:)
+integer :: i
+
+allocate(z(1:4, -2:5, 4, 10:11))
+
+if (rank(x) /= 2) call abort ()
+val = [(2*i+3, i = 1, size(x))]
+x = reshape (val, shape(x))
+call foo(x, rank(x), lbound(x), ubound(x), val)
+call foo2(x, rank(x), lbound(x), ubound(x), val)
+call bar(x,x,.true.)
+call bar(x,prsnt=.false.)
+
+if (rank(y) /= 1) call abort ()
+val = [(2*i+7, i = 1, size(y))]
+y = reshape (val, shape(y))
+call foo(y, rank(y), lbound(y), ubound(y), val)
+call foo2(y, rank(y), lbound(y), ubound(y), val)
+call bar(y,y,.true.)
+call bar(y,prsnt=.false.)
+
+if (rank(z) /= 4) call abort ()
+val = [(2*i+5, i = 1, size(z))]
+z(:,:,:,:) = reshape (val, shape(z))
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo2(z, rank(z), lbound(z), ubound(z), val)
+call bar(z,z,.true.)
+call bar(z,prsnt=.false.)
+
+contains
+ subroutine bar(a,b, prsnt)
+ integer, pointer, optional, intent(in) :: a(..),b(..)
+ logical, value :: prsnt
+ ! The following is not valid, but it goes past the constraint check
+ ! Technically, it could be allowed and might be in Fortran 2015:
+ if (.not. associated(a)) call abort()
+ if (present(b)) then
+ if (.not. associated(a,b)) call abort()
+ else
+ if (.not. associated(a)) call abort()
+ end if
+ if (.not. present(a)) call abort()
+ if (prsnt .neqv. present(b)) call abort()
+ end subroutine
+
+ ! POINTER argument - bounds as specified before
+ subroutine foo(a, rnk, low, high, val)
+ integer,pointer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+ if (low(1) /= lbound(a,1)) call abort()
+ if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+ if (low(i) /= lbound(a,i)) call abort()
+ if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call check_value (a, rnk, val)
+ call foo2(a, rnk, low, high, val)
+ end subroutine
+
+ ! Non-pointer, non-allocatable bounds. lbound == 1
+ subroutine foo2(a, rnk, low, high, val)
+ integer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+! if (1 /= lbound(a,1)) call abort()
+! if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+! if (1 /= lbound(a,i)) call abort()
+! if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call check_value (a, rnk, val)
+ end subroutine foo2
+
+ ! ALLOCATABLE argument - bounds as specified before
+ subroutine foo3 (a, rnk, low, high, val)
+ integer, allocatable, intent(in), target :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+! if (low(1) /= lbound(a,1)) call abort()
+! if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+! if (low(i) /= lbound(a,i)) call abort()
+! if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call check_value (a, rnk, val)
+ call foo(a, rnk, low, high, val)
+ end subroutine
+end
--- /dev/null 2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_1_c.c 2012-06-24 12:58:44.000000000 +0200
@@ -0,0 +1,16 @@
+/* Called by assumed_rank_1.f90. */
+
+#include <stdlib.h> /* For abort(). */
+
+struct array {
+ int *data;
+};
+
+void check_value_ (struct array *b, int n, int val[])
+{
+ int i;
+
+ for (i = 0; i < n; i++)
+ if (b->data[i] != val[i])
+ abort ();
+}
--- /dev/null 2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_2.f90 2012-07-13 16:37:19.000000000 +0200
@@ -0,0 +1,137 @@
+! { dg-do run }
+! { dg-options "-fcheck=all" }
+!
+! PR fortran/48820
+!
+! Assumed-rank tests - same as assumed_rank_1.f90,
+! but with bounds checks and w/o call to C function
+!
+! FIXME: The ubound/lbound checks have to be re-enabled when
+! after they are supported
+
+implicit none
+
+integer, target :: x(2:5,4:7), y(-4:4)
+integer, allocatable, target :: z(:,:,:,:)
+integer, allocatable :: val(:)
+integer :: i
+
+allocate(z(1:4, -2:5, 4, 10:11))
+
+if (rank(x) /= 2) call abort ()
+val = [(2*i+3, i = 1, size(x))]
+x = reshape (val, shape(x))
+call foo(x, rank(x), lbound(x), ubound(x), val)
+call foo2(x, rank(x), lbound(x), ubound(x), val)
+call bar(x,x,.true.)
+call bar(x,prsnt=.false.)
+
+if (rank(y) /= 1) call abort ()
+val = [(2*i+7, i = 1, size(y))]
+y = reshape (val, shape(y))
+call foo(y, rank(y), lbound(y), ubound(y), val)
+call foo2(y, rank(y), lbound(y), ubound(y), val)
+call bar(y,y,.true.)
+call bar(y,prsnt=.false.)
+
+if (rank(z) /= 4) call abort ()
+val = [(2*i+5, i = 1, size(z))]
+z(:,:,:,:) = reshape (val, shape(z))
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo2(z, rank(z), lbound(z), ubound(z), val)
+call bar(z,z,.true.)
+call bar(z,prsnt=.false.)
+
+contains
+ subroutine bar(a,b, prsnt)
+ integer, pointer, optional, intent(in) :: a(..),b(..)
+ logical, value :: prsnt
+ ! The following is not valid, but it goes past the constraint check
+ ! Technically, it could be allowed and might be in Fortran 2015:
+ if (.not. associated(a)) call abort()
+ if (present(b)) then
+ if (.not. associated(a,b)) call abort()
+ else
+ if (.not. associated(a)) call abort()
+ end if
+ if (.not. present(a)) call abort()
+ if (prsnt .neqv. present(b)) call abort()
+ end subroutine
+
+ ! POINTER argument - bounds as specified before
+ subroutine foo(a, rnk, low, high, val)
+ integer,pointer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+! if (low(1) /= lbound(a,1)) call abort()
+! if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+! if (low(i) /= lbound(a,i)) call abort()
+! if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call foo2(a, rnk, low, high, val)
+ end subroutine
+
+ ! Non-pointer, non-allocatable bounds. lbound == 1
+ subroutine foo2(a, rnk, low, high, val)
+ integer, intent(in) :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+! if (1 /= lbound(a,1)) call abort()
+! if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+! if (1 /= lbound(a,i)) call abort()
+! if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ end subroutine foo2
+
+ ! ALLOCATABLE argument - bounds as specified before
+ subroutine foo3 (a, rnk, low, high, val)
+ integer, allocatable, intent(in), target :: a(..)
+ integer, value :: rnk
+ integer, intent(in) :: low(:), high(:), val(:)
+ integer :: i
+
+ if (rank(a) /= rnk) call abort()
+ if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+ if (size(a) /= product (high - low +1)) call abort()
+
+ if (rnk > 0) then
+! if (low(1) /= lbound(a,1)) call abort()
+! if (high(1) /= ubound(a,1)) call abort()
+ if (size (a,1) /= high(1)-low(1)+1) call abort()
+ end if
+
+ do i = 1, rnk
+! if (low(i) /= lbound(a,i)) call abort()
+! if (high(i) /= ubound(a,i)) call abort()
+ if (size (a,i) /= high(i)-low(i)+1) call abort()
+ end do
+ call foo(a, rnk, low, high, val)
+ end subroutine
+end
--- /dev/null 2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_4.f90 2012-07-15 19:30:19.000000000 +0200
@@ -0,0 +1,50 @@
+! { dg-do compile }
+! { dg-options "-std=f2008ts" }
+!
+! PR fortran/48820
+!
+! Assumed-rank constraint checks and other diagnostics
+!
+
+subroutine valid1a(x)
+ integer, intent(in), pointer, contiguous :: x(..)
+end subroutine valid1a
+
+subroutine valid1(x)
+ integer, intent(in) :: x(..)
+end subroutine valid1
+
+subroutine valid2(x)
+ type(*) :: x
+end subroutine valid2
+
+subroutine foo99(x)
+ integer x(99)
+ call valid1(x) ! { dg-error "Procedure 'valid1' at .1. with assumed-rank dummy argument 'x' must have an explicit interface" }
+ call valid2(x(1)) ! { dg-error "Procedure 'valid2' at .1. with assumed-type dummy argument 'x' must have an explicit interface" }
+end subroutine foo99
+
+subroutine foo(x)
+ integer :: x(..)
+ print *, ubound(x,dim=2000) ! { dg-error "is not a valid dimension index" }
+ call bar(x) ! { dg-error "Assumed-rank argument requires an explicit interface" }
+ call intnl(x) ! { dg-error "requires that the dummy argument 'x' has assumed-rank" }
+contains
+ subroutine intnl(x)
+ integer :: x(:)
+ end subroutine intnl
+end subroutine foo
+
+subroutine foo2(x)
+ integer :: x(..)
+ call valid3(x(:)) ! { dg-error "Assumed-rank variable x at .1. shall not have a subobject reference" }
+ call valid3(x+1) ! { dg-error "Assumed-rank variable x at .1. may only be used as actual argument" }
+contains
+ subroutine valid3(y)
+ integer :: y(..)
+ end subroutine
+end subroutine
+
+subroutine foo3()
+ integer :: x(..) ! { dg-error "Assumed-rank array at .1. must be a dummy argument" }
+end subroutine
--- /dev/null 2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_5.f90 2012-06-24 15:17:51.000000000 +0200
@@ -0,0 +1,9 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/48820
+!
+!
+subroutine foo(x)
+ integer :: x(..) ! { dg-error "TS 29113: Assumed-rank array" }
+end subroutine foo
--- /dev/null 2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_6.f90 2012-07-15 19:29:22.000000000 +0200
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/48820
+!
+! Assumed-rank constraint checks and other diagnostics
+!
+
+subroutine foo(x) ! { dg-error "Assumed-type variable x at .1. may not have the INTENT.OUT. attribute" }
+ type(*), intent(out) :: x
+end subroutine
+
+subroutine bar(x)
+ integer, intent(out) :: x(..)
+end subroutine bar
+
+subroutine foo3(y)
+ integer :: y(..)
+ y = 7 ! { dg-error "Assumed-rank variable y at .1. may only be used as actual argument" }
+ print *, y + 10 ! { dg-error "Assumed-rank variable y at .1. may only be used as actual argument" }
+ print *, y ! { dg-error "Assumed-rank variable y at .1. may only be used as actual argument" }
+end subroutine
+
+subroutine foo2(x, y)
+ integer :: x(..), y(..)
+ call valid3(x(:)) ! { dg-error "Assumed-rank variable x at .1. shall not have a subobject reference" }
+contains
+ subroutine valid3(y)
+ integer :: y(..)
+ end subroutine
+end subroutine
+
+subroutine foo4(x) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
+ integer, codimension[*] :: x(..)
+end subroutine
+
+subroutine foo5(y) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
+ integer :: y(..)[*]
+end subroutine
--- /dev/null 2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_7.f90 2012-07-13 16:38:43.000000000 +0200
@@ -0,0 +1,66 @@
+! { dg-do run }
+!
+! PR fortran/48820
+!
+! Handle type/class for assumed-rank arrays
+!
+! FIXME: The ubound/lbound checks have to be re-enabled when
+! after they are supported.
+! FIXME: Passing a CLASS to a CLASS has to be re-enabled.
+implicit none
+type t
+ integer :: i
+end type
+
+class(T), allocatable :: ac(:,:)
+type(T), allocatable :: at(:,:)
+integer :: i
+
+allocate(ac(2:3,2:4))
+allocate(at(2:3,2:4))
+
+i = 0
+call foo(ac)
+call foo(at)
+call bar(ac)
+call bar(at)
+if (i /= 12) call abort()
+
+contains
+ subroutine bar(x)
+ type(t) :: x(..)
+! if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+ if (size(x) /= 6) call abort()
+ if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+! if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+ i = i + 1
+ call foo(x)
+ call bar2(x)
+ end subroutine
+ subroutine bar2(x)
+ type(t) :: x(..)
+! if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+ if (size(x) /= 6) call abort()
+ if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+! if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+ i = i + 1
+ end subroutine
+ subroutine foo(x)
+ class(t) :: x(..)
+! if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+ if (size(x) /= 6) call abort()
+ if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+! if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+ i = i + 1
+ call foo2(x)
+! call bar2(x) ! Passing a CLASS to a TYPE does not yet work
+ end subroutine
+ subroutine foo2(x)
+ class(t) :: x(..)
+! if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort()
+ if (size(x) /= 6) call abort()
+ if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+! if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort()
+ i = i + 1
+ end subroutine
+end
--- /dev/null 2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_8.f90 2012-07-15 19:35:32.000000000 +0200
@@ -0,0 +1,71 @@
+! { dg-do run }
+! { dg-additional-sources assumed_rank_8_c.c }
+!
+! PR fortran/48820
+!
+! Scalars to assumed-rank tests
+!
+program main
+ implicit none
+
+ interface
+ subroutine check (x)
+ integer :: x(..)
+ end subroutine check
+ end interface
+
+ integer, target :: ii, j
+ integer, allocatable :: kk
+ integer, pointer :: ll
+ ii = 489
+ j = 0
+ call f (ii)
+ call f (489)
+ call f ()
+ call f (null())
+ call f (kk)
+ if (j /= 2) call abort()
+
+ j = 0
+ nullify (ll)
+ call g (null())
+ call g (ll)
+ call g (ii)
+ if (j /= 1) call abort()
+
+ j = 0
+ call h (kk)
+ kk = 489
+ call h (kk)
+ if (j /= 1) call abort()
+
+contains
+
+ subroutine f (x)
+ integer, optional :: x(..)
+
+ if (.not. present (x)) return
+ if (rank (x) /= 0) call abort
+ call check (x)
+ j = j + 1
+ end subroutine
+
+ subroutine g (x)
+ integer, pointer, intent(in) :: x(..)
+
+ if (.not. associated (x)) return
+ if (rank (x) /= 0) call abort ()
+ call check (x)
+ j = j + 1
+ end subroutine
+
+ subroutine h (x)
+ integer, allocatable :: x(..)
+
+ if (.not. allocated (x)) return
+ if (rank (x) /= 0) call abort
+ call check (x)
+ j = j + 1
+ end subroutine
+
+end program main
--- /dev/null 2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_8_c.c 2012-07-15 19:34:46.000000000 +0200
@@ -0,0 +1,25 @@
+/* Called by assumed_rank_8.f90 and assumed_rank_9.f90. */
+
+#include <stdlib.h> /* For abort(). */
+
+struct a {
+ int *dat;
+};
+
+struct b {
+ struct a _data;
+};
+
+
+void check_ (struct a *x)
+{
+ if (*x->dat != 489)
+ abort ();
+}
+
+
+void check2_ (struct b *x)
+{
+ if (*x->_data.dat != 489)
+ abort ();
+}
--- /dev/null 2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_9.f90 2012-07-15 19:35:37.000000000 +0200
@@ -0,0 +1,139 @@
+! { dg-do run }
+! { dg-additional-sources assumed_rank_8_c.c }
+!
+! PR fortran/48820
+!
+! Scalars to assumed-rank tests
+!
+program main
+ implicit none
+
+ type t
+ integer :: i
+ end type t
+
+ interface
+ subroutine check (x)
+ integer :: x(..)
+ end subroutine check
+ subroutine check2 (x)
+ import t
+ class(t) :: x(..)
+ end subroutine check2
+ end interface
+
+ integer :: j
+
+ type(t), target :: y
+ class(t), allocatable, target :: yac
+
+ y%i = 489
+ allocate (yac)
+ yac%i = 489
+ j = 0
+ call fc()
+ call fc(null())
+ call fc(y)
+ call fc(yac)
+ if (j /= 2) call abort ()
+
+ j = 0
+ call gc(null())
+ call gc(y)
+ call gc(yac)
+ deallocate (yac)
+ call gc(yac)
+ if (j /= 2) call abort ()
+
+ j = 0
+ call hc(yac)
+ allocate (yac)
+ yac%i = 489
+ call hc(yac)
+ if (j /= 1) call abort ()
+
+ j = 0
+ call ft()
+ call ft(null())
+ call ft(y)
+ call ft(yac)
+ if (j /= 2) call abort ()
+
+ j = 0
+ call gt(null())
+ call gt(y)
+ call gt(yac)
+ deallocate (yac)
+ call gt(yac)
+ if (j /= 2) call abort ()
+
+ j = 0
+ call ht(yac)
+ allocate (yac)
+ yac%i = 489
+ call ht(yac)
+ if (j /= 1) call abort ()
+
+contains
+
+ subroutine fc (x)
+ class(t), optional :: x(..)
+
+ if (.not. present (x)) return
+ if (.not. SAME_TYPE_AS (x, yac)) call abort ()
+ if (rank (x) /= 0) call abort
+ call check2 (x)
+ j = j + 1
+ end subroutine
+
+ subroutine gc (x)
+ class(t), pointer, intent(in) :: x(..)
+
+ if (.not. associated (x)) return
+ if (.not. SAME_TYPE_AS (x, yac)) call abort ()
+ if (rank (x) /= 0) call abort ()
+ call check2 (x)
+ j = j + 1
+ end subroutine
+
+ subroutine hc (x)
+ class(t), allocatable :: x(..)
+
+ if (.not. allocated (x)) return
+ if (.not. SAME_TYPE_AS (x, yac)) call abort ()
+ if (rank (x) /= 0) call abort
+ call check2 (x)
+ j = j + 1
+ end subroutine
+
+ subroutine ft (x)
+ type(t), optional :: x(..)
+
+ if (.not. present (x)) return
+ if (.not. SAME_TYPE_AS (x, yac)) call abort ()
+ if (rank (x) /= 0) call abort
+ call check2 (x)
+ j = j + 1
+ end subroutine
+
+ subroutine gt (x)
+ type(t), pointer, intent(in) :: x(..)
+
+ if (.not. associated (x)) return
+ if (.not. SAME_TYPE_AS (x, yac)) call abort ()
+ if (rank (x) /= 0) call abort ()
+ call check2 (x)
+ j = j + 1
+ end subroutine
+
+ subroutine ht (x)
+ type(t), allocatable :: x(..)
+
+ if (.not. allocated (x)) return
+ if (.not. SAME_TYPE_AS (x, yac)) call abort ()
+ if (rank (x) /= 0) call abort
+ call check2 (x)
+ j = j + 1
+ end subroutine
+
+end program main
--- /dev/null 2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 2012-07-15 20:34:21.000000000 +0200
@@ -0,0 +1,106 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/48820
+!
+! Ensure that the value of scalars to assumed-rank arrays is
+! copied back, if and only its pointer address could have changed.
+!
+program test
+ implicit none
+ type t
+ integer :: aa
+ end type t
+
+ integer, allocatable :: iia
+ integer, pointer :: iip
+
+ type(t), allocatable :: jja
+ type(t), pointer :: jjp
+
+ logical :: is_present
+
+ is_present = .true.
+
+ allocate (iip, jjp)
+
+ iia = 7
+ iip = 7
+ jja = t(88)
+ jjp = t(88)
+
+ call faa(iia, jja) ! Copy back
+ if (iia /= 7 .and. jja%aa /= 88) call abort ()
+ call fai(iia, jja) ! No copy back
+ if (iia /= 7 .and. jja%aa /= 88) call abort ()
+
+ call fpa(iip, jjp) ! Copy back
+ if (iip /= 7 .and. jjp%aa /= 88) call abort ()
+ call fpi(iip, jjp) ! No copy back
+ if (iip /= 7 .and. jjp%aa /= 88) call abort ()
+
+ call fnn(iia, jja) ! No copy back
+ if (iia /= 7 .and. jja%aa /= 88) call abort ()
+ call fno(iia, jja) ! No copy back
+ if (iia /= 7 .and. jja%aa /= 88) call abort ()
+ call fnn(iip, jjp) ! No copy back
+ if (iip /= 7 .and. jjp%aa /= 88) call abort ()
+ call fno(iip, jjp) ! No copy back
+ if (iip /= 7 .and. jjp%aa /= 88) call abort ()
+
+ is_present = .false.
+
+ call fpa(null(), null()) ! No copy back
+ call fpi(null(), null()) ! No copy back
+ call fno(null(), null()) ! No copy back
+
+ call fno() ! No copy back
+
+contains
+
+ subroutine faa (xx1, yy1)
+ integer, allocatable :: xx1(..)
+ type(t), allocatable :: yy1(..)
+ if (.not. allocated (xx1)) call abort ()
+ if (.not. allocated (yy1)) call abort ()
+ end subroutine faa
+ subroutine fai (xx1, yy1)
+ integer, allocatable, intent(in) :: xx1(..)
+ type(t), allocatable, intent(in) :: yy1(..)
+ if (.not. allocated (xx1)) call abort ()
+ if (.not. allocated (yy1)) call abort ()
+ end subroutine fai
+ subroutine fpa (xx1, yy1)
+ integer, pointer :: xx1(..)
+ type(t), pointer :: yy1(..)
+ if (is_present .neqv. associated (xx1)) call abort ()
+ if (is_present .neqv. associated (yy1)) call abort ()
+ end subroutine fpa
+
+ subroutine fpi (xx1, yy1)
+ integer, pointer, intent(in) :: xx1(..)
+ type(t), pointer, intent(in) :: yy1(..)
+ if (is_present .neqv. associated (xx1)) call abort ()
+ if (is_present .neqv. associated (yy1)) call abort ()
+ end subroutine fpi
+
+ subroutine fnn(xx2,yy2)
+ integer :: xx2(..)
+ type(t) :: yy2(..)
+ end subroutine fnn
+
+ subroutine fno(xx2,yy2)
+ integer, optional :: xx2(..)
+ type(t), optional :: yy2(..)
+ if (is_present .neqv. present (xx2)) call abort ()
+ if (is_present .neqv. present (yy2)) call abort ()
+ end subroutine fno
+end program test
+
+! We should have exactly one copy back per variable
+!
+! { dg-final { scan-tree-dump-times "iip = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "iia = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "jjp = .struct t .. desc.\[0-9\]+.data;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "jja = .struct t .. desc.\[0-9\]+.data;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null 2012-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 2012-07-19 23:58:55.000000000 +0200
@@ -0,0 +1,21 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/48820
+!
+! Ensure that the value of scalars to assumed-rank arrays is
+! copied back - and everything happens in the correct order.
+
+call sub(f())
+contains
+subroutine sub(x)
+ integer, pointer :: x(..)
+end subroutine sub
+function f() result(res)
+ integer, pointer :: res
+end function f
+end
+
+! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;" "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
+
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
[not found] ` <0EFAB2BDD0F67E4FB6CCC8B9F87D756915E859A4@IRSMSX101.ger.corp.intel.com>
@ 2012-07-20 7:43 ` Igor Zamyatin
2012-07-20 7:51 ` Igor Zamyatin
2012-07-20 20:08 ` Tobias Burnus
0 siblings, 2 replies; 18+ messages in thread
From: Igor Zamyatin @ 2012-07-20 7:43 UTC (permalink / raw)
To: gcc-patches; +Cc: burnus
>
> Tobias Burnus wrote:
>> I will now regtest everything, read through the whole patch - your
>> part and mine, update the ChangeLog and commit it tomorrow.
>
> I have now committed the attached version as Rev. 189700!
>
> Thanks agai for the review!
>
> Tobias
>
This seems to cause following fails at least on i686:
FAIL: gfortran.dg/assumed_rank_12.f90 -O0 scan-tree-dump original "
= f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
\\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
FAIL: gfortran.dg/assumed_rank_12.f90 -O1 scan-tree-dump original "
= f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
\\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
FAIL: gfortran.dg/assumed_rank_12.f90 -O2 scan-tree-dump original "
= f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
\\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
FAIL: gfortran.dg/assumed_rank_12.f90 -O3 -fomit-frame-pointer
scan-tree-dump original " = f \\(\\);.*desc.0.dtype =
600;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*=
.integer.kind=4. .. desc.0.data;"
FAIL: gfortran.dg/assumed_rank_12.f90 -O3 -fomit-frame-pointer
-funroll-all-loops -finline-functions scan-tree-dump original " = f
\\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
\\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
FAIL: gfortran.dg/assumed_rank_12.f90 -O3 -fomit-frame-pointer
-funroll-loops scan-tree-dump original " = f \\(\\);.*desc.0.dtype =
600;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*=
.integer.kind=4. .. desc.0.data;"
FAIL: gfortran.dg/assumed_rank_12.f90 -O3 -g scan-tree-dump
original " = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void ..
D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
FAIL: gfortran.dg/assumed_rank_12.f90 -Os scan-tree-dump original "
= f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
\\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 19)
FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 20)
FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 21)
FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 26)
FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 33)
FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 37)
FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 9)
FAIL: gfortran.dg/assumed_rank_6.f90 -O (internal compiler error)
FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for excess errors)
FAIL: gfortran.dg/lto/pr45586-2
f_lto_pr45586-2_0.o-f_lto_pr45586-2_0.o link, -O0 -flto
-fuse-linker-plugin -fno-fat-lto-objects (internal compiler error)
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-20 7:43 ` Igor Zamyatin
@ 2012-07-20 7:51 ` Igor Zamyatin
2012-07-20 20:08 ` Tobias Burnus
1 sibling, 0 replies; 18+ messages in thread
From: Igor Zamyatin @ 2012-07-20 7:51 UTC (permalink / raw)
To: gcc-patches; +Cc: burnus
On x86_64 the same happens. Also I modified list of failing tests -
now it is correct
On Fri, Jul 20, 2012 at 11:43 AM, Igor Zamyatin <izamyatin@gmail.com> wrote:
>>
>> Tobias Burnus wrote:
>>> I will now regtest everything, read through the whole patch - your
>>> part and mine, update the ChangeLog and commit it tomorrow.
>>
>> I have now committed the attached version as Rev. 189700!
>>
>> Thanks agai for the review!
>>
>> Tobias
>>
>
> This seems to cause following fails at least on i686:
>
> FAIL: gfortran.dg/assumed_rank_12.f90 -O0 scan-tree-dump original "
> = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
> \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -O1 scan-tree-dump original "
> = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
> \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -O2 scan-tree-dump original "
> = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
> \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -O3 -fomit-frame-pointer
> scan-tree-dump original " = f \\(\\);.*desc.0.dtype =
> 600;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*=
> .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -O3 -fomit-frame-pointer
> -funroll-all-loops -finline-functions scan-tree-dump original " = f
> \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
> \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -O3 -fomit-frame-pointer
> -funroll-loops scan-tree-dump original " = f \\(\\);.*desc.0.dtype =
> 600;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*=
> .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -O3 -g scan-tree-dump
> original " = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void ..
> D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -Os scan-tree-dump original "
> = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
> \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 19)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 20)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 21)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 26)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 33)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 37)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 9)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (internal compiler error)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for excess errors)
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-20 7:43 ` Igor Zamyatin
2012-07-20 7:51 ` Igor Zamyatin
@ 2012-07-20 20:08 ` Tobias Burnus
1 sibling, 0 replies; 18+ messages in thread
From: Tobias Burnus @ 2012-07-20 20:08 UTC (permalink / raw)
To: Igor Zamyatin; +Cc: gcc-patches, gfortran
Igor Zamyatin wrote:
>> I have now committed the attached version as Rev. 189700!
> This seems to cause following fails at least on i686:
I have now committed as obvious (Rev. 189725) a patch to solve the issue
for assumed_rank_12.f90; I have also a patch for the other issue
(assumed_rank_6.f90), but that's pending review:
http://gcc.gnu.org/ml/fortran/2012-07/msg00100.html
For some reasons, the value of the array type in the descriptor (dtype)
is differs on i686 from the value on x86-64.
Sorry for the breakage and thanks for the report.
Tobias
Index: gfortran.dg/assumed_rank_12.f90
===================================================================
--- gfortran.dg/assumed_rank_12.f90 (Revision 189724)
+++ gfortran.dg/assumed_rank_12.f90 (Arbeitskopie)
@@ -16,6 +16,6 @@
end function f
end
-! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.dtype =
600;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*=
.integer.kind=4. .. desc.0.data;" "original" } }
+! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.dtype =
.*;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*=
.integer.kind=4. .. desc.0.data;" "original" } }
! { dg-final { cleanup-tree-dump "original" } }
Index: ChangeLog
===================================================================
--- ChangeLog (Revision 189724)
+++ ChangeLog (Arbeitskopie)
@@ -1,3 +1,7 @@
+2012-07-20 Tobias Burnus <burnus@net-b.de>
+
+ * gfortran.dg/assumed_rank_12.f90: Update dg-error.
+
2012-07-20 Jason Merrill <jason@redhat.com>
PR c++/54038
>
> FAIL: gfortran.dg/assumed_rank_12.f90 -O0 scan-tree-dump original "
> = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
> \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -O1 scan-tree-dump original "
> = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
> \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -O2 scan-tree-dump original "
> = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
> \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -O3 -fomit-frame-pointer
> scan-tree-dump original " = f \\(\\);.*desc.0.dtype =
> 600;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*=
> .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -O3 -fomit-frame-pointer
> -funroll-all-loops -finline-functions scan-tree-dump original " = f
> \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
> \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -O3 -fomit-frame-pointer
> -funroll-loops scan-tree-dump original " = f \\(\\);.*desc.0.dtype =
> 600;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*=
> .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -O3 -g scan-tree-dump
> original " = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void ..
> D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_12.f90 -Os scan-tree-dump original "
> = f \\(\\);.*desc.0.dtype = 600;.*desc.0.data = .void .. D.*;.*sub
> \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 19)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 20)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 21)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 26)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 33)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 37)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for errors, line 9)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (internal compiler error)
> FAIL: gfortran.dg/assumed_rank_6.f90 -O (test for excess errors)
> FAIL: gfortran.dg/lto/pr45586-2
> f_lto_pr45586-2_0.o-f_lto_pr45586-2_0.o link, -O0 -flto
> -fuse-linker-plugin -fno-fat-lto-objects (internal compiler error)
>
^ permalink raw reply [flat|nested] 18+ messages in thread
* Re: [Patch, Fortran] Add parsing support for assumed-rank array
2012-07-20 5:58 ` Tobias Burnus
[not found] ` <0EFAB2BDD0F67E4FB6CCC8B9F87D756915E859A4@IRSMSX101.ger.corp.intel.com>
@ 2012-07-20 23:24 ` Andreas Schwab
1 sibling, 0 replies; 18+ messages in thread
From: Andreas Schwab @ 2012-07-20 23:24 UTC (permalink / raw)
To: Tobias Burnus; +Cc: Mikael Morin, gcc patches, gfortran
Tobias Burnus <burnus@net-b.de> writes:
> + if (e->rank != class_ts.u.derived->components->as->rank)
> + class_array_data_assign (&parmse->pre, ctree, parmse->expr,
> + TREE_TYPE (parmse->expr));
../../gcc/gcc/fortran/trans-expr.c: In function ‘gfc_conv_derived_to_class’:
../../gcc/gcc/fortran/trans-expr.c:311:165: warning: passing argument 4 of ‘class_array_data_assign’ makes integer from pointer without a cast [enabled by default]
../../gcc/gcc/fortran/trans-expr.c:206:1: note: expected ‘unsigned char’ but argument is of type ‘tree’
Andreas.
--
Andreas Schwab, schwab@linux-m68k.org
GPG Key fingerprint = 58CA 54C7 6D53 942B 1756 01D3 44D5 214B 8276 4ED5
"And now for something completely different."
^ permalink raw reply [flat|nested] 18+ messages in thread
end of thread, other threads:[~2012-07-20 23:24 UTC | newest]
Thread overview: 18+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2012-06-16 14:06 [Patch, Fortran] Add parsing support for assumed-rank array Tobias Burnus
2012-06-24 15:48 ` Tobias Burnus
2012-07-05 13:52 ` Mikael Morin
2012-07-06 21:13 ` Tobias Burnus
2012-07-12 19:40 ` Mikael Morin
2012-07-12 20:08 ` Tobias Burnus
2012-07-13 7:51 ` Tobias Burnus
2012-07-14 13:26 ` Mikael Morin
2012-07-15 19:14 ` Tobias Burnus
2012-07-19 15:58 ` Mikael Morin
2012-07-19 17:39 ` Mikael Morin
2012-07-19 20:21 ` Tobias Burnus
2012-07-19 21:36 ` Tobias Burnus
2012-07-20 5:58 ` Tobias Burnus
[not found] ` <0EFAB2BDD0F67E4FB6CCC8B9F87D756915E859A4@IRSMSX101.ger.corp.intel.com>
2012-07-20 7:43 ` Igor Zamyatin
2012-07-20 7:51 ` Igor Zamyatin
2012-07-20 20:08 ` Tobias Burnus
2012-07-20 23:24 ` Andreas Schwab
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).