* [fortran-dev, patch] PR36874 - shape checks for cshift/eoshift
@ 2009-03-22 13:44 Daniel Franke
0 siblings, 0 replies; only message in thread
From: Daniel Franke @ 2009-03-22 13:44 UTC (permalink / raw)
To: fortran; +Cc: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 1024 bytes --]
Attached patch adds compile-time shape-conformance checks to CSHIFT/EOSHIFT
intrinsics.
The changes in dim_rank_check() and its callers is not strictly necessary
here, they are more of a general cleanup and could be split into a separate
patch on request.
2009-03-22 Daniel Franke <franke.daniel@gmail.com>
PR fortran/36874
* check.c (gfc_check_cshift): Added missing shape-conformance checks.
(gfc_check_eoshift): Likewise.
(dim_rank_check): Return SUCCESS if DIM=NULL.
(gfc_check_lbound): Removed (now) redundant check for DIM=NULL.
(gfc_check_minloc_maxloc): Likewise.
(check_reduction): Likewise.
(gfc_check_size): Likewise.
(gfc_check_ubound): Likewise.
2009-03-22 Daniel Franke <franke.daniel@gmail.com>
PR fortran/36874
* gfortran.dg/intrinsic_argument_conformance_2.f90: Adjusted error message.
* gfortran.dg/zero_sized_1.f90: Removed checks with incompatible shapes.
* gfortran.dg/zero_sized_5.f90: Likewise.
Regression tested on i686-pc-linux-gnu. Ok for dev and 4.5?
Cheers
Daniel
[-- Attachment #2: pr36874.diff --]
[-- Type: text/x-patch, Size: 11833 bytes --]
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c (revision 144996)
+++ gcc/fortran/check.c (working copy)
@@ -339,6 +339,9 @@ dim_rank_check (gfc_expr *dim, gfc_expr
gfc_array_ref *ar;
int rank;
+ if (dim == NULL)
+ return SUCCESS;
+
if (dim->expr_type != EXPR_CONSTANT
|| (array->expr_type != EXPR_VARIABLE
&& array->expr_type != EXPR_ARRAY))
@@ -876,23 +879,55 @@ gfc_check_cshift (gfc_expr *array, gfc_e
if (type_check (shift, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (array->rank == 1)
+ if (dim_check (dim, 2, true) == FAILURE)
+ return FAILURE;
+
+ if (dim_rank_check (dim, array, false) == FAILURE)
+ return FAILURE;
+
+ if (array->rank == 1 || shift->rank == 0)
{
if (scalar_check (shift, 1) == FAILURE)
return FAILURE;
}
- else if (shift->rank != array->rank - 1 && shift->rank != 0)
+ else if (shift->rank == array->rank - 1)
{
- gfc_error ("SHIFT argument at %L of CSHIFT must have rank %d or be a "
- "scalar", &shift->where, array->rank - 1);
- return FAILURE;
- }
+ int d;
+ if (!dim)
+ d = 1;
+ else if (dim->expr_type == EXPR_CONSTANT)
+ gfc_extract_int (dim, &d);
+ else
+ d = -1;
- /* TODO: Add shape conformance check between array (w/o dimension dim)
- and shift. */
+ if (d > 0)
+ {
+ int i, j;
+ for (i = 0, j = 0; i < array->rank; i++)
+ if (i != d - 1)
+ {
+ if (!identical_dimen_shape (array, i, shift, j))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ "invalid shape in dimension %d (%ld/%ld)",
+ gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, i + 1,
+ mpz_get_si (array->shape[i]),
+ mpz_get_si (shift->shape[j]));
+ return FAILURE;
+ }
- if (dim_check (dim, 2, true) == FAILURE)
- return FAILURE;
+ j += 1;
+ }
+ }
+ }
+ else
+ {
+ gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+ "%d or be a scalar", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, array->rank - 1);
+ return FAILURE;
+ }
return SUCCESS;
}
@@ -1042,55 +1077,84 @@ gfc_check_eoshift (gfc_expr *array, gfc_
if (type_check (shift, 1, BT_INTEGER) == FAILURE)
return FAILURE;
- if (array->rank == 1)
+ if (dim_check (dim, 3, true) == FAILURE)
+ return FAILURE;
+
+ if (dim_rank_check (dim, array, false) == FAILURE)
+ return FAILURE;
+
+ if (array->rank == 1 || shift->rank == 0)
{
- if (scalar_check (shift, 2) == FAILURE)
+ if (scalar_check (shift, 1) == FAILURE)
return FAILURE;
}
- else if (shift->rank != array->rank - 1 && shift->rank != 0)
+ else if (shift->rank == array->rank - 1)
{
- gfc_error ("SHIFT argument at %L of EOSHIFT must have rank %d or be a "
- "scalar", &shift->where, array->rank - 1);
+ int d;
+ if (!dim)
+ d = 1;
+ else if (dim->expr_type == EXPR_CONSTANT)
+ gfc_extract_int (dim, &d);
+ else
+ d = -1;
+
+ if (d > 0)
+ {
+ int i, j;
+ for (i = 0, j = 0; i < array->rank; i++)
+ if (i != d - 1)
+ {
+ if (!identical_dimen_shape (array, i, shift, j))
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ "invalid shape in dimension %d (%ld/%ld)",
+ gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, i + 1,
+ mpz_get_si (array->shape[i]),
+ mpz_get_si (shift->shape[j]));
+ return FAILURE;
+ }
+
+ j += 1;
+ }
+ }
+ }
+ else
+ {
+ gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+ "%d or be a scalar", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, array->rank - 1);
return FAILURE;
}
- /* TODO: Add shape conformance check between array (w/o dimension dim)
- and shift. */
-
if (boundary != NULL)
{
if (same_type_check (array, 0, boundary, 2) == FAILURE)
return FAILURE;
- if (array->rank == 1)
+ if (array->rank == 1 || boundary->rank == 0)
{
if (scalar_check (boundary, 2) == FAILURE)
return FAILURE;
}
- else if (boundary->rank != array->rank - 1 && boundary->rank != 0)
+ else if (boundary->rank == array->rank - 1)
{
- gfc_error ("BOUNDARY argument at %L of EOSHIFT must have rank %d or be "
- "a scalar", &boundary->where, array->rank - 1);
- return FAILURE;
+ char buffer[80];
+ snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic_arg[2],
+ gfc_current_intrinsic);
+ if (gfc_check_conformance (buffer, shift, boundary) == FAILURE)
+ return FAILURE;
}
-
- if (shift->rank == boundary->rank)
+ else
{
- int i;
- for (i = 0; i < shift->rank; i++)
- if (! identical_dimen_shape (shift, i, boundary, i))
- {
- gfc_error ("Different shape in dimension %d for SHIFT and "
- "BOUNDARY arguments of EOSHIFT at %L", shift->rank,
- &boundary->where);
- return FAILURE;
- }
+ gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
+ "rank %d or be a scalar", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &shift->where, array->rank - 1);
+ return FAILURE;
}
}
- if (dim_check (dim, 4, true) == FAILURE)
- return FAILURE;
-
return SUCCESS;
}
@@ -1512,14 +1576,11 @@ gfc_check_lbound (gfc_expr *array, gfc_e
if (array_check (array, 0) == FAILURE)
return FAILURE;
- if (dim != NULL)
- {
- if (dim_check (dim, 1, false) == FAILURE)
- return FAILURE;
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
- if (dim_rank_check (dim, array, 1) == FAILURE)
- return FAILURE;
- }
+ if (dim_rank_check (dim, array, 1) == FAILURE)
+ return FAILURE;
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
return FAILURE;
@@ -1905,10 +1966,10 @@ gfc_check_minloc_maxloc (gfc_actual_argl
ap->next->next->expr = m;
}
- if (d && dim_check (d, 1, false) == FAILURE)
+ if (dim_check (d, 1, false) == FAILURE)
return FAILURE;
- if (d && dim_rank_check (d, a, 0) == FAILURE)
+ if (dim_rank_check (d, a, 0) == FAILURE)
return FAILURE;
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
@@ -1961,10 +2022,10 @@ check_reduction (gfc_actual_arglist *ap)
ap->next->next->expr = m;
}
- if (d && dim_check (d, 1, false) == FAILURE)
+ if (dim_check (d, 1, false) == FAILURE)
return FAILURE;
- if (d && dim_rank_check (d, a, 0) == FAILURE)
+ if (dim_rank_check (d, a, 0) == FAILURE)
return FAILURE;
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
@@ -2650,14 +2711,11 @@ gfc_check_size (gfc_expr *array, gfc_exp
if (array_check (array, 0) == FAILURE)
return FAILURE;
- if (dim != NULL)
- {
- if (dim_check (dim, 1, true) == FAILURE)
- return FAILURE;
+ if (dim_check (dim, 1, true) == FAILURE)
+ return FAILURE;
- if (dim_rank_check (dim, array, 0) == FAILURE)
- return FAILURE;
- }
+ if (dim_rank_check (dim, array, 0) == FAILURE)
+ return FAILURE;
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
return FAILURE;
@@ -2993,14 +3051,11 @@ gfc_check_ubound (gfc_expr *array, gfc_e
if (array_check (array, 0) == FAILURE)
return FAILURE;
- if (dim != NULL)
- {
- if (dim_check (dim, 1, false) == FAILURE)
- return FAILURE;
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
- if (dim_rank_check (dim, array, 0) == FAILURE)
- return FAILURE;
- }
+ if (dim_rank_check (dim, array, 0) == FAILURE)
+ return FAILURE;
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
return FAILURE;
Index: gcc/testsuite/gfortran.dg/zero_sized_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/zero_sized_1.f90 (revision 144992)
+++ gcc/testsuite/gfortran.dg/zero_sized_1.f90 (working copy)
@@ -15,9 +15,6 @@ subroutine test_cshift
if (any(cshift(gee,shift=(/1,-1/),dim=1)/= 0)) call abort
if (any(cshift(gee,shift=(/1,-1/),dim=2)/= 0)) call abort
if (any(cshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) call abort
- if (any(cshift(tempm(5:4,:),shift=(/1,-1/),dim=2)/= 0)) call abort
- if (any(cshift(tempm(:,5:4),shift=(/1,-1/),dim=1)/= 0)) call abort
- if (any(cshift(tempm(:,5:4),shift=(/1,-1/),dim=2)/= 0)) call abort
deallocate(foo,bar,gee)
end
@@ -34,9 +31,6 @@ subroutine test_eoshift
if (any(eoshift(gee,shift=(/1,-1/),dim=1)/= 0)) call abort
if (any(eoshift(gee,shift=(/1,-1/),dim=2)/= 0)) call abort
if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) call abort
- if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2)/= 0)) call abort
- if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1)/= 0)) call abort
- if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2)/= 0)) call abort
if (any(eoshift(foo,dim=1,shift=1,boundary=42.0)/= 0)) call abort
if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=42.0)/= 0)) call abort
@@ -45,9 +39,6 @@ subroutine test_eoshift
if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort
if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
- if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort
- if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
- if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort
if (any(eoshift(foo,dim=1,shift=1,boundary=42.0)/= 0)) call abort
if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=-7.0)/= 0)) call abort
@@ -56,9 +47,6 @@ subroutine test_eoshift
if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
- if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
- if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
- if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
deallocate(foo,bar,gee)
end
Index: gcc/testsuite/gfortran.dg/zero_sized_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/zero_sized_5.f90 (revision 144992)
+++ gcc/testsuite/gfortran.dg/zero_sized_5.f90 (working copy)
@@ -8,8 +8,6 @@ program main
b = cshift (a,1)
b = cshift (a,j)
b = eoshift (a,1)
- b = eoshift (a,(/1/))
b = eoshift (a,1,boundary=c(1,:))
b = eoshift (a, j, boundary=c(1,:))
-
end program main
Index: gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90 (revision 144992)
+++ gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90 (working copy)
@@ -34,7 +34,7 @@ program main
b2 = eoshift (a2,1,boundary=c2(:,:)) ! { dg-error "have rank 1 or be a scalar" }
b2 = eoshift (a2,(/1/), boundary=c2(:,:)) ! { dg-error "have rank 1 or be a scalar" }
- b = eoshift (a,(/1/), boundary=c(1,:)) ! { dg-error "Different shape in dimension 1" }
+ b = eoshift (a,(/1/), boundary=c(1,:)) ! { dg-error "invalid shape in dimension" }
if (any(eoshift(foo,dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort() ! { dg-error "must be a scalar" }
if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort() ! { dg-error "must be a scalar" }
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2009-03-22 13:12 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2009-03-22 13:44 [fortran-dev, patch] PR36874 - shape checks for cshift/eoshift Daniel Franke
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).