Skip to content

R
riscv-gcc-1
Commit ca8a8795 by Daniel Franke Committed by Tobias Burnus
Options

re PR fortran/36874 (Add shape checks to cshift/eoshift) 

2009-06-07  Daniel Franke  <franke.daniel@gmail.com>

        * check.c (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.
        (gfc_check_cshift): Added missing shape-conformance checks.
        (gfc_check_eoshift): Likewise.
        * gfortran.h (gfc_check_conformance): Modified prototype to printf-style.
        * expr.c (gfc_check_conformance): Accept error-message chunks in
        printf-style. Changed all callers.

2009-06-07  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.

From-SVN: r148247
parent 014583a1
Showing with 186 additions and 123 deletions
gcc/fortran/ChangeLog
2009-06-07 Daniel Franke <franke.daniel@gmail.com>
* check.c (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.
(gfc_check_cshift): Added missing shape-conformance checks.
(gfc_check_eoshift): Likewise.
* gfortran.h (gfc_check_conformance): Modified prototype to printf-style.
* expr.c (gfc_check_conformance): Accept error-message chunks in
printf-style. Changed all callers.
2009-06-07 Daniel Franke <franke.daniel@gmail.com>
PR fortran/25104
PR fortran/29962
* intrinsic.h (gfc_simplify_dot_product): New prototype.
......
gcc/fortran/arith.c
......@@ -1561,7 +1561,7 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
rc = ARITH_OK;
d = op2->value.constructor;
if (gfc_check_conformance ("elemental binary operation", op1, op2)
if (gfc_check_conformance (op1, op2, "elemental binary operation")
!= SUCCESS)
rc = ARITH_INCOMMENSURATE;
else
......
gcc/fortran/expr.c
......@@ -2776,18 +2776,25 @@ gfc_specification_expr (gfc_expr *e)
/* Given two expressions, make sure that the arrays are conformable. */
gfc_try
gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
{
int op1_flag, op2_flag, d;
mpz_t op1_size, op2_size;
gfc_try t;
va_list argp;
char buffer[240];
if (op1->rank == 0 || op2->rank == 0)
return SUCCESS;
va_start (argp, optype_msgid);
vsnprintf (buffer, 240, optype_msgid, argp);
va_end (argp);
if (op1->rank != op2->rank)
{
gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid),
gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
op1->rank, op2->rank, &op1->where);
return FAILURE;
}
......@@ -2802,7 +2809,7 @@ gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
{
gfc_error ("Different shape for %s at %L on dimension %d "
"(%d and %d)", _(optype_msgid), &op1->where, d + 1,
"(%d and %d)", _(buffer), &op1->where, d + 1,
(int) mpz_get_si (op1_size),
(int) mpz_get_si (op2_size));
......@@ -2950,7 +2957,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
/* Check size of array assignments. */
if (lvalue->rank != 0 && rvalue->rank != 0
&& gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
&& gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
return FAILURE;
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
......
gcc/fortran/gfortran.h
......@@ -2484,7 +2484,7 @@ gfc_try gfc_specification_expr (gfc_expr *);
int gfc_numeric_ts (gfc_typespec *);
int gfc_kind_max (gfc_expr *, gfc_expr *);
gfc_try gfc_check_conformance (const char *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3;
gfc_try gfc_check_assign (gfc_expr *, gfc_expr *, int);
gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
......
gcc/fortran/intrinsic.c
......@@ -3617,14 +3617,13 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
first_expr = arg->expr;
for ( ; arg && arg->expr; arg = arg->next, n++)
{
char buffer[80];
snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[n],
gfc_current_intrinsic);
if (gfc_check_conformance (buffer, first_expr, arg->expr) == FAILURE)
return FAILURE;
}
if (gfc_check_conformance (first_expr, arg->expr,
"arguments '%s' and '%s' for "
"intrinsic '%s'",
gfc_current_intrinsic_arg[0],
gfc_current_intrinsic_arg[n],
gfc_current_intrinsic) == FAILURE)
return FAILURE;
}
if (t == FAILURE)
......
gcc/fortran/resolve.c
......@@ -1584,8 +1584,8 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
/* Elemental procedure's array actual arguments must conform. */
if (e != NULL)
{
if (gfc_check_conformance ("elemental procedure", arg->expr, e)
== FAILURE)
if (gfc_check_conformance (arg->expr, e,
"elemental procedure") == FAILURE)
return FAILURE;
}
else
......
gcc/testsuite/ChangeLog
2009-06-07 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.
2009-06-07 H.J. Lu <hongjiu.lu@intel.com>
PR middle-end/32950
......
gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
......@@ -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" }
......
gcc/testsuite/gfortran.dg/zero_sized_1.f90
......@@ -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
......
gcc/testsuite/gfortran.dg/zero_sized_5.f90
......@@ -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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment