gfortran.h (array_type): New type `AS_IMPLIED_SHAPE'.
2010-08-13 Daniel Kraft <d@domob.eu> * gfortran.h (array_type): New type `AS_IMPLIED_SHAPE'. * array.c (gfc_match_array_spec): Match implied-shape specification and handle AS_IMPLIED_SHAPE correctly otherwise. * decl.c (add_init_expr_to_sym): Set upper bounds for implied-shape. (variable_decl): Some checks for implied-shape declaration. * resolve.c (resolve_symbol): Assert that array-spec is no longer AS_IMPLIED_SHAPE in any case. 2010-08-13 Daniel Kraft <d@domob.eu> * gfortran.dg/implied_shape_1.f08: New test. * gfortran.dg/implied_shape_2.f90: New test. * gfortran.dg/implied_shape_3.f08: New test. From-SVN: r163221
This commit is contained in:
parent
cf677bb867
commit
f5ca06e678
|
@ -1,3 +1,13 @@
|
||||||
|
2010-08-13 Daniel Kraft <d@domob.eu>
|
||||||
|
|
||||||
|
* gfortran.h (array_type): New type `AS_IMPLIED_SHAPE'.
|
||||||
|
* array.c (gfc_match_array_spec): Match implied-shape specification and
|
||||||
|
handle AS_IMPLIED_SHAPE correctly otherwise.
|
||||||
|
* decl.c (add_init_expr_to_sym): Set upper bounds for implied-shape.
|
||||||
|
(variable_decl): Some checks for implied-shape declaration.
|
||||||
|
* resolve.c (resolve_symbol): Assert that array-spec is no longer
|
||||||
|
AS_IMPLIED_SHAPE in any case.
|
||||||
|
|
||||||
2010-08-12 Joseph Myers <joseph@codesourcery.com>
|
2010-08-12 Joseph Myers <joseph@codesourcery.com>
|
||||||
|
|
||||||
* lang.opt (MD, MMD): Change to MDX and MMDX.
|
* lang.opt (MD, MMD): Change to MDX and MMDX.
|
||||||
|
|
|
@ -463,6 +463,12 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
|
||||||
as->rank++;
|
as->rank++;
|
||||||
current_type = match_array_element_spec (as);
|
current_type = match_array_element_spec (as);
|
||||||
|
|
||||||
|
/* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
|
||||||
|
and implied-shape specifications. If the rank is at least 2, we can
|
||||||
|
distinguish between them. But for rank 1, we currently return
|
||||||
|
ASSUMED_SIZE; this gets adjusted later when we know for sure
|
||||||
|
whether the symbol parsed is a PARAMETER or not. */
|
||||||
|
|
||||||
if (as->rank == 1)
|
if (as->rank == 1)
|
||||||
{
|
{
|
||||||
if (current_type == AS_UNKNOWN)
|
if (current_type == AS_UNKNOWN)
|
||||||
|
@ -475,6 +481,15 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
|
||||||
case AS_UNKNOWN:
|
case AS_UNKNOWN:
|
||||||
goto cleanup;
|
goto cleanup;
|
||||||
|
|
||||||
|
case AS_IMPLIED_SHAPE:
|
||||||
|
if (current_type != AS_ASSUMED_SHAPE)
|
||||||
|
{
|
||||||
|
gfc_error ("Bad array specification for implied-shape"
|
||||||
|
" array at %C");
|
||||||
|
goto cleanup;
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
|
||||||
case AS_EXPLICIT:
|
case AS_EXPLICIT:
|
||||||
if (current_type == AS_ASSUMED_SIZE)
|
if (current_type == AS_ASSUMED_SIZE)
|
||||||
{
|
{
|
||||||
|
@ -513,6 +528,12 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
|
||||||
goto cleanup;
|
goto cleanup;
|
||||||
|
|
||||||
case AS_ASSUMED_SIZE:
|
case AS_ASSUMED_SIZE:
|
||||||
|
if (as->rank == 2 && current_type == AS_ASSUMED_SIZE)
|
||||||
|
{
|
||||||
|
as->type = AS_IMPLIED_SHAPE;
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
|
||||||
gfc_error ("Bad specification for assumed size array at %C");
|
gfc_error ("Bad specification for assumed size array at %C");
|
||||||
goto cleanup;
|
goto cleanup;
|
||||||
}
|
}
|
||||||
|
@ -570,6 +591,7 @@ coarray:
|
||||||
else
|
else
|
||||||
switch (as->cotype)
|
switch (as->cotype)
|
||||||
{ /* See how current spec meshes with the existing. */
|
{ /* See how current spec meshes with the existing. */
|
||||||
|
case AS_IMPLIED_SHAPE:
|
||||||
case AS_UNKNOWN:
|
case AS_UNKNOWN:
|
||||||
goto cleanup;
|
goto cleanup;
|
||||||
|
|
||||||
|
|
|
@ -1378,6 +1378,51 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/* If sym is implied-shape, set its upper bounds from init. */
|
||||||
|
if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
|
||||||
|
&& sym->as->type == AS_IMPLIED_SHAPE)
|
||||||
|
{
|
||||||
|
int dim;
|
||||||
|
|
||||||
|
if (init->rank == 0)
|
||||||
|
{
|
||||||
|
gfc_error ("Can't initialize implied-shape array at %L"
|
||||||
|
" with scalar", &sym->declared_at);
|
||||||
|
return FAILURE;
|
||||||
|
}
|
||||||
|
gcc_assert (sym->as->rank == init->rank);
|
||||||
|
|
||||||
|
/* Shape should be present, we get an initialization expression. */
|
||||||
|
gcc_assert (init->shape);
|
||||||
|
|
||||||
|
for (dim = 0; dim < sym->as->rank; ++dim)
|
||||||
|
{
|
||||||
|
int k;
|
||||||
|
gfc_expr* lower;
|
||||||
|
gfc_expr* e;
|
||||||
|
|
||||||
|
lower = sym->as->lower[dim];
|
||||||
|
if (lower->expr_type != EXPR_CONSTANT)
|
||||||
|
{
|
||||||
|
gfc_error ("Non-constant lower bound in implied-shape"
|
||||||
|
" declaration at %L", &lower->where);
|
||||||
|
return FAILURE;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* All dimensions must be without upper bound. */
|
||||||
|
gcc_assert (!sym->as->upper[dim]);
|
||||||
|
|
||||||
|
k = lower->ts.kind;
|
||||||
|
e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
|
||||||
|
mpz_add (e->value.integer,
|
||||||
|
lower->value.integer, init->shape[dim]);
|
||||||
|
mpz_sub_ui (e->value.integer, e->value.integer, 1);
|
||||||
|
sym->as->upper[dim] = e;
|
||||||
|
}
|
||||||
|
|
||||||
|
sym->as->type = AS_EXPLICIT;
|
||||||
|
}
|
||||||
|
|
||||||
/* Need to check if the expression we initialized this
|
/* Need to check if the expression we initialized this
|
||||||
to was one of the iso_c_binding named constants. If so,
|
to was one of the iso_c_binding named constants. If so,
|
||||||
and we're a parameter (constant), let it be iso_c.
|
and we're a parameter (constant), let it be iso_c.
|
||||||
|
@ -1650,6 +1695,34 @@ variable_decl (int elem)
|
||||||
else if (current_as)
|
else if (current_as)
|
||||||
merge_array_spec (current_as, as, true);
|
merge_array_spec (current_as, as, true);
|
||||||
|
|
||||||
|
/* At this point, we know for sure if the symbol is PARAMETER and can thus
|
||||||
|
determine (and check) whether it can be implied-shape. If it
|
||||||
|
was parsed as assumed-size, change it because PARAMETERs can not
|
||||||
|
be assumed-size. */
|
||||||
|
if (as)
|
||||||
|
{
|
||||||
|
if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
|
||||||
|
{
|
||||||
|
m = MATCH_ERROR;
|
||||||
|
gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
|
||||||
|
name, &var_locus);
|
||||||
|
goto cleanup;
|
||||||
|
}
|
||||||
|
|
||||||
|
if (as->type == AS_ASSUMED_SIZE && as->rank == 1
|
||||||
|
&& current_attr.flavor == FL_PARAMETER)
|
||||||
|
as->type = AS_IMPLIED_SHAPE;
|
||||||
|
|
||||||
|
if (as->type == AS_IMPLIED_SHAPE
|
||||||
|
&& gfc_notify_std (GFC_STD_F2008,
|
||||||
|
"Fortran 2008: Implied-shape array at %L",
|
||||||
|
&var_locus) == FAILURE)
|
||||||
|
{
|
||||||
|
m = MATCH_ERROR;
|
||||||
|
goto cleanup;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
char_len = NULL;
|
char_len = NULL;
|
||||||
cl = NULL;
|
cl = NULL;
|
||||||
|
|
||||||
|
|
|
@ -157,7 +157,7 @@ expr_t;
|
||||||
/* Array types. */
|
/* Array types. */
|
||||||
typedef enum
|
typedef enum
|
||||||
{ AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED,
|
{ AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED,
|
||||||
AS_ASSUMED_SIZE, AS_UNKNOWN
|
AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_UNKNOWN
|
||||||
}
|
}
|
||||||
array_type;
|
array_type;
|
||||||
|
|
||||||
|
|
|
@ -11673,20 +11673,24 @@ resolve_symbol (gfc_symbol *sym)
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Assumed size arrays and assumed shape arrays must be dummy
|
/* Assumed size arrays and assumed shape arrays must be dummy
|
||||||
arguments. */
|
arguments. Array-spec's of implied-shape should have been resolved to
|
||||||
|
AS_EXPLICIT already. */
|
||||||
|
|
||||||
if (sym->as != NULL
|
if (sym->as)
|
||||||
&& ((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
|
|
||||||
|| sym->as->type == AS_ASSUMED_SHAPE)
|
|
||||||
&& sym->attr.dummy == 0)
|
|
||||||
{
|
{
|
||||||
if (sym->as->type == AS_ASSUMED_SIZE)
|
gcc_assert (sym->as->type != AS_IMPLIED_SHAPE);
|
||||||
gfc_error ("Assumed size array at %L must be a dummy argument",
|
if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed)
|
||||||
&sym->declared_at);
|
|| sym->as->type == AS_ASSUMED_SHAPE)
|
||||||
else
|
&& sym->attr.dummy == 0)
|
||||||
gfc_error ("Assumed shape array at %L must be a dummy argument",
|
{
|
||||||
&sym->declared_at);
|
if (sym->as->type == AS_ASSUMED_SIZE)
|
||||||
return;
|
gfc_error ("Assumed size array at %L must be a dummy argument",
|
||||||
|
&sym->declared_at);
|
||||||
|
else
|
||||||
|
gfc_error ("Assumed shape array at %L must be a dummy argument",
|
||||||
|
&sym->declared_at);
|
||||||
|
return;
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Make sure symbols with known intent or optional are really dummy
|
/* Make sure symbols with known intent or optional are really dummy
|
||||||
|
|
|
@ -1,3 +1,9 @@
|
||||||
|
2010-08-13 Daniel Kraft <d@domob.eu>
|
||||||
|
|
||||||
|
* gfortran.dg/implied_shape_1.f08: New test.
|
||||||
|
* gfortran.dg/implied_shape_2.f90: New test.
|
||||||
|
* gfortran.dg/implied_shape_3.f08: New test.
|
||||||
|
|
||||||
2010-08-12 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
2010-08-12 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
||||||
|
|
||||||
PR libfortran/42526
|
PR libfortran/42526
|
||||||
|
|
|
@ -0,0 +1,37 @@
|
||||||
|
! { dg-do run }
|
||||||
|
! { dg-options "-std=f2008 -fall-intrinsics" }
|
||||||
|
|
||||||
|
! Test for correct semantics of implied-shape arrays.
|
||||||
|
|
||||||
|
! Contributed by Daniel Kraft, d@domob.eu.
|
||||||
|
|
||||||
|
PROGRAM main
|
||||||
|
IMPLICIT NONE
|
||||||
|
|
||||||
|
INTEGER, PARAMETER :: n = 3
|
||||||
|
|
||||||
|
! Should be able to reduce complex expressions.
|
||||||
|
REAL, PARAMETER :: arr1(n:*) = SQRT ((/ 1.0, 2.0, 3.0 /)) + 42
|
||||||
|
|
||||||
|
! With dimension statement.
|
||||||
|
REAL, DIMENSION(*), PARAMETER :: arr2 = arr1
|
||||||
|
|
||||||
|
! Rank > 1.
|
||||||
|
INTEGER, PARAMETER :: arr3(n:*, *) = RESHAPE ((/ 1, 2, 3, 4 /), (/ 2, 2/))
|
||||||
|
|
||||||
|
! Character array.
|
||||||
|
CHARACTER(LEN=*), PARAMETER :: arr4(*) = (/ CHARACTER(LEN=3) :: "ab", "cde" /)
|
||||||
|
|
||||||
|
IF (LBOUND (arr1, 1) /= n .OR. UBOUND (arr1, 1) /= n + 2) CALL abort ()
|
||||||
|
IF (SIZE (arr1) /= 3) CALL abort ()
|
||||||
|
|
||||||
|
IF (LBOUND (arr2, 1) /= 1 .OR. UBOUND (arr2, 1) /= 3) CALL abort ()
|
||||||
|
IF (SIZE (arr2) /= 3) CALL abort ()
|
||||||
|
|
||||||
|
IF (ANY (LBOUND (arr3) /= (/ n, 1 /) .OR. UBOUND (arr3) /= (/ n + 1, 2 /))) &
|
||||||
|
CALL abort ()
|
||||||
|
IF (SIZE (arr3) /= 4) CALL abort ()
|
||||||
|
|
||||||
|
IF (LBOUND (arr4, 1) /= 1 .OR. UBOUND (arr4, 1) /= 2) CALL abort ()
|
||||||
|
IF (SIZE (arr4) /= 2) CALL abort ()
|
||||||
|
END PROGRAM main
|
|
@ -0,0 +1,11 @@
|
||||||
|
! { dg-do compile }
|
||||||
|
! { dg-options "-std=f95" }
|
||||||
|
|
||||||
|
! Test for rejection of implied-shape prior to Fortran 2008.
|
||||||
|
|
||||||
|
! Contributed by Daniel Kraft, d@domob.eu.
|
||||||
|
|
||||||
|
PROGRAM main
|
||||||
|
IMPLICIT NONE
|
||||||
|
INTEGER, PARAMETER :: arr(*) = (/ 2, 3, 4 /) ! { dg-error "Fortran 2008" }
|
||||||
|
END PROGRAM main
|
|
@ -0,0 +1,35 @@
|
||||||
|
! { dg-do compile }
|
||||||
|
! { dg-options "-std=f2008" }
|
||||||
|
|
||||||
|
! Test for errors with implied-shape declarations.
|
||||||
|
|
||||||
|
! Contributed by Daniel Kraft, d@domob.eu.
|
||||||
|
|
||||||
|
PROGRAM main
|
||||||
|
IMPLICIT NONE
|
||||||
|
|
||||||
|
INTEGER :: n
|
||||||
|
INTEGER, PARAMETER :: mat(2, 2) = RESHAPE ((/ 1, 2, 3, 4 /), (/ 2, 2 /))
|
||||||
|
|
||||||
|
! Malformed declaration.
|
||||||
|
INTEGER, PARAMETER :: arr1(*, *, 5) = mat ! { dg-error "Bad array specification for implied-shape array" }
|
||||||
|
|
||||||
|
! Rank mismatch in initialization.
|
||||||
|
INTEGER, PARAMETER :: arr2(*, *) = (/ 1, 2, 3, 4 /) ! { dg-error "Incompatible ranks" }
|
||||||
|
|
||||||
|
! Non-PARAMETER implied-shape, with and without initializer.
|
||||||
|
INTEGER :: arr3(*, *) ! { dg-error "Non-PARAMETER" }
|
||||||
|
INTEGER :: arr4(*, *) = mat ! { dg-error "Non-PARAMETER" }
|
||||||
|
|
||||||
|
! Missing initializer.
|
||||||
|
INTEGER, PARAMETER :: arr5(*) ! { dg-error "is missing an initializer" }
|
||||||
|
|
||||||
|
! Initialization from scalar.
|
||||||
|
INTEGER, PARAMETER :: arr6(*) = 0 ! { dg-error "with scalar" }
|
||||||
|
|
||||||
|
! Automatic bounds.
|
||||||
|
n = 2
|
||||||
|
BLOCK
|
||||||
|
INTEGER, PARAMETER :: arr7(n:*) = (/ 2, 3, 4 /) ! { dg-error "Non-constant lower bound" }
|
||||||
|
END BLOCK
|
||||||
|
END PROGRAM main
|
Loading…
Reference in New Issue