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 b11ae7ce5c5ca1818b381e6b7e5c20c21936141d..35563a78697f4f7a8fdd1c89c2e1ebf0dd3f1a52 100644 (file)
--- 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 d148de3e3b53dfd4814a7a589fbed37752b762d9..b11054810991c7b72de65cf48157d35c43f89823 100644 (file)
--- 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 45c3ad387ac01d2a107cc0d5d34b822f7e4fcc26..592364689f9771efb42cb429f99530752f649643 100644 (file)
--- 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 7f9eaf58d6d0dffe78ef56dfb949fa9f3f655a80..f8a12913c914632c45cd5d31d10a38b2f574b9f3 100644 (file)
--- 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 (file)
index 0000000..fe51ff7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_stat_3.f90
@@ -0,0 +1,71 @@
+! { 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(80)        :: 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 (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=stat, errmsg=c(2:79))
+  deallocate (A,  stat=stat, errmsg=c(2:79))
+  allocate (A,    stat=stat, errmsg=z%s)
+  deallocate (A,  stat=stat, errmsg=z%s)
+  allocate (A,    stat=stat, errmsg=z%s(2:39))
+  deallocate (A,  stat=stat, errmsg=z%s(2:39))
+  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 61091ec41a04d86c8e21d00cacb5c1115149f6d1..8f93704ac4c4de50db0649b97973a0170b64b5d0 100644 (file)
--- 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 4e8d8a07b4e6ec5874507ed0f720f38e24b22375..7c1bf43785c5e7732b730ee634c6955060aeb551 100644 (file)
--- 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" }