Fortran: improve runtime error message with ALLOCATE and ERRMSG= [PR91300]

ALLOCATE: generate different STAT,ERRMSG results for failures from
allocation of already allocated objects or insufficient virtual memory.

gcc/fortran/ChangeLog:

	PR fortran/91300
	* libgfortran.h: Define new error code LIBERROR_NO_MEMORY.
	* trans-stmt.cc (gfc_trans_allocate): Generate code for setting
	ERRMSG depending on result of STAT result of ALLOCATE.
	* trans.cc (gfc_allocate_using_malloc): Use STAT value of
	LIBERROR_NO_MEMORY in case of failed malloc.

gcc/testsuite/ChangeLog:

	PR fortran/91300
	* gfortran.dg/allocate_alloc_opt_15.f90: New test.

diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 064795eb4699c93d8468950a4719b6125ecc2b29..4328447be04b8e02d82fb66f4b5d984ba2bb2ac8 100644 (file)
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -133,6 +133,7 @@ typedef enum
   LIBERROR_CORRUPT_FILE,
   LIBERROR_INQUIRE_INTERNAL_UNIT, /* Must be different from STAT_STOPPED_IMAGE.  */
   LIBERROR_BAD_WAIT_ID,
+  LIBERROR_NO_MEMORY,
   LIBERROR_LAST                        /* Not a real error, the last error # + 1.  */
 }
 libgfortran_error_codes;

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 79096816c6e9fcf6dac3ec68b960d596c1598583..fd6d294147e21bc6ab40fefb5841b6fa205528e3 100644 (file)
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -7130,7 +7130,8 @@ gfc_trans_allocate (gfc_code * code)
   if (code->expr1 && code->expr2)
     {
       const char *msg = "Attempt to allocate an allocated object";
-      tree slen, dlen, errmsg_str;
+      const char *oommsg = "Insufficient virtual memory";
+      tree slen, dlen, errmsg_str, oom_str, oom_loc;
       stmtblock_t errmsg_block;
 
       gfc_init_block (&errmsg_block);
@@ -7151,8 +7152,34 @@ gfc_trans_allocate (gfc_code * code)
                             gfc_default_character_kind);
       dlen = gfc_finish_block (&errmsg_block);
 
-      tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
-                            stat, build_int_cst (TREE_TYPE (stat), 0));
+      tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+                            stat, build_int_cst (TREE_TYPE (stat),
+                                                 LIBERROR_ALLOCATION));
+
+      tmp = build3_v (COND_EXPR, tmp,
+                     dlen, build_empty_stmt (input_location));
+
+      gfc_add_expr_to_block (&block, tmp);
+
+      oom_str = gfc_create_var (pchar_type_node, "OOMMSG");
+      oom_loc = gfc_build_localized_cstring_const (oommsg);
+      gfc_add_modify (&errmsg_block, oom_str,
+                     gfc_build_addr_expr (pchar_type_node, oom_loc));
+
+      slen = build_int_cst (gfc_charlen_type_node, strlen (oommsg));
+      dlen = gfc_get_expr_charlen (code->expr2);
+      slen = fold_build2_loc (input_location, MIN_EXPR,
+                             TREE_TYPE (slen), dlen, slen);
+
+      gfc_trans_string_copy (&errmsg_block, dlen, errmsg,
+                            code->expr2->ts.kind,
+                            slen, oom_str,
+                            gfc_default_character_kind);
+      dlen = gfc_finish_block (&errmsg_block);
+
+      tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+                            stat, build_int_cst (TREE_TYPE (stat),
+                                                 LIBERROR_NO_MEMORY));
 
       tmp = build3_v (COND_EXPR, tmp,
                      dlen, build_empty_stmt (input_location));

diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index f0a5dfb50fc60a913c5930254b58be1ffed02ff1..912a206f2ed75d952d692217e960d3aa4eb78760 100644 (file)
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -772,7 +772,7 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
       if (newmem == NULL)
       {
         if (stat)
-          *stat = LIBERROR_ALLOCATION;
+         *stat = LIBERROR_NO_MEMORY;
         else
          runtime_error ("Allocation would exceed memory limit");
       }
@@ -807,7 +807,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
   if (status != NULL_TREE)
     {
       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status,
-                            build_int_cst (status_type, LIBERROR_ALLOCATION));
+                            build_int_cst (status_type, LIBERROR_NO_MEMORY));
       gfc_add_expr_to_block (&on_error, tmp);
     }
   else

diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_15.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_15.f90
new file mode 100644 (file)
index 0000000..3c26e81
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_15.f90
@@ -0,0 +1,49 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+! PR fortran/91300 - runtime error message with allocate and errmsg=
+! Contributed by zed.three
+
+program bigarray_prog
+  use, intrinsic :: iso_c_binding, only: C_INTPTR_T
+  implicit none
+  real(4), dimension(:), allocatable :: array, bigarray
+  integer                 :: stat1, stat2
+  character(len=100)      :: errmsg1, errmsg2
+  character(*), parameter :: no_error = "no error"
+  integer(8), parameter :: n1 = huge (1_4) / 3          ! request more than 2GB
+  integer(8), parameter :: n2 = huge (1_C_INTPTR_T) / 4 ! "safe" for 64bit
+  integer(8), parameter :: bignumber = max (n1, n2)
+
+  stat1   = -1
+  stat2   = -1
+  errmsg1 = no_error
+  errmsg2 = no_error
+  allocate (array(1), stat=stat1, errmsg=errmsg1)
+  if (stat1   /= 0       ) stop 1
+  if (errmsg1 /= no_error) stop 1
+
+  ! Obtain stat, errmsg for attempt to allocate an allocated object
+  allocate (array(1), stat=stat1, errmsg=errmsg1)
+  if (stat1   == 0       ) stop 2
+  if (errmsg1 == no_error) stop 2
+
+  ! Try to allocate very large object
+  allocate (bigarray(bignumber), stat=stat2, errmsg=errmsg2)
+  if (stat2 /= 0) then
+     print *, "stat1 =", stat1
+     print *, "errmsg: ", trim (errmsg1)
+     print *, "stat2 =", stat2
+     print *, "errmsg: ", trim (errmsg2)
+     ! Ensure different results for stat, errmsg variables (all compilers)
+     if (stat2   == stat1                           ) stop 3
+     if (errmsg2 == no_error .or. errmsg2 == errmsg1) stop 4
+
+     ! Finally verify gfortran-specific error messages
+     if (errmsg1 /= "Attempt to allocate an allocated object") stop 5
+     if (errmsg2 /= "Insufficient virtual memory"            ) stop 6
+  end if
+
+end program bigarray_prog
+
+! { dg-final { scan-tree-dump-times "Attempt to allocate an allocated object" 4 "original" } }
+! { dg-final { scan-tree-dump-times "Insufficient virtual memory" 4 "original" } }