This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [fortran, 4.5] Implement errmsg for [de]allocate
On Wed, Dec 03, 2008 at 12:07:09PM -0800, Steve Kargl wrote:
> On Wed, Dec 03, 2008 at 08:28:48PM +0100, Tobias Burnus wrote:
> > Steve Kargl wrote:
> > > The attached patch implements the F2003 feature of ERRMSG= in
> > > the [DE]ALLOCATE statements. The current patch makes use of
> > > the infrastructure for STAT= to determine if a failure occurs.
> > >
> > Somehow it does not work if one additionally requests a STAT= variable:
> >
> > deallocate(x, stat=i, errmsg=err)
> > 1
> > Error: Syntax error in DEALLOCATE statement at (1)
> >
> > (Ditto for: errmsg=..., stat=...)
>
> I may have misinterpreted the 'or' in the BNF:
>
> R623 allocate-stmt is ALLOCATE ( [ type-spec :: ] allocation-list
> [, alloc-opt-list ] )
> R624 alloc-opt is STAT = stat-variable
> or ERRMSG = errmsg-variable
> or SOURCE = source-expr
>
> alloc-opt-list is not defined but C630 suggests that a combination of
> the alloc-opts can appear.
>
> C630 (R624) No alloc-opt shall appear more than once in a given alloc-opt-list.
>
> It's easy to fix. I'll work out it this weekend.
>
> > Additionally: Can we add a -Wsurprising which checks for the presence of
> > STAT= when ERRMSG= is given? NAG f95 prints:
> >
> > Warning: hfjgf.f90, line 6: ERRMSG= is useless without STAT=
> >
> > > deallocate(x, x, errmsg=err)
> > > print *, err
> > There are several issues:
> > a) "deallocate(x, x)" is invalid, which can be compile-time diagnosable
> > (as e.g. ifort does), better place it in two lines
>
> OK. gfortran doesn't currently catch at compile time.
>
> REMOVE:kargl[125] gfc4x -o z b.f90
> REMOVE:kargl[126] ./z
> At line 4 of file b.f90
> Fortran runtime error: Attempt to DEALLOCATE unallocated 'i'
> REMOVE:kargl[127] cat b.f90
> program a
> integer, allocatable :: i(:)
> allocate(i(4))
> deallocate(i, i)
> end program a
>
> > b) "print *, err" is invalid - it always prints uninitialized value (in
> > case of success). In case of a failure, it does not print anything as
> > DEALLOCATE aborts
>
> The code in the email was a quick hack to show the current error
> message. The testcase is completely legal.
>
> > "If an error condition occurs during execution of an ALLOCATE statement
> > that does not contain the STAT= specifier, execution of the program is
> > terminated."
>
> Hmmm, that's going to complicate the trans-*c code. In fact, this
> pretty makes errmsg useless without stat, so your -Wsurprising
> should probably be a plain old warning.
>
> >
> > I will review the patch itself later.
> >
>
> Wait for an update. I have a 5 hour flight home
> tomorrow night.
It took a little longer than 5 hours. :(
The attached patch addresses many of the issues raised by Tobias
as well as some that I've identified while reading the F2003
standard. Specifically, this patch implements the F2003 feature
ERRMSG in the ALLOCATE and DEALLOCATE statments, and it adds
additional compile time error checking for allocate-objects,
stat-variable, and errmsg-variable.
Note, this patch does not implement checking of allocate-objects,
stat-variable, and errmsg-variable if these involve a derived type.
For example,
program c
type a
integer, allocatable :: i(:)
end type a
type(a) b
allocate(b%i(2))
deallocate(b%i, b%i) ! Invalid, not diagnosed.
end program c
troutmask:sgk[224] gfc4x -o z c.f90
troutmask:sgk[225] ./z
At line 10 of file c.f90
Fortran runtime error: Attempt to DEALLOCATE unallocated 'b'
This is the behavior one sees in 4.2.x, 4.3.x, and trunk.
There is also an issue with array references in STAT= and
ERRMSG= variables. Consider,
program b
integer, allocatable :: i(:)
integer :: k(3) = 42
deallocate(i, stat=k) ! Invalid, not diagnosed. Causes ICE!
print '(3(I0,1X))', k
deallocate(i, stat=k(3)) ! Valid
print '(3(I0,1X))', k
end program
troutmask:sgk[230] gfc4x -o z b.f90
b.f90: In function 'b':
b.f90:1: internal compiler error: Segmentation fault: 11
Please submit a full bug report,
with preprocessed source if appropriate.
See <http://gcc.gnu.org/bugs.html> for instructions.
Again, this is the behavior one sees in 4.2.x, 4.3.x, and trunk.
These issues will require walking data structures and would
make the 863 line diff much larger and harder to review (ie.,
a multi-dimensional array of a nested derived type is going
to be nasty).
This patch also does not implement the parsing of the SOURCE=
alloc-opt for the ALLOCATE() statement. Given the number
of constraints involving SOURCE, the addition of an optional
type spec, the fact that gfc_code needs to grow another member,
and the length of the current diff, I felt implementation of
SOURCE should be done in a self-contained patch.
Regression tests run on x86_64-unknown-freebsd8.0
=== gfortran Summary ===
# of expected passes 28976
# of unexpected successes 31
# of expected failures 19
# of unsupported tests 42
2008-12-10 Steven G. Kargl <kargls@comcast.net>
* gfortran.dg/alloc_alloc_expr_1.f90: Adjust for new error message.
* gfortran.dg/allocate_alloc_opt_1.f90: New test.
* gfortran.dg/allocate_alloc_opt_2.f90: Ditto.
* gfortran.dg/allocate_alloc_opt_3.f90: Ditto.
* gfortran.dg/deallocate_alloc_opt_1.f90: Ditto.
* gfortran.dg/deallocate_alloc_opt_2.f90: Ditto.
* gfortran.dg/deallocate_alloc_opt_3.f90: Ditto.
2008-12-10 Steven G. Kargl <kargls@comcast.net>
* trans-stmt.c(gfc_trans_allocate): Add translation of ERRMSG.
(gfc_trans_deallocate): Add translation of ERRMSG. Remove stale
comments. Minor whitespace cleanup.
* resolve.c(is_scalar_expr_ptr): Whitespace cleanup.
(resolve_deallocate_expr (gfc_expr *e): Update error message.
(resolve_allocate_expr): Remove dead code. Update error message.
Move error checking to ...
(resolve_allocate_deallocate): ... here. Add additional error
checking for STAT, ERRMSG, and allocate-objects.
* match.c(gfc_match_allocate,gfc_match_deallocate): Parse ERRMSG.
Check for redundant uses of STAT and ERRMSG. Reword error message
and add checking for pointer, allocatable, and proc_pointer attributes.
--
Steve
Index: gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90 (revision 142601)
+++ gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90 (working copy)
@@ -18,9 +18,9 @@ program fc011
integer, pointer :: PTR
integer, allocatable :: ALLOCS(:)
- allocate (PTR, stat=PTR) ! { dg-error "allocated in the same statement" }
+ allocate (PTR, stat=PTR) ! { dg-error "in the same ALLOCATE statement" }
- allocate (ALLOCS(10),stat=ALLOCS(1)) ! { dg-error "allocated in the same statement" }
+ allocate (ALLOCS(10),stat=ALLOCS(1)) ! { dg-error "in the same ALLOCATE statement" }
ALLOCATE(PTR,ALLOCS(PTR)) ! { dg-error "same ALLOCATE statement" }
Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_alloc_opt_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_1.f90 (revision 0)
@@ -0,0 +1,40 @@
+! { dg-do compile }
+program a
+
+ implicit none
+
+ real x
+ integer j, k, n(4)
+ character(len=70) err
+ character(len=70), allocatable :: error(:)
+
+ integer, allocatable :: i(:)
+
+ type b
+ integer, allocatable :: c(:), d(:)
+ end type b
+
+ type(b) e, f(3)
+
+ allocate(i(2), stat=x) ! { dg-error "must be a scalar INTEGER" }
+ allocate(i(2), stat=j, stat=k) ! { dg-error "Redundant STAT" }
+ allocate(i(2))
+ allocate(i(2))) ! { dg-error "Syntax error in ALLOCATE" }
+ allocate(i(2), errmsg=err, errmsg=err) ! { dg-error "Redundant ERRMSG" }
+ allocate(i(2), errmsg=err) ! { dg-warning "useless without a STAT" }
+ allocate(i(2), stat=j, errmsg=x) ! { dg-error "must be a scalar CHARACTER" }
+
+ allocate(err) ! { dg-error "nonprocedure pointer or an allocatable" }
+
+ allocate(error(2),stat=j,errmsg=error) ! { dg-error "shall not be ALLOCATEd within" }
+ allocate(i(2), stat = i) ! { dg-error "shall not be ALLOCATEd within" }
+
+ allocate(n) ! { dg-error "must be ALLOCATABLE or a POINTER" }
+
+ allocate(i(2), i(2)) ! { dg-error "Allocate-object at" }
+
+ ! These should not fail the check for duplicate alloc-objects.
+ allocate(f(1)%c(2), f(2)%d(2))
+ allocate(e%c(2), e%d(2))
+
+end program a
Index: gcc/testsuite/gfortran.dg/deallocate_alloc_opt_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/deallocate_alloc_opt_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/deallocate_alloc_opt_2.f90 (revision 0)
@@ -0,0 +1,12 @@
+! { dg-do compile }
+subroutine sub(i, j, err)
+ implicit none
+ character(len=*), intent(in) :: err
+ integer, intent(in) :: j
+ integer, intent(in), allocatable :: i(:)
+ integer, allocatable :: m(:)
+ integer n
+ deallocate(i) ! { dg-error "Cannot deallocate" "" }
+ deallocate(m, stat=j) ! { dg-error "cannot be" "" }
+ deallocate(m,stat=n,errmsg=err) ! { dg-error "cannot be" "" }
+end subroutine sub
Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_alloc_opt_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_3.f90 (revision 0)
@@ -0,0 +1,33 @@
+! { dg-do run }
+program a
+
+ implicit none
+
+ integer n
+ character(len=70) e1
+ character(len=30) e2
+ integer, allocatable :: i(:)
+
+ e1 = 'No error'
+ allocate(i(4), stat=n, errmsg=e1)
+ if (trim(e1) /= 'No error') call abort
+ deallocate(i)
+
+ e2 = 'No error'
+ allocate(i(4),stat=n, errmsg=e2)
+ if (trim(e2) /= 'No error') call abort
+ deallocate(i)
+
+
+ e1 = 'No error'
+ allocate(i(4), stat=n, errmsg=e1)
+ allocate(i(4), stat=n, errmsg=e1)
+ if (trim(e1) /= 'Attempt to allocate an allocated object') call abort
+ deallocate(i)
+
+ e2 = 'No error'
+ allocate(i(4), stat=n, errmsg=e2)
+ allocate(i(4), stat=n, errmsg=e2)
+ if (trim(e2) /= 'Attempt to allocate an allocat') call abort
+
+end program a
Index: gcc/testsuite/gfortran.dg/deallocate_alloc_opt_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/deallocate_alloc_opt_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/deallocate_alloc_opt_1.f90 (revision 0)
@@ -0,0 +1,40 @@
+! { dg-do compile }
+program a
+
+ implicit none
+
+ real x
+ integer j, k, n(4)
+ character(len=70) err
+ character(len=70), allocatable :: error(:)
+
+ integer, allocatable :: i(:)
+
+ type b
+ integer, allocatable :: c(:), d(:)
+ end type b
+
+ type(b) e, f(3)
+
+ deallocate(i, stat=x) ! { dg-error "must be a scalar INTEGER" }
+ deallocate(i, stat=j, stat=k) ! { dg-error "Redundant STAT" }
+ deallocate(i)
+ deallocate(i)) ! { dg-error "Syntax error in DEALLOCATE" }
+ deallocate(i, errmsg=err, errmsg=err) ! { dg-error "Redundant ERRMSG" }
+ deallocate(i, errmsg=err) ! { dg-warning "useless without a STAT" }
+ deallocate(i, stat=j, errmsg=x) ! { dg-error "must be a scalar CHARACTER" }
+
+ deallocate(err) ! { dg-error "nonprocedure pointer or an allocatable" }
+
+ deallocate(error,stat=j,errmsg=error) ! { dg-error "shall not be DEALLOCATEd within" }
+ deallocate(i, stat = i) ! { dg-error "shall not be DEALLOCATEd within" }
+
+ deallocate(n) ! { dg-error "must be ALLOCATABLE or a POINTER" }
+
+ deallocate(i, i) ! { dg-error "Allocate-object at" }
+
+ ! These should not fail the check for duplicate alloc-objects.
+ deallocate(f(1)%c, f(2)%d)
+ deallocate(e%c, e%d)
+
+end program a
Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_alloc_opt_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_2.f90 (revision 0)
@@ -0,0 +1,12 @@
+! { dg-do compile }
+subroutine sub(i, j, err)
+ implicit none
+ character(len=*), intent(in) :: err
+ integer, intent(in) :: j
+ integer, intent(in), allocatable :: i(:)
+ integer, allocatable :: m(:)
+ integer n
+ allocate(i(2)) ! { dg-error "Cannot allocate" "" }
+ allocate(m(2), stat=j) ! { dg-error "cannot be" "" }
+ allocate(m(2),stat=n,errmsg=err) ! { dg-error "cannot be" "" }
+end subroutine sub
Index: gcc/testsuite/gfortran.dg/deallocate_alloc_opt_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/deallocate_alloc_opt_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/deallocate_alloc_opt_3.f90 (revision 0)
@@ -0,0 +1,29 @@
+! { dg-do run }
+program a
+
+ implicit none
+
+ integer n
+ character(len=70) e1
+ character(len=30) e2
+ integer, allocatable :: i(:)
+
+ e1 = 'No error'
+ allocate(i(4))
+ deallocate(i, stat=n, errmsg=e1)
+ if (trim(e1) /= 'No error') call abort
+
+ e2 = 'No error'
+ allocate(i(4))
+ deallocate(i, stat=n, errmsg=e2)
+ if (trim(e2) /= 'No error') call abort
+
+ e1 = 'No error'
+ deallocate(i, stat=n, errmsg=e1)
+ if (trim(e1) /= 'Attempt to deallocate an unallocated object') call abort
+
+ e2 = 'No error'
+ deallocate(i, stat=n, errmsg=e2)
+ if (trim(e2) /= 'Attempt to deallocate an unall') call abort
+
+end program a
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 142601)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -3877,9 +3877,12 @@ gfc_trans_allocate (gfc_code * code)
if (!code->ext.alloc_list)
return NULL_TREE;
+ pstat = stat = error_label = tmp = NULL_TREE;
+
gfc_start_block (&block);
- if (code->expr)
+ /* Either STAT= and/or ERRMSG is present. */
+ if (code->expr || code->expr2)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
@@ -3889,8 +3892,6 @@ gfc_trans_allocate (gfc_code * code)
error_label = gfc_build_label_decl (NULL_TREE);
TREE_USED (error_label) = 1;
}
- else
- pstat = stat = error_label = NULL_TREE;
for (al = code->ext.alloc_list; al != NULL; al = al->next)
{
@@ -3916,7 +3917,7 @@ gfc_trans_allocate (gfc_code * code)
fold_convert (TREE_TYPE (se.expr), tmp));
gfc_add_expr_to_block (&se.pre, tmp);
- if (code->expr)
+ if (code->expr || code->expr2)
{
tmp = build1_v (GOTO_EXPR, error_label);
parm = fold_build2 (NE_EXPR, boolean_type_node,
@@ -3939,7 +3940,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
- /* Assign the value to the status variable. */
+ /* STAT block. */
if (code->expr)
{
tmp = build1_v (LABEL_EXPR, error_label);
@@ -3951,29 +3952,45 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_modify (&block, se.expr, tmp);
}
+ /* ERRMSG block. */
+ if (code->expr2)
+ {
+ /* A better error message may be possible, but not required. */
+ const char *msg = "Attempt to allocate an allocated object";
+ tree errmsg, slen, dlen;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->expr2);
+
+ errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
+
+ gfc_add_modify (&block, errmsg,
+ gfc_build_addr_expr (pchar_type_node,
+ gfc_build_localized_cstring_const (msg)));
+
+ slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
+ dlen = gfc_get_expr_charlen (code->expr2);
+ slen = fold_build2 (MIN_EXPR, TREE_TYPE (slen), dlen, slen);
+
+ dlen = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+
+ tmp = fold_build2 (NE_EXPR, boolean_type_node, stat,
+ build_int_cst (TREE_TYPE (stat), 0));
+
+ tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt ());
+
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
return gfc_finish_block (&block);
}
-/* Translate a DEALLOCATE statement.
- There are two cases within the for loop:
- (1) deallocate(a1, a2, a3) is translated into the following sequence
- _gfortran_deallocate(a1, 0B)
- _gfortran_deallocate(a2, 0B)
- _gfortran_deallocate(a3, 0B)
- where the STAT= variable is passed a NULL pointer.
- (2) deallocate(a1, a2, a3, stat=i) is translated into the following
- astat = 0
- _gfortran_deallocate(a1, &stat)
- astat = astat + stat
- _gfortran_deallocate(a2, &stat)
- astat = astat + stat
- _gfortran_deallocate(a3, &stat)
- astat = astat + stat
- In case (1), we simply return at the end of the for loop. In case (2)
- we set STAT= astat. */
+/* Translate a DEALLOCATE statement. */
+
tree
-gfc_trans_deallocate (gfc_code * code)
+gfc_trans_deallocate (gfc_code *code)
{
gfc_se se;
gfc_alloc *al;
@@ -3981,14 +3998,17 @@ gfc_trans_deallocate (gfc_code * code)
tree apstat, astat, pstat, stat, tmp;
stmtblock_t block;
+ pstat = apstat = stat = astat = tmp = NULL_TREE;
+
gfc_start_block (&block);
- /* Set up the optional STAT= */
- if (code->expr)
+ /* Count the number of failed deallocations. If deallocate() was
+ called with STAT= , then set STAT to the count. If deallocate
+ was called with ERRMSG, then set ERRMG to a string. */
+ if (code->expr || code->expr2)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
- /* Variable used with the library call. */
stat = gfc_create_var (gfc_int4_type_node, "stat");
pstat = build_fold_addr_expr (stat);
@@ -3999,8 +4019,6 @@ gfc_trans_deallocate (gfc_code * code)
/* Initialize astat to 0. */
gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
}
- else
- pstat = apstat = stat = astat = NULL_TREE;
for (al = code->ext.alloc_list; al != NULL; al = al->next)
{
@@ -4014,8 +4032,7 @@ gfc_trans_deallocate (gfc_code * code)
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (expr->ts.type == BT_DERIVED
- && expr->ts.derived->attr.alloc_comp)
+ if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
{
gfc_ref *ref;
gfc_ref *last = NULL;
@@ -4026,7 +4043,7 @@ gfc_trans_deallocate (gfc_code * code)
/* Do not deallocate the components of a derived type
ultimate pointer component. */
if (!(last && last->u.c.component->attr.pointer)
- && !(!last && expr->symtree->n.sym->attr.pointer))
+ && !(!last && expr->symtree->n.sym->attr.pointer))
{
tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
expr->rank);
@@ -4049,7 +4066,7 @@ gfc_trans_deallocate (gfc_code * code)
/* Keep track of the number of failed deallocations by adding stat
of the last deallocation to the running total. */
- if (code->expr)
+ if (code->expr || code->expr2)
{
apstat = fold_build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat);
gfc_add_modify (&se.pre, astat, apstat);
@@ -4060,7 +4077,7 @@ gfc_trans_deallocate (gfc_code * code)
}
- /* Assign the value to the status variable. */
+ /* Set STAT. */
if (code->expr)
{
gfc_init_se (&se, NULL);
@@ -4069,6 +4086,37 @@ gfc_trans_deallocate (gfc_code * code)
gfc_add_modify (&block, se.expr, tmp);
}
+ /* Set ERRMSG. */
+ if (code->expr2)
+ {
+ /* A better error message may be possible, but not required. */
+ const char *msg = "Attempt to deallocate an unallocated object";
+ tree errmsg, slen, dlen;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->expr2);
+
+ errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
+
+ gfc_add_modify (&block, errmsg,
+ gfc_build_addr_expr (pchar_type_node,
+ gfc_build_localized_cstring_const (msg)));
+
+ slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
+ dlen = gfc_get_expr_charlen (code->expr2);
+ slen = fold_build2 (MIN_EXPR, TREE_TYPE (slen), dlen, slen);
+
+ dlen = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+
+ tmp = fold_build2 (NE_EXPR, boolean_type_node, astat,
+ build_int_cst (TREE_TYPE (astat), 0));
+
+ tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt ());
+
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
return gfc_finish_block (&block);
}
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 142601)
+++ gcc/fortran/resolve.c (working copy)
@@ -2000,16 +2000,16 @@ is_scalar_expr_ptr (gfc_expr *expr)
}
else
{
- /* We have constant lower and upper bounds. If the
- difference between is 1, it can be considered a
- scalar. */
- start = (int) mpz_get_si
- (ref->u.ar.as->lower[0]->value.integer);
- end = (int) mpz_get_si
- (ref->u.ar.as->upper[0]->value.integer);
- if (end - start + 1 != 1)
- retval = FAILURE;
- }
+ /* We have constant lower and upper bounds. If the
+ difference between is 1, it can be considered a
+ scalar. */
+ start = (int) mpz_get_si
+ (ref->u.ar.as->lower[0]->value.integer);
+ end = (int) mpz_get_si
+ (ref->u.ar.as->upper[0]->value.integer);
+ if (end - start + 1 != 1)
+ retval = FAILURE;
+ }
}
else
retval = FAILURE;
@@ -5084,8 +5084,8 @@ resolve_deallocate_expr (gfc_expr *e)
if (allocatable == 0 && attr.pointer == 0)
{
bad:
- gfc_error ("Expression in DEALLOCATE statement at %L must be "
- "ALLOCATABLE or a POINTER", &e->where);
+ gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
+ &e->where);
}
if (check_intent_in
@@ -5170,11 +5170,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
- if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
- sym = code->expr->symtree->n.sym;
- else
- sym = NULL;
-
/* Make sure the expression is allocatable or a pointer. If it is
pointer, the next-to-last reference must be a pointer. */
@@ -5193,14 +5188,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_
pointer = e->symtree->n.sym->attr.pointer;
dimension = e->symtree->n.sym->attr.dimension;
- if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
- {
- gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
- "not be allocated in the same statement at %L",
- sym->name, &e->where);
- return FAILURE;
- }
-
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
if (pointer)
@@ -5231,8 +5218,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_
if (allocatable == 0 && pointer == 0)
{
- gfc_error ("Expression in ALLOCATE statement at %L must be "
- "ALLOCATABLE or a POINTER", &e->where);
+ gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
+ &e->where);
return FAILURE;
}
@@ -5327,26 +5314,83 @@ check_symbols:
static void
resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{
- gfc_symbol *s = NULL;
- gfc_alloc *a;
+ gfc_expr *stat, *errmsg, *pe, *qe;
+ gfc_alloc *a, *p, *q;
+
+ stat = code->expr ? code->expr : NULL;
- if (code->expr)
- s = code->expr->symtree->n.sym;
+ errmsg = code->expr2 ? code->expr2 : NULL;
- if (s)
+ /* Check the stat variable. */
+ if (stat)
{
- if (s->attr.intent == INTENT_IN)
- gfc_error ("STAT variable '%s' of %s statement at %C cannot "
- "be INTENT(IN)", s->name, fcn);
+ if (stat->symtree->n.sym->attr.intent == INTENT_IN)
+ gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
+ stat->symtree->n.sym->name, &stat->where);
- if (gfc_pure (NULL) && gfc_impure_variable (s))
- gfc_error ("Illegal STAT variable in %s statement at %C "
- "for a PURE procedure", fcn);
+ if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
+ gfc_error ("Illegal stat-variable at %L for a PURE procedure",
+ &stat->where);
+
+ if (stat->ts.type != BT_INTEGER
+ && !(stat->ref && (stat->ref->type == REF_ARRAY
+ || stat->ref->type == REF_COMPONENT)))
+ gfc_error ("Stat-variable at %L must be a scalar INTEGER "
+ "variable", &stat->where);
+
+ for (p = code->ext.alloc_list; p; p = p->next)
+ if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
+ gfc_error ("Stat-variable at %L shall not be %sd within "
+ "the same %s statement", &stat->where, fcn, fcn);
}
- if (s && code->expr->ts.type != BT_INTEGER)
- gfc_error ("STAT tag in %s statement at %L must be "
- "of type INTEGER", fcn, &code->expr->where);
+ /* Check the errmsg variable. */
+ if (errmsg)
+ {
+ if (!stat)
+ gfc_warning ("ERRMSG at %L is useless without a STAT tag",
+ &errmsg->where);
+
+ if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
+ gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
+ errmsg->symtree->n.sym->name, &errmsg->where);
+
+ if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
+ gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
+ &errmsg->where);
+
+ if (errmsg->ts.type != BT_CHARACTER
+ && !(errmsg->ref
+ && (errmsg->ref->type == REF_ARRAY
+ || errmsg->ref->type == REF_COMPONENT)))
+ gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
+ "variable", &errmsg->where);
+
+ for (p = code->ext.alloc_list; p; p = p->next)
+ if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
+ gfc_error ("Errmsg-variable at %L shall not be %sd within "
+ "the same %s statement", &errmsg->where, fcn, fcn);
+ }
+
+ /* Check that an allocate-object appears only once in the statement.
+ FIXME: Checking derived types is disabled. */
+ for (p = code->ext.alloc_list; p; p = p->next)
+ {
+ pe = p->expr;
+ if ((pe->ref && pe->ref->type != REF_COMPONENT)
+ && (pe->symtree->n.sym->ts.type != BT_DERIVED))
+ {
+ for (q = p->next; q; q = q->next)
+ {
+ qe = q->expr;
+ if ((qe->ref && qe->ref->type != REF_COMPONENT)
+ && (qe->symtree->n.sym->ts.type != BT_DERIVED)
+ && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
+ gfc_error ("Allocate-object at %L also appears at %L",
+ &pe->where, &qe->where);
+ }
+ }
+ }
if (strcmp (fcn, "ALLOCATE") == 0)
{
@@ -5360,6 +5404,7 @@ resolve_allocate_deallocate (gfc_code *c
}
}
+
/************ SELECT CASE resolution subroutines ************/
/* Callback function for our mergesort variant. Determines interval
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 142601)
+++ gcc/fortran/match.c (working copy)
@@ -2222,11 +2222,13 @@ match
gfc_match_allocate (void)
{
gfc_alloc *head, *tail;
- gfc_expr *stat;
+ gfc_expr *stat, *errmsg, *tmp;
match m;
+ bool saw_stat, saw_errmsg;
head = tail = NULL;
- stat = NULL;
+ stat = errmsg = tmp = NULL;
+ saw_stat = saw_errmsg = false;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
@@ -2250,35 +2252,92 @@ gfc_match_allocate (void)
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
- if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
{
- gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
- "PURE procedure");
+ gfc_error ("Bad allocate-object at %C for a PURE procedure");
goto cleanup;
}
if (tail->expr->ts.type == BT_DERIVED)
tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
+ /* FIXME: disable the checking on derived types and arrays. */
+ if (!(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))
+ {
+ gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
+ "or an allocatable variable");
+ goto cleanup;
+ }
+
if (gfc_match_char (',') != MATCH_YES)
break;
- m = gfc_match (" stat = %v", &stat);
+alloc_opt_list:
+
+ m = gfc_match (" stat = %v", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
- break;
+ {
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ gfc_free_expr (tmp);
+ goto cleanup;
+ }
+
+ stat = tmp;
+ saw_stat = true;
+
+ if (gfc_check_do_variable (stat->symtree))
+ goto cleanup;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto alloc_opt_list;
+ }
+
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
+ &tmp->where) == FAILURE)
+ goto cleanup;
+
+ if (saw_errmsg)
+ {
+ gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ gfc_free_expr (tmp);
+ goto cleanup;
+ }
+
+ errmsg = tmp;
+ saw_errmsg = true;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto alloc_opt_list;
+ }
+
+ gfc_gobble_whitespace ();
+
+ if (gfc_peek_char () == ')')
+ break;
}
- if (stat != NULL)
- gfc_check_do_variable(stat->symtree);
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
new_st.op = EXEC_ALLOCATE;
new_st.expr = stat;
+ new_st.expr2 = errmsg;
new_st.ext.alloc_list = head;
return MATCH_YES;
@@ -2287,6 +2346,7 @@ syntax:
gfc_syntax_error (ST_ALLOCATE);
cleanup:
+ gfc_free_expr (errmsg);
gfc_free_expr (stat);
gfc_free_alloc_list (head);
return MATCH_ERROR;
@@ -2367,11 +2427,13 @@ match
gfc_match_deallocate (void)
{
gfc_alloc *head, *tail;
- gfc_expr *stat;
+ gfc_expr *stat, *errmsg, *tmp;
match m;
+ bool saw_stat, saw_errmsg;
head = tail = NULL;
- stat = NULL;
+ stat = errmsg = tmp = NULL;
+ saw_stat = saw_errmsg = false;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
@@ -2395,32 +2457,88 @@ gfc_match_deallocate (void)
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
- if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
{
- gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
- "for a PURE procedure");
+ gfc_error ("Illegal allocate-object at %C for a PURE procedure");
+ goto cleanup;
+ }
+
+ /* FIXME: disable the checking on derived types. */
+ if (!(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))
+ {
+ gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
+ "or an allocatable variable");
goto cleanup;
}
if (gfc_match_char (',') != MATCH_YES)
break;
- m = gfc_match (" stat = %v", &stat);
+dealloc_opt_list:
+
+ m = gfc_match (" stat = %v", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
- break;
- }
+ {
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ gfc_free_expr (tmp);
+ goto cleanup;
+ }
+
+ stat = tmp;
+ saw_stat = true;
+
+ if (gfc_check_do_variable (stat->symtree))
+ goto cleanup;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto dealloc_opt_list;
+ }
- if (stat != NULL)
- gfc_check_do_variable(stat->symtree);
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
+ &tmp->where) == FAILURE)
+ goto cleanup;
+
+ if (saw_errmsg)
+ {
+ gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ gfc_free_expr (tmp);
+ goto cleanup;
+ }
+
+ errmsg = tmp;
+ saw_errmsg = true;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto dealloc_opt_list;
+ }
+
+ gfc_gobble_whitespace ();
+
+ if (gfc_peek_char () == ')')
+ break;
+ }
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
new_st.op = EXEC_DEALLOCATE;
new_st.expr = stat;
+ new_st.expr2 = errmsg;
new_st.ext.alloc_list = head;
return MATCH_YES;
@@ -2429,6 +2547,7 @@ syntax:
gfc_syntax_error (ST_DEALLOCATE);
cleanup:
+ gfc_free_expr (errmsg);
gfc_free_expr (stat);
gfc_free_alloc_list (head);
return MATCH_ERROR;