aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog10
-rw-r--r--gcc/fortran/array.c8
-rw-r--r--gcc/fortran/decl.c23
-rw-r--r--gcc/fortran/trans-intrinsic.c46
4 files changed, 73 insertions, 14 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7be7bdb..b388efc 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,15 @@
2012-07-21 Tobias Burnus <burnus@net-b.de>
+ PR fortran/48820
+ * trans-intrinsic.c (gfc_conv_intrinsic_bound): Support
+ lbound/ubound with dim= for assumed-rank arrays.
+ * array.c (gfc_set_array_spec): Reject coarrays with
+ assumed shape.
+ * decl.c (merge_array_spec): Ditto. Return gfc_try.
+ (match_attr_spec, match_attr_spec): Update call.
+
+2012-07-21 Tobias Burnus <burnus@net-b.de>
+
* resolve.c (resolve_formal_arglist): Put variable
declaration before the first assignment.
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index acae59f..1b700b8 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -750,6 +750,14 @@ gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
return SUCCESS;
}
+ if ((sym->as->type == AS_ASSUMED_RANK && as->corank)
+ || (as->type == AS_ASSUMED_RANK && sym->as->corank))
+ {
+ gfc_error ("The assumed-rank array '%s' at %L shall not have a "
+ "codimension", sym->name, error_loc);
+ return FAILURE;
+ }
+
if (as->corank)
{
/* The "sym" has no corank (checked via gfc_add_codimension). Thus
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 28e5a5b..5d234e6 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -589,13 +589,17 @@ cleanup:
/* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
-static void
+static gfc_try
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 ((from->type == AS_ASSUMED_RANK && to->corank)
+ || (to->type == AS_ASSUMED_RANK && from->corank))
+ {
+ gfc_error ("The assumed-rank array at %C shall not have a codimension");
+ return FAILURE;
+ }
if (to->rank == 0 && from->rank > 0)
{
@@ -642,6 +646,8 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
}
}
}
+
+ return SUCCESS;
}
@@ -1799,8 +1805,12 @@ variable_decl (int elem)
if (m == MATCH_NO)
as = gfc_copy_array_spec (current_as);
- else if (current_as)
- merge_array_spec (current_as, as, true);
+ else if (current_as
+ && merge_array_spec (current_as, as, true) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
if (gfc_option.flag_cray_pointer)
cp_as = gfc_copy_array_spec (as);
@@ -3512,7 +3522,8 @@ match_attr_spec (void)
current_as = as;
else if (m == MATCH_YES)
{
- merge_array_spec (as, current_as, false);
+ if (merge_array_spec (as, current_as, false) == FAILURE)
+ m = MATCH_ERROR;
free (as);
}
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index be94219..7bcfda9 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1367,6 +1367,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;
@@ -1408,27 +1409,36 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
desc = argse.expr;
+ as = gfc_get_full_arrayspec_from_expr (arg->expr);
+
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,
@@ -1436,11 +1446,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
@@ -1462,7 +1480,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);
@@ -1488,9 +1508,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
{
generated by cgit v1.1 at 2025-05-28 03:17:34 +0000