Dear all,
this patch is a cleanup follow up to the assumed-rank patch. Changes:
* Fix pattern matching for the dump. for some reason, the DTYPE differes
between i686 and x86-64.
* There was a proper check missing that assumed-rank arrays may not have
a codimension. (There are now checks in array.c, decl.c and -
preexisting - resolve.c, all are triggered by the test case _11.)
* I re-added my lbound/ubound patch. It still only works with dim=.
For lbound/ubound without dim= and for shape, one has to modify the
scalarizer a bit. See discussion at
http://gcc.gnu.org/ml/fortran/2012-07/msg00032.html
Mikael: I wouldn't mind if you could have a look at the scalarizer - you
seem to have an idea how one can implement it with minimal effort/code
cluttering.
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
PS: Sorry for missing the regression failure before the committal.
2012-07-20 Tobias Burnus <bur...@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-20 Tobias Burnus <bur...@net-b.de>
PR fortran/48820
* gfortran.dg/assumed_rank_3.f90: New.
* gfortran.dg/assumed_rank_11.f90: New.
* gfortran.dg/assumed_rank_1.f90: Update dg-error.
* gfortran.dg/assumed_rank_2.f90: Update dg-error.
* gfortran.dg/assumed_rank_7.f90: Update dg-error.
* gfortran.dg/assumed_rank_12.f90: Update dg-error.
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 66e2ca8..c836b25 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;
}
@@ -1813,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);
@@ -3526,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
{
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_1.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_1.f90
index d68f1f9..44e278c 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_1.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_1.f90
@@ -5,8 +5,6 @@
!
! Assumed-rank tests
!
-! FIXME: The ubound/lbound checks have to be re-enabled when
-! after they are supported
implicit none
@@ -106,14 +104,14 @@ contains
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 (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 (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)
@@ -131,14 +129,14 @@ contains
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 (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 (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)
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
index a2abcba..f947f49 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
@@ -16,6 +16,6 @@ function f() result(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 { 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" } }
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_2.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_2.f90
index 981e5cc2..344278e 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_2.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_2.f90
@@ -6,8 +6,6 @@
! 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
@@ -73,14 +71,14 @@ contains
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 (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 (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)
@@ -98,14 +96,14 @@ contains
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 (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 (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
@@ -122,14 +120,14 @@ contains
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 (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 (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)
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_6.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_6.f90
index e5071bd..86da3f8 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_6.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_6.f90
@@ -30,8 +30,8 @@ contains
end subroutine
end subroutine
-subroutine foo4(x) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
- integer, codimension[*] :: x(..)
+subroutine foo4(x)
+ integer, codimension[*] :: x(..) ! { dg-error "The assumed-rank array at .1. shall not have a codimension" }
end subroutine
subroutine foo5(y) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_7.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_7.f90
index 96d4d8f..f9ff3b9 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_7.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_7.f90
@@ -4,8 +4,6 @@
!
! 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
@@ -29,38 +27,38 @@ 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 (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()
+ 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 (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()
+ 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 (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()
+ 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 (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()
+ 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_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-07-18 07:03:52.759757921 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_11.f90 2012-07-20 10:35:39.000000000 +0200
@@ -0,0 +1,52 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/48820
+!
+! Assumed-rank tests
+subroutine foo(X)
+ integer :: x(..)
+ codimension :: x[*] ! { dg-error "The assumed-rank array 'x' at .1. shall not have a codimension" }
+end
+
+subroutine foo2(X)
+ integer, dimension(..) :: x[*] ! { dg-error "The assumed-rank array at .1. shall not have a codimension" }
+end
+
+subroutine foo3(X)
+ integer, codimension[*] :: x(..) ! { dg-error "The assumed-rank array at .1. shall not have a codimension" }
+end
+
+subroutine foo4(X)
+ integer, codimension[*], dimension(..) :: x ! { dg-error "The assumed-rank array at .1. shall not have a codimension" }
+end
+
+subroutine bar(X)
+ integer :: x[*]
+ dimension :: x(..) ! { dg-error "The assumed-rank array 'x' at .1. shall not have a codimension" }
+end
+
+subroutine foobar(X)
+ integer :: x
+ codimension :: x[*]
+ dimension :: x(..) ! { dg-error "The assumed-rank array 'x' at .1. shall not have a codimension" }
+end
+
+subroutine barfoo(X)
+ integer :: x
+ dimension :: x(..)
+ codimension :: x[*] ! { dg-error "The assumed-rank array 'x' at .1. shall not have a codimension" }
+end
+
+subroutine orig(X) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
+ integer :: x(..)[*]
+end
+
+subroutine val1(X)
+ integer, value :: x(..) ! { dg-error "VALUE attribute conflicts with DIMENSION attribute" }
+end
+
+subroutine val2(X)
+ integer, value :: x
+ dimension :: x(..) ! { dg-error "VALUE attribute conflicts with DIMENSION attribute" }
+end
