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> 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/25104
PR fortran/29962 PR fortran/29962
* intrinsic.h (gfc_simplify_dot_product): New prototype. * 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 **), ...@@ -1561,7 +1561,7 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
rc = ARITH_OK; rc = ARITH_OK;
d = op2->value.constructor; d = op2->value.constructor;
if (gfc_check_conformance ("elemental binary operation", op1, op2) if (gfc_check_conformance (op1, op2, "elemental binary operation")
!= SUCCESS) != SUCCESS)
rc = ARITH_INCOMMENSURATE; rc = ARITH_INCOMMENSURATE;
else else
......
gcc/fortran/expr.c
...@@ -2776,18 +2776,25 @@ gfc_specification_expr (gfc_expr *e) ...@@ -2776,18 +2776,25 @@ gfc_specification_expr (gfc_expr *e)
/* Given two expressions, make sure that the arrays are conformable. */ /* Given two expressions, make sure that the arrays are conformable. */
gfc_try 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; int op1_flag, op2_flag, d;
mpz_t op1_size, op2_size; mpz_t op1_size, op2_size;
gfc_try t; gfc_try t;
va_list argp;
char buffer[240];
if (op1->rank == 0 || op2->rank == 0) if (op1->rank == 0 || op2->rank == 0)
return SUCCESS; return SUCCESS;
va_start (argp, optype_msgid);
vsnprintf (buffer, 240, optype_msgid, argp);
va_end (argp);
if (op1->rank != op2->rank) 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); op1->rank, op2->rank, &op1->where);
return FAILURE; return FAILURE;
} }
...@@ -2802,7 +2809,7 @@ gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2) ...@@ -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) if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
{ {
gfc_error ("Different shape for %s at %L on dimension %d " 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 (op1_size),
(int) mpz_get_si (op2_size)); (int) mpz_get_si (op2_size));
...@@ -2950,7 +2957,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) ...@@ -2950,7 +2957,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
/* Check size of array assignments. */ /* Check size of array assignments. */
if (lvalue->rank != 0 && rvalue->rank != 0 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; return FAILURE;
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
......
gcc/fortran/gfortran.h
...@@ -2484,7 +2484,7 @@ gfc_try gfc_specification_expr (gfc_expr *); ...@@ -2484,7 +2484,7 @@ gfc_try gfc_specification_expr (gfc_expr *);
int gfc_numeric_ts (gfc_typespec *); int gfc_numeric_ts (gfc_typespec *);
int gfc_kind_max (gfc_expr *, gfc_expr *); 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_assign (gfc_expr *, gfc_expr *, int);
gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *); gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
gfc_try gfc_check_assign_symbol (gfc_symbol *, 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) ...@@ -3617,14 +3617,13 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
first_expr = arg->expr; first_expr = arg->expr;
for ( ; arg && arg->expr; arg = arg->next, n++) for ( ; arg && arg->expr; arg = arg->next, n++)
{ if (gfc_check_conformance (first_expr, arg->expr,
char buffer[80]; "arguments '%s' and '%s' for "
snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'", "intrinsic '%s'",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[n], gfc_current_intrinsic_arg[0],
gfc_current_intrinsic); gfc_current_intrinsic_arg[n],
if (gfc_check_conformance (buffer, first_expr, arg->expr) == FAILURE) gfc_current_intrinsic) == FAILURE)
return FAILURE; return FAILURE;
}
} }
if (t == FAILURE) if (t == FAILURE)
......
gcc/fortran/resolve.c
...@@ -1584,8 +1584,8 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) ...@@ -1584,8 +1584,8 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
/* Elemental procedure's array actual arguments must conform. */ /* Elemental procedure's array actual arguments must conform. */
if (e != NULL) if (e != NULL)
{ {
if (gfc_check_conformance ("elemental procedure", arg->expr, e) if (gfc_check_conformance (arg->expr, e,
== FAILURE) "elemental procedure") == FAILURE)
return FAILURE; return FAILURE;
} }
else 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> 2009-06-07 H.J. Lu <hongjiu.lu@intel.com>
PR middle-end/32950 PR middle-end/32950
......
gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
...@@ -34,7 +34,7 @@ program main ...@@ -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" }
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(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" } 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 ...@@ -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=1)/= 0)) call abort
if (any(cshift(gee,shift=(/1,-1/),dim=2)/= 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=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) deallocate(foo,bar,gee)
end end
...@@ -34,9 +31,6 @@ subroutine test_eoshift ...@@ -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=1)/= 0)) call abort
if (any(eoshift(gee,shift=(/1,-1/),dim=2)/= 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=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(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 if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=42.0)/= 0)) call abort
...@@ -45,9 +39,6 @@ subroutine test_eoshift ...@@ -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=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(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=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(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 if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=-7.0)/= 0)) call abort
...@@ -56,9 +47,6 @@ subroutine test_eoshift ...@@ -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=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(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=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) deallocate(foo,bar,gee)
end end
......
gcc/testsuite/gfortran.dg/zero_sized_5.f90
...@@ -8,8 +8,6 @@ program main ...@@ -8,8 +8,6 @@ program main
b = cshift (a,1) b = cshift (a,1)
b = cshift (a,j) b = cshift (a,j)
b = eoshift (a,1) b = eoshift (a,1)
b = eoshift (a,(/1/))
b = eoshift (a,1,boundary=c(1,:)) b = eoshift (a,1,boundary=c(1,:))
b = eoshift (a, j, boundary=c(1,:)) b = eoshift (a, j, boundary=c(1,:))
end program main 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