The new comment in the patch explains the patch. This was
developed and tested on 8-branch, but will be applied to
trunk prior to committing to branches. Built and regression
tested on x86_64-*-freebsd. OK to commit?
2018-05-29 Steven G. Kargl <ka...@gcc.gnu.org>
PR fortran/85981
* resolve.c (resolve_allocate_deallocate): Check errmsg is default
character kind.
2018-05-29 Steven G. Kargl <ka...@gcc.gnu.org>
PR fortran/85981
* gfortran.dg/allocate_alloc_opt_14.f90: New test.
* gfortran.dg/allocate_alloc_opt_1.f90: Update error string.
* gfortran.dg/allocate_stat_2.f90: Ditto.
* gfortran.dg/deallocate_alloc_opt_1.f90: Ditto.
--
Steve
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 260769)
+++ gcc/fortran/resolve.c (working copy)
@@ -7763,12 +7763,17 @@ resolve_allocate_deallocate (gfc_code *code, const cha
gfc_check_vardef_context (errmsg, false, false, false,
_("ERRMSG variable"));
+ /* 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)))
- || errmsg->rank > 0 )
- gfc_error ("Errmsg-variable at %L must be a scalar 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);
for (p = code->ext.alloc.list; p; p = p->next)
Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_alloc_opt_1.f90 (revision 260767)
+++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_1.f90 (working copy)
@@ -22,7 +22,7 @@ program a
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(i(2), stat=j, errmsg=x) ! { dg-error "shall be a scalar default CHARACTER" }
allocate(err) ! { dg-error "neither a data pointer nor an allocatable" }
Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_14.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_alloc_opt_14.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_14.f90 (working copy)
@@ -0,0 +1,8 @@
+! { dg-do compile }
+program p
+ integer, allocatable :: arr(:)
+ integer :: stat
+ character(len=128, kind=4) :: errmsg = ' '
+ allocate (arr(3), stat=stat, errmsg=errmsg) ! { dg-error "shall be a scalar default CHARACTER" }
+ print *, allocated(arr), stat, trim(errmsg)
+end
Index: gcc/testsuite/gfortran.dg/allocate_stat_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_stat_2.f90 (revision 260767)
+++ gcc/testsuite/gfortran.dg/allocate_stat_2.f90 (working copy)
@@ -5,6 +5,6 @@ program main
character(len=30), dimension(2) :: er
integer, dimension (:), allocatable :: a
allocate (a (16), stat = ier) ! { dg-error "must be a scalar INTEGER" }
- allocate (a (14), stat=ier(1),errmsg=er) ! { dg-error "must be a scalar CHARACTER" }
+ allocate (a (14), stat=ier(1),errmsg=er) ! { dg-error "shall be a scalar default CHARACTER" }
end
Index: gcc/testsuite/gfortran.dg/deallocate_alloc_opt_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/deallocate_alloc_opt_1.f90 (revision 260767)
+++ gcc/testsuite/gfortran.dg/deallocate_alloc_opt_1.f90 (working copy)
@@ -22,7 +22,7 @@ program a
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(i, stat=j, errmsg=x) ! { dg-error "shall be a scalar default CHARACTER" }
deallocate(err) ! { dg-error "nonprocedure pointer nor an allocatable" }
