allocate_alloc_opt_4.f90: New test.
2009-08-22 Steven K. kargl <kargl@gcc.gnu.org> * gfortran.dg/allocate_alloc_opt_4.f90: New test. * gfortran.dg/allocate_alloc_opt_5.f90: New test. * gfortran.dg/allocate_alloc_opt_6.f90: New test. 2009-08-22 Steven K. kargl <kargl@gcc.gnu.org> * fortran/decl.c (match_char_spec): Rename to gfc_match_char_spec, and remove static. * fortran/gfortran.h: Add *expr3 entity to gfc_code. Add prototype for gfc_match_char_spec. * fortran/trans-stmt.c (gfc_trans_allocate): Translate the SOURCE= tag. * fortran/match.c (match_intrinsic_typespec): New function to match F2003 intrinsic-type-spec. (conformable_arrays): New function. Check SOURCE= and allocation-object are conformable. (gfc_match_allocate): Use new functions. Match SOURCE= tag. From-SVN: r151023
This commit is contained in:
Steven G. Kargl
parent
e25b7843ec
commit
8234e5e0e2
|
|
@ -1,3 +1,17 @@
|
|||
2009-08-22 Steven K. kargl <kargl@gcc.gnu.org>
|
||||
|
||||
* fortran/decl.c (match_char_spec): Rename to gfc_match_char_spec,
|
||||
and remove static.
|
||||
* fortran/gfortran.h: Add *expr3 entity to gfc_code. Add prototype
|
||||
for gfc_match_char_spec.
|
||||
* fortran/trans-stmt.c (gfc_trans_allocate): Translate the SOURCE=
|
||||
tag.
|
||||
* fortran/match.c (match_intrinsic_typespec): New function to match
|
||||
F2003 intrinsic-type-spec.
|
||||
(conformable_arrays): New function. Check SOURCE= and
|
||||
allocation-object are conformable.
|
||||
(gfc_match_allocate): Use new functions. Match SOURCE= tag.
|
||||
|
||||
2009-08-22 Bud Davis <bdavis9659@sbcglobal.net>
|
||||
|
||||
PR fortran/28093
|
||||
|
|
|
|||
|
|
@ -2104,11 +2104,12 @@ no_match:
|
|||
return m;
|
||||
}
|
||||
|
||||
|
||||
/* Match the various kind/length specifications in a CHARACTER
|
||||
declaration. We don't return MATCH_NO. */
|
||||
|
||||
static match
|
||||
match_char_spec (gfc_typespec *ts)
|
||||
match
|
||||
gfc_match_char_spec (gfc_typespec *ts)
|
||||
{
|
||||
int kind, seen_length, is_iso_c;
|
||||
gfc_charlen *cl;
|
||||
|
|
@ -2324,7 +2325,7 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
|
|||
{
|
||||
ts->type = BT_CHARACTER;
|
||||
if (implicit_flag == 0)
|
||||
return match_char_spec (ts);
|
||||
return gfc_match_char_spec (ts);
|
||||
else
|
||||
return MATCH_YES;
|
||||
}
|
||||
|
|
@ -2636,7 +2637,7 @@ gfc_match_implicit (void)
|
|||
|
||||
/* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
|
||||
if (ts.type == BT_CHARACTER)
|
||||
m = match_char_spec (&ts);
|
||||
m = gfc_match_char_spec (&ts);
|
||||
else
|
||||
{
|
||||
m = gfc_match_kind_spec (&ts, false);
|
||||
|
|
|
|||
|
|
@ -1977,7 +1977,7 @@ typedef struct gfc_code
|
|||
|
||||
gfc_st_label *here, *label1, *label2, *label3;
|
||||
gfc_symtree *symtree;
|
||||
gfc_expr *expr1, *expr2;
|
||||
gfc_expr *expr1, *expr2, *expr3;
|
||||
/* A name isn't sufficient to identify a subroutine, we need the actual
|
||||
symbol for the interface definition.
|
||||
const char *sub_name; */
|
||||
|
|
@ -2184,6 +2184,7 @@ gfc_finalizer;
|
|||
|
||||
/* decl.c */
|
||||
bool gfc_in_match_data (void);
|
||||
match gfc_match_char_spec (gfc_typespec *);
|
||||
|
||||
/* scanner.c */
|
||||
void gfc_scanner_done_1 (void);
|
||||
|
|
|
|||
|
|
@ -2221,23 +2221,186 @@ gfc_free_alloc_list (gfc_alloc *p)
|
|||
}
|
||||
|
||||
|
||||
/* Match a Fortran 2003 intrinsic-type-spec. This is a stripped
|
||||
down version of gfc_match_type_spec() from decl.c. It only includes
|
||||
the intrinsic types from the Fortran 2003 standard. Thus, neither
|
||||
BYTE nor forms like REAL*4 are allowed. Additionally, the implicit_flag
|
||||
is not needed, so it was removed. The handling of derived types has
|
||||
been removed and no notion of the gfc_matching_function state
|
||||
is needed. In short, this functions matches only standard conforming
|
||||
intrinsic-type-spec (R403). */
|
||||
|
||||
static match
|
||||
match_intrinsic_typespec (gfc_typespec *ts)
|
||||
{
|
||||
match m;
|
||||
|
||||
gfc_clear_ts (ts);
|
||||
|
||||
if (gfc_match ("integer") == MATCH_YES)
|
||||
{
|
||||
ts->type = BT_INTEGER;
|
||||
ts->kind = gfc_default_integer_kind;
|
||||
goto kind_selector;
|
||||
}
|
||||
|
||||
if (gfc_match ("real") == MATCH_YES)
|
||||
{
|
||||
ts->type = BT_REAL;
|
||||
ts->kind = gfc_default_real_kind;
|
||||
goto kind_selector;
|
||||
}
|
||||
|
||||
if (gfc_match ("double precision") == MATCH_YES)
|
||||
{
|
||||
ts->type = BT_REAL;
|
||||
ts->kind = gfc_default_double_kind;
|
||||
return MATCH_YES;
|
||||
}
|
||||
|
||||
if (gfc_match ("complex") == MATCH_YES)
|
||||
{
|
||||
ts->type = BT_COMPLEX;
|
||||
ts->kind = gfc_default_complex_kind;
|
||||
goto kind_selector;
|
||||
}
|
||||
|
||||
if (gfc_match ("character") == MATCH_YES)
|
||||
{
|
||||
ts->type = BT_CHARACTER;
|
||||
goto char_selector;
|
||||
}
|
||||
|
||||
if (gfc_match ("logical") == MATCH_YES)
|
||||
{
|
||||
ts->type = BT_LOGICAL;
|
||||
ts->kind = gfc_default_logical_kind;
|
||||
goto kind_selector;
|
||||
}
|
||||
|
||||
/* If an intrinsic type is not matched, simply return MATCH_NO. */
|
||||
return MATCH_NO;
|
||||
|
||||
kind_selector:
|
||||
|
||||
gfc_gobble_whitespace ();
|
||||
if (gfc_peek_ascii_char () == '*')
|
||||
{
|
||||
gfc_error ("Invalid type-spec at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
m = gfc_match_kind_spec (ts, false);
|
||||
|
||||
if (m == MATCH_NO)
|
||||
m = MATCH_YES; /* No kind specifier found. */
|
||||
|
||||
return m;
|
||||
|
||||
char_selector:
|
||||
|
||||
m = gfc_match_char_spec (ts);
|
||||
|
||||
if (m == MATCH_NO)
|
||||
m = MATCH_YES; /* No kind specifier found. */
|
||||
|
||||
return m;
|
||||
}
|
||||
|
||||
|
||||
/* Used in gfc_match_allocate to check that a allocation-object and
|
||||
a source-expr are conformable. This does not catch all possible
|
||||
cases; in particular a runtime checking is needed. */
|
||||
|
||||
static gfc_try
|
||||
conformable_arrays (gfc_expr *e1, gfc_expr *e2)
|
||||
{
|
||||
/* First compare rank. */
|
||||
if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
|
||||
{
|
||||
gfc_error ("Source-expr at %L must be scalar or have the "
|
||||
"same rank as the allocate-object at %L",
|
||||
&e1->where, &e2->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
if (e1->shape)
|
||||
{
|
||||
int i;
|
||||
mpz_t s;
|
||||
|
||||
mpz_init (s);
|
||||
|
||||
for (i = 0; i < e1->rank; i++)
|
||||
{
|
||||
if (e2->ref->u.ar.end[i])
|
||||
{
|
||||
mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
|
||||
mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
|
||||
mpz_add_ui (s, s, 1);
|
||||
}
|
||||
else
|
||||
{
|
||||
mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
|
||||
}
|
||||
|
||||
if (mpz_cmp (e1->shape[i], s) != 0)
|
||||
{
|
||||
gfc_error ("Source-expr at %L and allocate-object at %L must "
|
||||
"have the same shape", &e1->where, &e2->where);
|
||||
mpz_clear (s);
|
||||
return FAILURE;
|
||||
}
|
||||
}
|
||||
|
||||
mpz_clear (s);
|
||||
}
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
/* Match an ALLOCATE statement. */
|
||||
|
||||
match
|
||||
gfc_match_allocate (void)
|
||||
{
|
||||
gfc_alloc *head, *tail;
|
||||
gfc_expr *stat, *errmsg, *tmp;
|
||||
gfc_expr *stat, *errmsg, *tmp, *source;
|
||||
gfc_typespec ts;
|
||||
match m;
|
||||
bool saw_stat, saw_errmsg;
|
||||
locus old_locus;
|
||||
bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
|
||||
|
||||
head = tail = NULL;
|
||||
stat = errmsg = tmp = NULL;
|
||||
saw_stat = saw_errmsg = false;
|
||||
stat = errmsg = source = tmp = NULL;
|
||||
saw_stat = saw_errmsg = saw_source = false;
|
||||
|
||||
if (gfc_match_char ('(') != MATCH_YES)
|
||||
goto syntax;
|
||||
|
||||
/* Match an optional intrinsic-type-spec. */
|
||||
old_locus = gfc_current_locus;
|
||||
m = match_intrinsic_typespec (&ts);
|
||||
if (m == MATCH_ERROR)
|
||||
goto cleanup;
|
||||
else if (m == MATCH_NO)
|
||||
ts.type = BT_UNKNOWN;
|
||||
else
|
||||
{
|
||||
if (gfc_match (" :: ") == MATCH_YES)
|
||||
{
|
||||
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
|
||||
"ALLOCATE at %L", &old_locus) == FAILURE)
|
||||
goto cleanup;
|
||||
}
|
||||
else
|
||||
{
|
||||
ts.type = BT_UNKNOWN;
|
||||
gfc_current_locus = old_locus;
|
||||
}
|
||||
}
|
||||
|
||||
for (;;)
|
||||
{
|
||||
if (head == NULL)
|
||||
|
|
@ -2263,17 +2426,46 @@ gfc_match_allocate (void)
|
|||
goto cleanup;
|
||||
}
|
||||
|
||||
/* The ALLOCATE statement had an optional typespec. Check the
|
||||
constraints. */
|
||||
if (ts.type != BT_UNKNOWN)
|
||||
{
|
||||
/* Enforce C626. */
|
||||
if (ts.type != tail->expr->ts.type)
|
||||
{
|
||||
gfc_error ("Type of entity at %L is type incompatible with "
|
||||
"typespec", &tail->expr->where);
|
||||
goto cleanup;
|
||||
}
|
||||
|
||||
/* Enforce C627. */
|
||||
if (ts.kind != tail->expr->ts.kind)
|
||||
{
|
||||
gfc_error ("Kind type parameter for entity at %L differs from "
|
||||
"the kind type parameter of the typespec",
|
||||
&tail->expr->where);
|
||||
goto cleanup;
|
||||
}
|
||||
}
|
||||
|
||||
if (tail->expr->ts.type == BT_DERIVED)
|
||||
tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
|
||||
|
||||
/* FIXME: disable the checking on derived types and arrays. */
|
||||
if (!(tail->expr->ref
|
||||
b1 = !(tail->expr->ref
|
||||
&& (tail->expr->ref->type == REF_COMPONENT
|
||||
|| tail->expr->ref->type == REF_ARRAY))
|
||||
&& tail->expr->symtree->n.sym
|
||||
&& !(tail->expr->symtree->n.sym->attr.allocatable
|
||||
|| tail->expr->symtree->n.sym->attr.pointer
|
||||
|| tail->expr->symtree->n.sym->attr.proc_pointer))
|
||||
|| tail->expr->ref->type == REF_ARRAY));
|
||||
b2 = tail->expr->symtree->n.sym
|
||||
&& !(tail->expr->symtree->n.sym->attr.allocatable
|
||||
|| tail->expr->symtree->n.sym->attr.pointer
|
||||
|| tail->expr->symtree->n.sym->attr.proc_pointer);
|
||||
b3 = tail->expr->symtree->n.sym
|
||||
&& tail->expr->symtree->n.sym->ns
|
||||
&& tail->expr->symtree->n.sym->ns->proc_name
|
||||
&& (tail->expr->symtree->n.sym->ns->proc_name->attr.allocatable
|
||||
|| tail->expr->symtree->n.sym->ns->proc_name->attr.pointer
|
||||
|| tail->expr->symtree->n.sym->ns->proc_name->attr.proc_pointer);
|
||||
if (b1 && b2 && !b3)
|
||||
{
|
||||
gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
|
||||
"or an allocatable variable");
|
||||
|
|
@ -2290,10 +2482,10 @@ alloc_opt_list:
|
|||
goto cleanup;
|
||||
if (m == MATCH_YES)
|
||||
{
|
||||
/* Enforce C630. */
|
||||
if (saw_stat)
|
||||
{
|
||||
gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
|
||||
gfc_free_expr (tmp);
|
||||
goto cleanup;
|
||||
}
|
||||
|
||||
|
|
@ -2312,14 +2504,14 @@ alloc_opt_list:
|
|||
goto cleanup;
|
||||
if (m == MATCH_YES)
|
||||
{
|
||||
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
|
||||
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
|
||||
&tmp->where) == FAILURE)
|
||||
goto cleanup;
|
||||
|
||||
/* Enforce C630. */
|
||||
if (saw_errmsg)
|
||||
{
|
||||
gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
|
||||
gfc_free_expr (tmp);
|
||||
goto cleanup;
|
||||
}
|
||||
|
||||
|
|
@ -2330,6 +2522,66 @@ alloc_opt_list:
|
|||
goto alloc_opt_list;
|
||||
}
|
||||
|
||||
m = gfc_match (" source = %e", &tmp);
|
||||
if (m == MATCH_ERROR)
|
||||
goto cleanup;
|
||||
if (m == MATCH_YES)
|
||||
{
|
||||
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
|
||||
&tmp->where) == FAILURE)
|
||||
goto cleanup;
|
||||
|
||||
/* Enforce C630. */
|
||||
if (saw_source)
|
||||
{
|
||||
gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
|
||||
goto cleanup;
|
||||
}
|
||||
|
||||
/* The next 3 conditionals check C631. */
|
||||
if (ts.type != BT_UNKNOWN)
|
||||
{
|
||||
gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
|
||||
&tmp->where, &old_locus);
|
||||
goto cleanup;
|
||||
}
|
||||
|
||||
if (head->next)
|
||||
{
|
||||
gfc_error ("SOURCE tag at %L requires only a single entity in "
|
||||
"the allocation-list", &tmp->where);
|
||||
goto cleanup;
|
||||
}
|
||||
|
||||
gfc_resolve_expr (tmp);
|
||||
|
||||
if (head->expr->ts.type != tmp->ts.type)
|
||||
{
|
||||
gfc_error ("Type of entity at %L is type incompatible with "
|
||||
"source-expr at %L", &head->expr->where, &tmp->where);
|
||||
goto cleanup;
|
||||
}
|
||||
|
||||
/* Check C633. */
|
||||
if (tmp->ts.kind != head->expr->ts.kind)
|
||||
{
|
||||
gfc_error ("The allocate-object at %L and the source-expr at %L "
|
||||
"shall have the same kind type parameter",
|
||||
&head->expr->where, &tmp->where);
|
||||
goto cleanup;
|
||||
}
|
||||
|
||||
/* Check C632 and restriction following Note 6.18. */
|
||||
if (tmp->rank > 0 && conformable_arrays (tmp, head->expr) == FAILURE)
|
||||
goto cleanup;
|
||||
|
||||
source = tmp;
|
||||
saw_source = true;
|
||||
|
||||
if (gfc_match_char (',') == MATCH_YES)
|
||||
goto alloc_opt_list;
|
||||
}
|
||||
|
||||
gfc_gobble_whitespace ();
|
||||
|
||||
if (gfc_peek_char () == ')')
|
||||
|
|
@ -2343,6 +2595,7 @@ alloc_opt_list:
|
|||
new_st.op = EXEC_ALLOCATE;
|
||||
new_st.expr1 = stat;
|
||||
new_st.expr2 = errmsg;
|
||||
new_st.expr3 = source;
|
||||
new_st.ext.alloc_list = head;
|
||||
|
||||
return MATCH_YES;
|
||||
|
|
@ -2352,7 +2605,9 @@ syntax:
|
|||
|
||||
cleanup:
|
||||
gfc_free_expr (errmsg);
|
||||
gfc_free_expr (source);
|
||||
gfc_free_expr (stat);
|
||||
gfc_free_expr (tmp);
|
||||
gfc_free_alloc_list (head);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4081,6 +4081,44 @@ gfc_trans_allocate (gfc_code * code)
|
|||
gfc_add_expr_to_block (&block, tmp);
|
||||
}
|
||||
|
||||
/* SOURCE block. Note, by C631, we know that code->ext.alloc_list
|
||||
has a single entity. */
|
||||
if (code->expr3)
|
||||
{
|
||||
gfc_ref *ref;
|
||||
gfc_array_ref *ar;
|
||||
int n;
|
||||
|
||||
/* If there is a terminating array reference, this is converted
|
||||
to a full array, so that gfc_trans_assignment can scalarize the
|
||||
expression for the source. */
|
||||
for (ref = code->ext.alloc_list->expr->ref; ref; ref = ref->next)
|
||||
{
|
||||
if (ref->next == NULL)
|
||||
{
|
||||
if (ref->type != REF_ARRAY)
|
||||
break;
|
||||
|
||||
ref->u.ar.type = AR_FULL;
|
||||
ar = &ref->u.ar;
|
||||
ar->dimen = ar->as->rank;
|
||||
for (n = 0; n < ar->dimen; n++)
|
||||
{
|
||||
ar->dimen_type[n] = DIMEN_RANGE;
|
||||
gfc_free_expr (ar->start[n]);
|
||||
gfc_free_expr (ar->end[n]);
|
||||
gfc_free_expr (ar->stride[n]);
|
||||
ar->start[n] = NULL;
|
||||
ar->end[n] = NULL;
|
||||
ar->stride[n] = NULL;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
tmp = gfc_trans_assignment (code->ext.alloc_list->expr, code->expr3, false);
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
}
|
||||
|
||||
return gfc_finish_block (&block);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,14 @@
|
|||
2009-08-22 Steven K. kargl <kargl@gcc.gnu.org>
|
||||
|
||||
* gfortran.dg/allocate_alloc_opt_4.f90: New test.
|
||||
* gfortran.dg/allocate_alloc_opt_5.f90: New test.
|
||||
* gfortran.dg/allocate_alloc_opt_6.f90: New test.
|
||||
|
||||
2009-08-22 Bud Davis <bdavis9659@sbcglobal.net>
|
||||
|
||||
PR fortran/28039
|
||||
* gfortran.dg/fmt_with_extra.f: new file.
|
||||
|
||||
2009-08-21 Maciej W. Rozycki <macro@codesourcery.com>
|
||||
|
||||
* lib/target-supports.exp
|
||||
|
|
|
|||
|
|
@ -0,0 +1,27 @@
|
|||
! { dg-do compile }
|
||||
program a
|
||||
|
||||
implicit none
|
||||
|
||||
integer n, m(3,3)
|
||||
integer(kind=8) k
|
||||
integer, allocatable :: i(:), j(:)
|
||||
real, allocatable :: x(:)
|
||||
|
||||
n = 42
|
||||
m = n
|
||||
k = 1_8
|
||||
|
||||
allocate(i(4), source=42, source=n) ! { dg-error "Redundant SOURCE tag found" }
|
||||
|
||||
allocate(integer(4) :: i(4), source=n) ! { dg-error "conflicts with the typespec" }
|
||||
|
||||
allocate(i(4), j(n), source=n) ! { dg-error "requires only a single entity" }
|
||||
|
||||
allocate(x(4), source=n) ! { dg-error "type incompatible with" }
|
||||
|
||||
allocate(i(4), source=m) ! { dg-error "must be scalar or have the same rank" }
|
||||
|
||||
allocate(i(4), source=k) ! { dg-error "shall have the same kind type" }
|
||||
|
||||
end program a
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "-std=f95" }
|
||||
program a
|
||||
|
||||
implicit none
|
||||
|
||||
integer n
|
||||
character(len=70) str
|
||||
integer, allocatable :: i(:)
|
||||
|
||||
n = 42
|
||||
allocate(i(4), source=n) ! { dg-error "Fortran 2003: SOURCE tag" }
|
||||
allocate(i(4), stat=n, errmsg=str) ! { dg-error "Fortran 2003: ERRMSG tag" }
|
||||
|
||||
end program a
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
! { dg-do run }
|
||||
program a
|
||||
|
||||
implicit none
|
||||
|
||||
type :: mytype
|
||||
real :: r
|
||||
integer :: i
|
||||
end type mytype
|
||||
|
||||
integer n
|
||||
integer, allocatable :: i(:)
|
||||
real z
|
||||
real, allocatable :: x(:)
|
||||
type(mytype), pointer :: t
|
||||
|
||||
n = 42
|
||||
z = 99.
|
||||
|
||||
allocate(i(4), source=n)
|
||||
if (any(i /= 42)) call abort
|
||||
|
||||
allocate(x(4), source=z)
|
||||
if (any(x /= 99.)) call abort
|
||||
|
||||
allocate(t, source=mytype(1.0,2))
|
||||
if (t%r /= 1. .or. t%i /= 2) call abort
|
||||
|
||||
deallocate(i)
|
||||
allocate(i(3), source=(/1, 2, 3/))
|
||||
if (i(1) /= 1 .or. i(2) /= 2 .or. i(3) /= 3) call abort
|
||||
|
||||
call sub1(i)
|
||||
|
||||
end program a
|
||||
|
||||
subroutine sub1(j)
|
||||
integer, intent(in) :: j(*)
|
||||
integer, allocatable :: k(:)
|
||||
allocate(k(2), source=j(1:2))
|
||||
if (k(1) /= 1 .or. k(2) /= 2) call abort
|
||||
end subroutine sub1
|
||||
Loading…
Reference in New Issue