re PR fortran/68078 (segfault with allocate and stat for derived types with default initialization)

2016-09-17  Louis Krupp  <louis.krupp@gmail.com>

	PR fortran/68078
	* gfortran.dg/pr68078.f90: New test.
	* gfortran.dg/set_vm_limit.c: New, called by pr68078.

2016_09_17  Louis Krupp  <louis.krupp@zoho.com>

	PR fortran/68078
	* resolve.c (resolve_allocate_expr): Check that derived type
	pointer, object or array has been successfully allocated before
	initializing.

From-SVN: r240219

gcc/fortran/ChangeLog

+2016_09_17  Louis Krupp  <louis.krupp@zoho.com>
+
+	PR fortran/68078
+	* resolve.c (resolve_allocate_expr): Check that derived type
+	pointer, object or array has been successfully allocated before
+	initializing.
+
 2016-09-16  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/77612

gcc/fortran/resolve.c

@@ -6928,6 +6928,35 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
   return true;
 }
 
+static void
+cond_init (gfc_code *code, gfc_expr *e, int pointer, gfc_expr *init_e)
+{
+  gfc_code *block;
+  gfc_expr *cond;
+  gfc_code *init_st;
+  gfc_expr *e_to_init = gfc_expr_to_initialize (e);
+
+  cond = pointer
+    ? gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_ASSOCIATED,
+	"associated", code->loc, 2, gfc_copy_expr (e_to_init), NULL)
+    : gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_ALLOCATED,
+	"allocated", code->loc, 1, gfc_copy_expr (e_to_init));
+
+  init_st = gfc_get_code (EXEC_INIT_ASSIGN);
+  init_st->loc = code->loc;
+  init_st->expr1 = e_to_init;
+  init_st->expr2 = init_e;
+
+  block = gfc_get_code (EXEC_IF);
+  block->loc = code->loc;
+  block->block = gfc_get_code (EXEC_IF);
+  block->block->loc = code->loc;
+  block->block->expr1 = cond;
+  block->block->next = init_st;
+  block->next = code->next;
+
+  code->next = block;
+}
 
 /* Resolve the expression in an ALLOCATE statement, doing the additional
    checks to see whether the expression is OK or not.  The expression must
@@ -7193,14 +7222,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
 	ts = ts.u.derived->components->ts;
 
       if (gfc_bt_struct (ts.type) && (init_e = gfc_default_initializer (&ts)))
-	{
-	  gfc_code *init_st = gfc_get_code (EXEC_INIT_ASSIGN);
-	  init_st->loc = code->loc;
-	  init_st->expr1 = gfc_expr_to_initialize (e);
-	  init_st->expr2 = init_e;
-	  init_st->next = code->next;
-	  code->next = init_st;
-	}
+	cond_init (code, e, pointer, init_e);
     }
   else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
     {

gcc/testsuite/ChangeLog

+2016-09-17  Louis Krupp  <louis.krupp@gmail.com>
+
+	PR fortran/68078
+	* gfortran.dg/pr68078.f90: New test.
+	* gfortran.dg/set_vm_limit.c: New, called by pr68078.
+
 2016-09-16  Bill Schmidt  <wschmidt@linux.vnet.ibm.com>
 
 	PR target/77613

gcc/testsuite/gfortran.dg/pr68078.f90

+! { dg-do run }
+! { dg-additional-sources set_vm_limit.c }
+
+USE :: ISO_C_BINDING !, only: C_INT
+IMPLICIT NONE
+
+INTERFACE
+  SUBROUTINE set_vm_limit(n) bind(C)
+  import
+  integer(C_INT), value, intent(in) :: n
+  END SUBROUTINE set_vm_limit
+END INTERFACE
+
+TYPE foo
+  INTEGER, DIMENSION(10000) :: data = 42
+END TYPE
+TYPE(foo), POINTER :: foo_ptr
+TYPE(foo), ALLOCATABLE :: foo_obj
+TYPE(foo), ALLOCATABLE, DIMENSION(:) :: foo_array
+
+INTEGER istat
+
+CALL set_vm_limit(1000000)
+
+DO
+  ALLOCATE(foo_ptr, stat = istat)
+  IF (istat .NE. 0) THEN
+    PRINT *, "foo_ptr allocation failed"
+    EXIT
+  ENDIF
+ENDDO
+
+ALLOCATE(foo_obj, stat = istat)
+IF (istat .NE. 0) THEN
+  PRINT *, "foo_obj allocation failed"
+ENDIF
+
+ALLOCATE(foo_array(5), stat = istat)
+IF (istat .NE. 0) THEN
+  PRINT *, "foo_array allocation failed"
+ENDIF
+
+END
+! { dg-output " *foo_ptr allocation failed(\n|\r\n|\r)" }
+! { dg-output " *foo_obj allocation failed(\n|\r\n|\r)" }
+! { dg-output " *foo_array allocation failed(\n|\r\n|\r)" }

gcc/testsuite/gfortran.dg/set_vm_limit.c

+/* Called by pr68078. */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <sys/time.h>
+#include <sys/resource.h>
+
+void
+set_vm_limit (int vm_limit)
+{
+  struct rlimit rl = { vm_limit, RLIM_INFINITY };
+  int r;
+
+  r = setrlimit (RLIMIT_AS, &rl);
+  if (r)
+    {
+      perror ("set_vm_limit");
+      exit (1);
+    }
+
+  return;
+}