fortran: Fix deref of optional in gen. code. [PR100337]

gcc/fortran/ChangeLog:

	PR fortran/100337
	* trans-intrinsic.c (conv_co_collective): Check stat for null ptr
	before dereferrencing.

gcc/testsuite/ChangeLog:

	PR fortran/100337
	* gfortran.dg/coarray_collectives_17.f90: New test.

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index e578449..46670ba 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -11242,8 +11242,28 @@ conv_co_collective (gfc_code *code)
   if (flag_coarray == GFC_FCOARRAY_SINGLE)
     {
       if (stat != NULL_TREE)
-       gfc_add_modify (&block, stat,
-                       fold_convert (TREE_TYPE (stat), integer_zero_node));
+       {
+         /* For optional stats, check the pointer is valid before zero'ing.  */
+         if (gfc_expr_attr (stat_expr).optional)
+           {
+             tree tmp;
+             stmtblock_t ass_block;
+             gfc_start_block (&ass_block);
+             gfc_add_modify (&ass_block, stat,
+                             fold_convert (TREE_TYPE (stat),
+                                           integer_zero_node));
+             tmp = fold_build2 (NE_EXPR, logical_type_node,
+                                gfc_build_addr_expr (NULL_TREE, stat),
+                                null_pointer_node);
+             tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
+                                gfc_finish_block (&ass_block),
+                                build_empty_stmt (input_location));
+             gfc_add_expr_to_block (&block, tmp);
+           }
+         else
+           gfc_add_modify (&block, stat,
+                           fold_convert (TREE_TYPE (stat), integer_zero_node));
+       }
       return gfc_finish_block (&block);
     }
 

diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_17.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_17.f90
new file mode 100644 (file)
index 0000000..84a6645
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_collectives_17.f90
@@ -0,0 +1,42 @@
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! PR 100337
+! Test case inspired by code submitted by Brad Richardson
+
+program main
+    implicit none
+
+    integer, parameter :: MESSAGE = 42
+    integer :: result
+
+    call myco_broadcast(MESSAGE, result, 1)
+
+    if (result /= MESSAGE) error stop 1
+contains
+    subroutine myco_broadcast(m, r, source_image, stat, errmsg)
+        integer, intent(in) :: m
+        integer, intent(out) :: r
+        integer, intent(in) :: source_image
+        integer, intent(out), optional :: stat
+        character(len=*), intent(inout), optional :: errmsg
+
+        integer :: data_length 
+
+        data_length = 1
+
+        call co_broadcast(data_length, source_image, stat, errmsg)
+
+        if (present(stat)) then
+            if (stat /= 0) return
+        end if
+
+        if (this_image() == source_image) then
+            r = m
+        end if
+
+        call co_broadcast(r, source_image, stat, errmsg)
+    end subroutine
+
+end program
+