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" }