mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 10:50:51 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/25104 ([F2003] Non-initialization expr. as case-selector)

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

        PR fortran/25104
        PR fortran/29962
        * array.c (gfc_append_constructor): Added NULL-check.
        * check.c (gfc_check_spread): Check DIM.
        (gfc_check_unpack): Check that the ARRAY arguments provides
        enough values for MASK.
        * intrinsic.h (gfc_simplify_spread): New prototype.
        (gfc_simplify_unpack): Likewise.
        * intrinsic.c (add_functions): Added new simplifier callbacks.
        * simplify.c (gfc_simplify_spread): New.
        (gfc_simplify_unpack): New.
        * expr.c (check_transformational): Allow additional
        * transformational
        intrinsics in initialization expression.

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

        PR fortran/25104
        PR fortran/29962
        * gfortran.dg/spread_init_expr.f03: New.
        * gfortran.dg/unpack_init_expr.f03: New.
        * gfortran.dg/intrinsic_argument_conformance_2.f90: Adjusted
        error message.

From-SVN: r148250
This commit is contained in:
Daniel Franke 2009-06-07 13:33:34 -04:00 committed by Tobias Burnus
parent a16d978fca
commit c430a6f9f8
11 changed files with 264 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/fortran/ChangeLog
View File

@ -1,3 +1,19 @@
2009-06-07 Daniel Franke <franke.daniel@gmail.com>
PR fortran/25104
PR fortran/29962
* array.c (gfc_append_constructor): Added NULL-check.
* check.c (gfc_check_spread): Check DIM.
(gfc_check_unpack): Check that the ARRAY arguments provides enough
values for MASK.
* intrinsic.h (gfc_simplify_spread): New prototype.
(gfc_simplify_unpack): Likewise.
* intrinsic.c (add_functions): Added new simplifier callbacks.
* simplify.c (gfc_simplify_spread): New.
(gfc_simplify_unpack): New.
* expr.c (check_transformational): Allow additional transformational
intrinsics in initialization expression.
2009-06-07 Daniel Franke <franke.daniel@gmail.com>
PR fortran/25104

3
gcc/fortran/array.c
View File

@ -607,7 +607,8 @@ gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
c->expr = new_expr;
if (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind)
if (new_expr
&& (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind))
gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
}

61
gcc/fortran/check.c
View File

@ -2816,6 +2816,18 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
/* dim_rank_check() does not apply here. */
if (dim
&& dim->expr_type == EXPR_CONSTANT
&& (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
"dimension index", gfc_current_intrinsic_arg[1],
gfc_current_intrinsic, &dim->where);
return FAILURE;
}
if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
return FAILURE;
@ -3120,6 +3132,8 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
gfc_try
gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
{
mpz_t vector_size;
if (rank_check (vector, 0, 1) == FAILURE)
return FAILURE;
@ -3132,10 +3146,45 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
if (same_type_check (vector, 0, field, 2) == FAILURE)
return FAILURE;
if (mask->expr_type == EXPR_ARRAY
&& gfc_array_size (vector, &vector_size) == SUCCESS)
{
int mask_true_count = 0;
gfc_constructor *mask_ctor = mask->value.constructor;
while (mask_ctor)
{
if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
{
mask_true_count = 0;
break;
}
if (mask_ctor->expr->value.logical)
mask_true_count++;
mask_ctor = mask_ctor->next;
}
if (mpz_get_si (vector_size) < mask_true_count)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must "
"provide at least as many elements as there "
"are .TRUE. values in '%s' (%ld/%d)",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
&vector->where, gfc_current_intrinsic_arg[1],
mpz_get_si (vector_size), mask_true_count);
return FAILURE;
}
mpz_clear (vector_size);
}
if (mask->rank != field->rank && field->rank != 0)
{
gfc_error ("FIELD argument at %L of UNPACK must have the same rank as "
"MASK or be a scalar", &field->where);
gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
"the same rank as '%s' or be a scalar",
gfc_current_intrinsic_arg[2], gfc_current_intrinsic,
&field->where, gfc_current_intrinsic_arg[1]);
return FAILURE;
}
@ -3145,9 +3194,11 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
for (i = 0; i < field->rank; i++)
if (! identical_dimen_shape (mask, i, field, i))
{
gfc_error ("Different shape in dimension %d for MASK and FIELD "
"arguments of UNPACK at %L", mask->rank, &field->where);
return FAILURE;
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
"must have identical shape.",
gfc_current_intrinsic_arg[2],
gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
&field->where);
}
}

3
gcc/fortran/expr.c
View File

@ -2130,7 +2130,8 @@ check_transformational (gfc_expr *e)
static const char * const trans_func_f2003[] = {
"all", "any", "count", "dot_product", "matmul", "null", "pack",
"product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
"selected_real_kind", "sum", "transfer", "transpose", "trim", NULL
"selected_real_kind", "spread", "sum", "transfer", "transpose",
"trim", "unpack", NULL
};
int i;

4
gcc/fortran/intrinsic.c
View File

@ -2433,7 +2433,7 @@ add_functions (void)
make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
add_sym_3 ("spread", GFC_ISYM_SPREAD, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_spread, NULL, gfc_resolve_spread,
gfc_check_spread, gfc_simplify_spread, gfc_resolve_spread,
src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
ncopies, BT_INTEGER, di, REQUIRED);
@ -2575,7 +2575,7 @@ add_functions (void)
make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
add_sym_3 ("unpack", GFC_ISYM_UNPACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_unpack, NULL, gfc_resolve_unpack,
gfc_check_unpack, gfc_simplify_unpack, gfc_resolve_unpack,
v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
f, BT_REAL, dr, REQUIRED);

2
gcc/fortran/intrinsic.h
View File

@ -318,6 +318,7 @@ gfc_expr *gfc_simplify_sinh (gfc_expr *);
gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_sngl (gfc_expr *);
gfc_expr *gfc_simplify_spacing (gfc_expr *);
gfc_expr *gfc_simplify_spread (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_sqrt (gfc_expr *);
gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_tan (gfc_expr *);
@ -328,6 +329,7 @@ gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_transpose (gfc_expr *);
gfc_expr *gfc_simplify_trim (gfc_expr *);
gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_unpack (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_xor (gfc_expr *, gfc_expr *);

141
gcc/fortran/simplify.c
View File

@ -5037,6 +5037,99 @@ gfc_simplify_spacing (gfc_expr *x)
}
gfc_expr *
gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
{
gfc_expr *result = 0L;
int i, j, dim, ncopies;
if ((!gfc_is_constant_expr (source)
&& !is_constant_array_expr (source))
|| !gfc_is_constant_expr (dim_expr)
|| !gfc_is_constant_expr (ncopies_expr))
return NULL;
gcc_assert (dim_expr->ts.type == BT_INTEGER);
gfc_extract_int (dim_expr, &dim);
dim -= 1; /* zero-base DIM */
gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
gfc_extract_int (ncopies_expr, &ncopies);
ncopies = MAX (ncopies, 0);
if (source->expr_type == EXPR_CONSTANT)
{
gcc_assert (dim == 0);
result = gfc_start_constructor (source->ts.type,
source->ts.kind,
&source->where);
result->rank = 1;
result->shape = gfc_get_shape (result->rank);
mpz_init_set_si (result->shape[0], ncopies);
for (i = 0; i < ncopies; ++i)
gfc_append_constructor (result, gfc_copy_expr (source));
}
else if (source->expr_type == EXPR_ARRAY)
{
int result_size, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
gfc_constructor *ctor, *source_ctor, *result_ctor;
gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
gcc_assert (dim >= 0 && dim <= source->rank);
result = gfc_start_constructor (source->ts.type,
source->ts.kind,
&source->where);
result->rank = source->rank + 1;
result->shape = gfc_get_shape (result->rank);
result_size = 1;
for (i = 0, j = 0; i < result->rank; ++i)
{
if (i != dim)
mpz_init_set (result->shape[i], source->shape[j++]);
else
mpz_init_set_si (result->shape[i], ncopies);
extent[i] = mpz_get_si (result->shape[i]);
rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
result_size *= extent[i];
}
for (i = 0; i < result_size; ++i)
gfc_append_constructor (result, NULL);
source_ctor = source->value.constructor;
result_ctor = result->value.constructor;
while (source_ctor)
{
ctor = result_ctor;
for (i = 0; i < ncopies; ++i)
{
ctor->expr = gfc_copy_expr (source_ctor->expr);
ADVANCE (ctor, rstride[dim]);
}
ADVANCE (result_ctor, (dim == 0 ? ncopies : 1));
ADVANCE (source_ctor, 1);
}
}
else
/* FIXME: Returning here avoids a regression in array_simplify_1.f90.
Replace NULL with gcc_unreachable() after implementing
gfc_simplify_cshift(). */
return NULL;
if (source->ts.type == BT_CHARACTER)
result->ts.cl = source->ts.cl;
return result;
}
gfc_expr *
gfc_simplify_sqrt (gfc_expr *e)
{
@ -5431,6 +5524,54 @@ gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
}
gfc_expr *
gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
{
gfc_expr *result, *e;
gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
if (!is_constant_array_expr (vector)
|| !is_constant_array_expr (mask)
|| (!gfc_is_constant_expr (field)
&& !is_constant_array_expr(field)))
return NULL;
result = gfc_start_constructor (vector->ts.type,
vector->ts.kind,
&vector->where);
result->rank = mask->rank;
result->shape = gfc_copy_shape (mask->shape, mask->rank);
if (vector->ts.type == BT_CHARACTER)
result->ts.cl = vector->ts.cl;
vector_ctor = vector->value.constructor;
mask_ctor = mask->value.constructor;
field_ctor = field->expr_type == EXPR_ARRAY ? field->value.constructor : NULL;
while (mask_ctor)
{
if (mask_ctor->expr->value.logical)
{
gcc_assert (vector_ctor);
e = gfc_copy_expr (vector_ctor->expr);
ADVANCE (vector_ctor, 1);
}
else if (field->expr_type == EXPR_ARRAY)
e = gfc_copy_expr (field_ctor->expr);
else
e = gfc_copy_expr (field);
gfc_append_constructor (result, e);
ADVANCE (mask_ctor, 1);
ADVANCE (field_ctor, 1);
}
return result;
}
gfc_expr *
gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
{

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
2009-06-07 Daniel Franke <franke.daniel@gmail.com>
PR fortran/25104
PR fortran/29962
* gfortran.dg/spread_init_expr.f03: New.
* gfortran.dg/unpack_init_expr.f03: New.
* gfortran.dg/intrinsic_argument_conformance_2.f90: Adjusted
error message.
2009-06-07 Daniel Franke <franke.daniel@gmail.com>
PR fortran/25104

4
gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
View File

@ -39,6 +39,6 @@ program main
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(unpack(tempv,tempv(1:0)/=0,tempv) /= -47)) call abort() ! { dg-error "Different shape" }
if (any(unpack(tempv(5:4),tempv(1:0)/=0,tempv) /= -47)) call abort() ! { dg-error "Different shape" }
if (any(unpack(tempv,tempv(1:0)/=0,tempv) /= -47)) call abort() ! { dg-error "must have identical shape" }
if (any(unpack(tempv(5:4),tempv(1:0)/=0,tempv) /= -47)) call abort() ! { dg-error "must have identical shape" }
end program main

17
gcc/testsuite/gfortran.dg/spread_init_expr.f03 Normal file
View File

@ -0,0 +1,17 @@
! { dg-do "run" }
INTEGER, PARAMETER :: n = 5
INTEGER, PARAMETER :: a1(n) = SPREAD(1, 1, n)
INTEGER, PARAMETER :: a2(n, 3) = SPREAD([1,2,3], DIM=1, NCOPIES=n)
INTEGER, PARAMETER :: a3(3, n) = SPREAD([1,2,3], DIM=2, NCOPIES=n)
IF (ANY(a1 /= [ 1, 1, 1, 1, 1 ])) CALL abort()
IF (ANY(a2(:, 1) /= 1)) CALL abort()
IF (ANY(a2(:, 2) /= 2)) CALL abort()
IF (ANY(a2(:, 3) /= 3)) CALL abort()
IF (ANY(a3(1, :) /= 1)) CALL abort()
IF (ANY(a3(2, :) /= 2)) CALL abort()
IF (ANY(a3(3, :) /= 3)) CALL abort()
END

15
gcc/testsuite/gfortran.dg/unpack_init_expr.f03 Normal file
View File

@ -0,0 +1,15 @@
! { dg-do "run" }
!
! Example from F2003, sec 13.7.125
!
INTEGER, PARAMETER :: m(3,3) = RESHAPE ([1,0,0,0,1,0,0,0,1], [3,3])
INTEGER, PARAMETER :: v(3) = [1,2,3]
LOGICAL, PARAMETER :: F = .FALSE., T = .TRUE.
LOGICAL, PARAMETER :: q(3,3) = RESHAPE ([F,T,F,T,F,F,F,F,T], [3,3])
INTEGER, PARAMETER :: r1(3,3) = UNPACK (V, MASK=Q, FIELD=M)
INTEGER, PARAMETER :: r2(3,3) = UNPACK (V, MASK=Q, FIELD=0)
IF (ANY (r1 /= RESHAPE ([1,1,0,2,1,0,0,0,3], [3,3]))) CALL ABORT()
IF (ANY (r2 /= RESHAPE ([0,1,0,2,0,0,0,0,3], [3,3]))) CALL ABORT()
END