Hi Tobias,
> > We should rather open a separate PR on auditing the related uses
> > of gfc_match.
>
> I concur – I just wanted to quickly check how many %v are there –
> besides %v, there are also direct calls to gfc_match_variable.
>
> Can you open a PR?
this is now https://gcc.gnu.org/bugzilla/show_bug.cgi?id=101652
> The loops are clear – but the
> '!stat->ref || (...ref->type != ARRAY || ref->type != COMPONENT))'
> is still not clear to me.
Ah, I was really missing the point and looking in the wrong place.
Actually, I also do not understand the reason for this version of
the check, and it also leads to a strange accepts-invalid for
certain non-integer STAT variables. Removing the stat->ref part
fixes that without introducing any regression in the testsuite.
(There was an analogous part in the check for ERRMSG.)
> Can you add the (working) test:
> allocate (A, stat=y%stat%kind) ! { dg-error "cannot be a constant" }
> deallocate (A, stat=y%stat%kind) ! { dg-error "cannot be a constant" }
> to your testcase gcc/testsuite/gfortran.dg/allocate_stat_3.f90 ?
Done.
> And also the following one, which does not get diagnosed and, hence,
> later gives an ICE during gimplification.
>
> type tc
> character (len=:), allocatable :: str
> end type tc
> ...
> type(tc) :: z
> ...
> allocate(character(len=13) :: z%str)
> allocate (A, stat=z%str%len)
> deallocate (A, stat=z%str%len)
>
> To fix it, I think the solution is to do the following:
> * In gfc_check_vardef_context, handle also REF_INQUIRY; in the
> for (ref = e->ref; ref && check_intentin; ref = ref->next)
> loop, I think there should be a
> if (ref->type == REF_INQUIRY)
> {
> if (context)
> gfc_error ("Type parameter inquiry for %qs in "
> "variable definition context (%s) at %L",
> name, context, &e->where);
> return false;
> }
> (untested)
This almost worked, needing only a restriction to %KIND and %LEN.
Note that %RE and %IM are usually definable.
> I assume (but have not tested it) that will give
> two error messages for:
> allocate (A, errmsg=z%str%len)
> deallocate (A, errmsg=z%str%len)
> one for the new type-param-inquiry check and one for
> != BT_CHARACTER
> if you want to prevent the double error, consider to
> replace
> gfc_check_vardef_context (...);
> by
> if (!gfc_check_vardef_context (...))
> goto done_errmsg;
Yes, that is reasonable. Done.
> > Regtested on x86_64-pc-linux-gnu. OK?
> LGTM - except for the two testcase additions proposed above
> and fixing the ICE. If you are happy with my changes and they
> work, feel free add them and commit without further review.
> In either case, I have the feeling we are nearly there. :-)
I have added the updated "final" version of the patch to give
everybody another 24h to have a look, and will commit if nobody
complains.
> Thanks for the patch and the review-modification-review-... patience!
Well, I believe this was really a worthwile review process,
with fixing a few issues on the way before Gerhard finds them...
Thanks,
Harald
Fortran: ICE in resolve_allocate_deallocate for invalid STAT argument
gcc/fortran/ChangeLog:
PR fortran/101564
* expr.c (gfc_check_vardef_context): Add check for KIND and LEN
parameter inquiries.
* match.c (gfc_match): Fix comment for %v code.
(gfc_match_allocate, gfc_match_deallocate): Replace use of %v code
by %e in gfc_match to allow for function references as STAT and
ERRMSG arguments.
* resolve.c (resolve_allocate_deallocate): Avoid NULL pointer
dereferences and shortcut for bad STAT and ERRMSG argument to
(DE)ALLOCATE. Remove bogus parts of checks for STAT and ERRMSG.
gcc/testsuite/ChangeLog:
PR fortran/101564
* gfortran.dg/allocate_stat_3.f90: New test.
* gfortran.dg/allocate_stat.f90: Adjust error messages.
* gfortran.dg/implicit_11.f90: Likewise.
* gfortran.dg/inquiry_type_ref_3.f90: Likewise.
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index b11ae7ce5c5..35563a78697 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -6199,6 +6199,16 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
if (!pointer)
check_intentin = false;
}
+ if (ref->type == REF_INQUIRY
+ && (ref->u.i == INQUIRY_KIND || ref->u.i == INQUIRY_LEN))
+ {
+ if (context)
+ gfc_error ("%qs parameter inquiry for %qs in "
+ "variable definition context (%s) at %L",
+ ref->u.i == INQUIRY_KIND ? "KIND" : "LEN",
+ sym->name, context, &e->where);
+ return false;
+ }
}
if (check_intentin
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index d148de3e3b5..b1105481099 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1109,7 +1109,8 @@ gfc_match_char (char c)
%t Matches end of statement.
%o Matches an intrinsic operator, returned as an INTRINSIC enum.
%l Matches a statement label
- %v Matches a variable expression (an lvalue)
+ %v Matches a variable expression (an lvalue, except function references
+ having a data pointer result)
% Matches a required space (in free form) and optional spaces. */
match
@@ -4405,7 +4406,7 @@ gfc_match_allocate (void)
alloc_opt_list:
- m = gfc_match (" stat = %v", &tmp);
+ m = gfc_match (" stat = %e", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
@@ -4434,7 +4435,7 @@ alloc_opt_list:
goto alloc_opt_list;
}
- m = gfc_match (" errmsg = %v", &tmp);
+ m = gfc_match (" errmsg = %e", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
@@ -4777,7 +4778,7 @@ gfc_match_deallocate (void)
dealloc_opt_list:
- m = gfc_match (" stat = %v", &tmp);
+ m = gfc_match (" stat = %e", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
@@ -4799,7 +4800,7 @@ dealloc_opt_list:
goto dealloc_opt_list;
}
- m = gfc_match (" errmsg = %v", &tmp);
+ m = gfc_match (" errmsg = %e", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 45c3ad387ac..592364689f9 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8155,16 +8155,21 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
/* Check the stat variable. */
if (stat)
{
- gfc_check_vardef_context (stat, false, false, false,
- _("STAT variable"));
+ if (!gfc_check_vardef_context (stat, false, false, false,
+ _("STAT variable")))
+ goto done_stat;
- if ((stat->ts.type != BT_INTEGER
- && !(stat->ref && (stat->ref->type == REF_ARRAY
- || stat->ref->type == REF_COMPONENT)))
+ if (stat->ts.type != BT_INTEGER
|| stat->rank > 0)
gfc_error ("Stat-variable at %L must be a scalar INTEGER "
"variable", &stat->where);
+ if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL)
+ goto done_stat;
+
+ /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
+ * within the ALLOCATE or DEALLOCATE statement in which it appears ...
+ */
for (p = code->ext.alloc.list; p; p = p->next)
if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
{
@@ -8192,6 +8197,8 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
}
}
+done_stat:
+
/* Check the errmsg variable. */
if (errmsg)
{
@@ -8199,22 +8206,26 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
&errmsg->where);
- gfc_check_vardef_context (errmsg, false, false, false,
- _("ERRMSG variable"));
+ if (!gfc_check_vardef_context (errmsg, false, false, false,
+ _("ERRMSG variable")))
+ goto done_errmsg;
/* F18:R928 alloc-opt is ERRMSG = errmsg-variable
F18:R930 errmsg-variable is scalar-default-char-variable
F18:R906 default-char-variable is variable
F18:C906 default-char-variable shall be default character. */
- if ((errmsg->ts.type != BT_CHARACTER
- && !(errmsg->ref
- && (errmsg->ref->type == REF_ARRAY
- || errmsg->ref->type == REF_COMPONENT)))
+ if (errmsg->ts.type != BT_CHARACTER
|| errmsg->rank > 0
|| errmsg->ts.kind != gfc_default_character_kind)
gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
"variable", &errmsg->where);
+ if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL)
+ goto done_errmsg;
+
+ /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
+ * within the ALLOCATE or DEALLOCATE statement in which it appears ...
+ */
for (p = code->ext.alloc.list; p; p = p->next)
if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
{
@@ -8242,6 +8253,8 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
}
}
+done_errmsg:
+
/* Check that an allocate-object appears only once in the statement. */
for (p = code->ext.alloc.list; p; p = p->next)
diff --git a/gcc/testsuite/gfortran.dg/allocate_stat.f90 b/gcc/testsuite/gfortran.dg/allocate_stat.f90
index 7f9eaf58d6d..f8a12913c91 100644
--- a/gcc/testsuite/gfortran.dg/allocate_stat.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_stat.f90
@@ -38,7 +38,7 @@ function func2() result(res)
implicit none
real, pointer :: gain
integer :: res
- allocate (gain,STAT=func2) ! { dg-error "is not a variable" }
+ allocate (gain,STAT=func2) ! { dg-error "requires an argument list" }
deallocate(gain)
res = 0
end function func2
@@ -51,7 +51,7 @@ subroutine sub()
end interface
real, pointer :: gain
integer, parameter :: res = 2
- allocate (gain,STAT=func2) ! { dg-error "is not a variable" }
+ allocate (gain,STAT=func2) ! { dg-error "requires an argument list" }
deallocate(gain)
end subroutine sub
@@ -68,9 +68,9 @@ contains
end function one
subroutine sub()
integer, pointer :: p
- allocate(p, stat=one) ! { dg-error "is not a variable" }
+ allocate(p, stat=one) ! { dg-error "requires an argument list" }
if(associated(p)) deallocate(p)
- allocate(p, stat=two) ! { dg-error "is not a variable" }
+ allocate(p, stat=two) ! { dg-error "requires an argument list" }
if(associated(p)) deallocate(p)
end subroutine sub
end module test
diff --git a/gcc/testsuite/gfortran.dg/allocate_stat_3.f90 b/gcc/testsuite/gfortran.dg/allocate_stat_3.f90
new file mode 100644
index 00000000000..1fa38925d6f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_stat_3.f90
@@ -0,0 +1,67 @@
+! { dg-do compile }
+! PR fortran/101564 - ICE in resolve_allocate_deallocate
+
+program p
+ implicit none
+ integer, allocatable :: x(:)
+ integer :: stat
+ integer, pointer :: A
+ integer, target :: ptr
+ real, target :: r
+ character(4) :: c
+ type t
+ integer :: stat
+ real :: r
+ complex :: z
+ end type t
+ type(t), allocatable :: y
+ type tc
+ character(len=:), allocatable :: s
+ end type tc
+ type(tc) :: z
+ allocate (character(42) :: z%s, stat=stat)
+ allocate (A, stat=stat, errmsg=z%s)
+ deallocate (A, stat=stat, errmsg=z%s)
+ allocate (x(2), stat=stat)
+ deallocate (x, stat=stat)
+ allocate (A, stat=f())
+ deallocate (A, stat=f())
+ allocate (A, stat=y%stat)
+ deallocate (A, stat=y%stat)
+ allocate (A, stat=y%r) ! { dg-error "must be a scalar INTEGER variable" }
+ deallocate (A, stat=y%r) ! { dg-error "must be a scalar INTEGER variable" }
+ allocate (x(2), stat=stat%kind) ! { dg-error "STAT tag" }
+ deallocate (x, stat=stat%kind) ! { dg-error "STAT variable" }
+ allocate (A, stat=A%kind) ! { dg-error "STAT tag" }
+ deallocate (A, stat=A%kind) ! { dg-error "STAT variable" }
+ allocate (A, stat=c%len) ! { dg-error "STAT tag" }
+ deallocate (A, stat=c%len) ! { dg-error "STAT variable" }
+ allocate (A, stat=y%stat%kind) ! { dg-error "STAT tag" }
+ deallocate (A, stat=y%stat%kind) ! { dg-error "STAT variable" }
+ allocate (y, stat=y%stat) ! { dg-error "within the same ALLOCATE statement" }
+ allocate (y, stat=r) ! { dg-error "must be a scalar INTEGER variable" }
+ allocate (A, stat=y%z%re) ! { dg-error "must be a scalar INTEGER variable" }
+ deallocate (A, stat=y%z%im) ! { dg-error "must be a scalar INTEGER variable" }
+ allocate (y, stat=g()) ! { dg-error "must be a scalar INTEGER variable" }
+ deallocate (y, stat=g()) ! { dg-error "must be a scalar INTEGER variable" }
+ allocate (A, stat=f) ! { dg-error "requires an argument list" }
+ deallocate (A, stat=f) ! { dg-error "requires an argument list" }
+ allocate (y, stat=g) ! { dg-error "requires an argument list" }
+ deallocate (y, stat=g) ! { dg-error "requires an argument list" }
+ allocate (A, stat=z%s%len) ! { dg-error "parameter inquiry" }
+ deallocate (A, stat=z%s%len) ! { dg-error "parameter inquiry" }
+ allocate (A, stat=f(), errmsg="") ! { dg-error "ERRMSG variable" }
+ deallocate (A, stat=f(), errmsg="") ! { dg-error "ERRMSG variable" }
+ allocate (A, stat=stat, errmsg=z%s%len) ! { dg-error "ERRMSG variable" }
+ deallocate (A, stat=stat, errmsg=z%s%len) ! { dg-error "ERRMSG variable" }
+ deallocate (z%s, stat=stat, errmsg=z%s) ! { dg-error "within the same DEALLOCATE statement" }
+contains
+ integer function f()
+ pointer :: f
+ f => ptr
+ end function f
+ real function g()
+ pointer :: g
+ g => r
+ end function g
+end
diff --git a/gcc/testsuite/gfortran.dg/implicit_11.f90 b/gcc/testsuite/gfortran.dg/implicit_11.f90
index 61091ec41a0..8f93704ac4c 100644
--- a/gcc/testsuite/gfortran.dg/implicit_11.f90
+++ b/gcc/testsuite/gfortran.dg/implicit_11.f90
@@ -31,6 +31,6 @@
SUBROUTINE AD0001
REAL RLA1(:)
ALLOCATABLE RLA1
- ALLOCATE (RLA1(NF10), STAT = ISTAT2) ! { dg-error "is not a variable" }
+ ALLOCATE (RLA1(NF10), STAT = ISTAT2) ! { dg-error "requires an argument list" }
END SUBROUTINE
END MODULE tests2
diff --git a/gcc/testsuite/gfortran.dg/inquiry_type_ref_3.f90 b/gcc/testsuite/gfortran.dg/inquiry_type_ref_3.f90
index 4e8d8a07b4e..7c1bf43785c 100644
--- a/gcc/testsuite/gfortran.dg/inquiry_type_ref_3.f90
+++ b/gcc/testsuite/gfortran.dg/inquiry_type_ref_3.f90
@@ -17,7 +17,7 @@ program main
type(t) :: s
b = "abcdefg"
a%kind = 2 ! { dg-error "Assignment to a constant expression" }
- b%len = 2 ! { dg-error "Assignment to a LEN or KIND part_ref" }
+ b%len = 2 ! { dg-error "parameter inquiry" }
i = a%kind ! OK
i = b%len ! OK
print *, z%re ! { dg-error "must be applied to a COMPLEX expression" }
