* builtin-types.def (BT_FN_PTR_PTR_SIZE): New type.

	* builtins.def (BUILT_IN_REALLOC): New builtin.

	* trans-array.c (gfc_grow_array): Use gfc_call_realloc.
	(gfc_array_allocate): Use gfc_allocate_with_status and
	gfc_allocate_array_with_status.
	(gfc_array_deallocate): Use gfc_deallocate_with_status.
	(gfc_trans_dealloc_allocated): Use gfc_deallocate_with_status.
	* trans-stmt.c (gfc_trans_allocate): Use gfc_allocate_with_status.
	(gfc_trans_deallocate): Use gfc_deallocate_with_status.
	* trans.c (gfc_allocate_with_status, gfc_allocate_array_with_status,
	gfc_deallocate_with_status, gfc_call_realloc): New functions.
	* trans.h (gfc_allocate_with_status, gfc_allocate_array_with_status,
	gfc_deallocate_with_status, gfc_call_realloc): New prototypes.
	(gfor_fndecl_internal_realloc, gfor_fndecl_allocate,
	gfor_fndecl_allocate_array, gfor_fndecl_deallocate): Remove.
	* f95-lang.c (gfc_init_builtin_functions): Create decl for
	BUILT_IN_REALLOC.
	* trans-decl.c (gfor_fndecl_internal_realloc,
	gfor_fndecl_allocate, gfor_fndecl_allocate_array,
	gfor_fndecl_deallocate): Remove function decls.
	(gfc_build_builtin_function_decls): Likewise.

	* runtime/memory.c (internal_realloc, allocate, allocate_array,
	deallocate): Remove functions.
	* gfortran.map (_gfortran_allocate, _gfortran_allocate_array,
	_gfortran_deallocate, _gfortran_internal_realloc): Remove symbols.
	* libgfortran.h (error_codes): Add comment.

	* gfortran.dg/alloc_comp_basics_1.f90: Update check.
	* gfortran.dg/alloc_comp_constructor_1.f90: Update check.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127897 138bc75d-0d04-0410-961f-82ee72b054a4

17 files changed, 452 insertions, 205 deletions

diff --git a/gcc/ChangeLog b/gcc/ChangeLog
index 5300252823f..c649ee24f2b 100644
--- a/gcc/ChangeLog
+++ b/gcc/ChangeLog
@@ -1,3 +1,8 @@
+2007-08-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* gcc/builtin-types.def (BT_FN_PTR_PTR_SIZE): New type.
+	* gcc/builtins.def (BUILT_IN_REALLOC): New builtin.
+
 2007-08-29  Douglas Gregor  <doug.gregor@gmail.com>
 
 	PR c++/33194
diff --git a/gcc/builtin-types.def b/gcc/builtin-types.def
index 792e8da7097..081a33f0467 100644
--- a/gcc/builtin-types.def
+++ b/gcc/builtin-types.def
@@ -289,6 +289,8 @@ DEF_FUNCTION_TYPE_2 (BT_FN_INT_CONST_STRING_VALIST_ARG,
 		     BT_INT, BT_CONST_STRING, BT_VALIST_ARG)
 DEF_FUNCTION_TYPE_2 (BT_FN_PTR_SIZE_SIZE,
 		     BT_PTR, BT_SIZE, BT_SIZE)
+DEF_FUNCTION_TYPE_2 (BT_FN_PTR_PTR_SIZE,
+		     BT_PTR, BT_PTR, BT_SIZE)
 DEF_FUNCTION_TYPE_2 (BT_FN_COMPLEX_FLOAT_COMPLEX_FLOAT_COMPLEX_FLOAT,
 		     BT_COMPLEX_FLOAT, BT_COMPLEX_FLOAT, BT_COMPLEX_FLOAT)
 DEF_FUNCTION_TYPE_2 (BT_FN_COMPLEX_DOUBLE_COMPLEX_DOUBLE_COMPLEX_DOUBLE,
diff --git a/gcc/builtins.def b/gcc/builtins.def
index 628fd257e9e..8bedfbf30e9 100644
--- a/gcc/builtins.def
+++ b/gcc/builtins.def
@@ -687,6 +687,7 @@ DEF_GCC_BUILTIN        (BUILT_IN_POPCOUNTIMAX, "popcountimax", BT_FN_INT_UINTMAX
 DEF_GCC_BUILTIN        (BUILT_IN_POPCOUNTL, "popcountl", BT_FN_INT_ULONG, ATTR_CONST_NOTHROW_LIST)
 DEF_GCC_BUILTIN        (BUILT_IN_POPCOUNTLL, "popcountll", BT_FN_INT_ULONGLONG, ATTR_CONST_NOTHROW_LIST)
 DEF_GCC_BUILTIN        (BUILT_IN_PREFETCH, "prefetch", BT_FN_VOID_CONST_PTR_VAR, ATTR_NOVOPS_LIST)
+DEF_LIB_BUILTIN        (BUILT_IN_REALLOC, "realloc", BT_FN_PTR_PTR_SIZE, ATTR_NOTHROW_LIST)
 DEF_GCC_BUILTIN        (BUILT_IN_RETURN, "return", BT_FN_VOID_PTR, ATTR_NORETURN_NOTHROW_LIST)
 DEF_GCC_BUILTIN        (BUILT_IN_RETURN_ADDRESS, "return_address", BT_FN_PTR_UINT, ATTR_NULL)
 DEF_GCC_BUILTIN        (BUILT_IN_SAVEREGS, "saveregs", BT_FN_PTR_VAR, ATTR_NULL)
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 582d035f186..b523e8aa007 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,25 @@
+2007-08-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* trans-array.c (gfc_grow_array): Use gfc_call_realloc.
+	(gfc_array_allocate): Use gfc_allocate_with_status and
+	gfc_allocate_array_with_status.
+	(gfc_array_deallocate): Use gfc_deallocate_with_status.
+	(gfc_trans_dealloc_allocated): Use gfc_deallocate_with_status.
+	* trans-stmt.c (gfc_trans_allocate): Use gfc_allocate_with_status.
+	(gfc_trans_deallocate): Use gfc_deallocate_with_status.
+	* trans.c (gfc_allocate_with_status, gfc_allocate_array_with_status,
+	gfc_deallocate_with_status, gfc_call_realloc): New functions.
+	* trans.h (gfc_allocate_with_status, gfc_allocate_array_with_status,
+	gfc_deallocate_with_status, gfc_call_realloc): New prototypes.
+	(gfor_fndecl_internal_realloc, gfor_fndecl_allocate,
+	gfor_fndecl_allocate_array, gfor_fndecl_deallocate): Remove.
+	* f95-lang.c (gfc_init_builtin_functions): Create decl for
+	BUILT_IN_REALLOC.
+	* trans-decl.c (gfor_fndecl_internal_realloc,
+	gfor_fndecl_allocate, gfor_fndecl_allocate_array,
+	gfor_fndecl_deallocate): Remove function decls.
+	(gfc_build_builtin_function_decls): Likewise.
+
 2007-08-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/33055
diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c
index 1e1b640537e..05f6750218d 100644
--- a/gcc/fortran/f95-lang.c
+++ b/gcc/fortran/f95-lang.c
@@ -1036,6 +1036,12 @@ gfc_init_builtin_functions (void)
 		      "malloc", false);
   DECL_IS_MALLOC (built_in_decls[BUILT_IN_MALLOC]) = 1;
 
+  tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node);
+  tmp = tree_cons (NULL_TREE, size_type_node, tmp);
+  ftype = build_function_type (pvoid_type_node, tmp);
+  gfc_define_builtin ("__builtin_realloc", ftype, BUILT_IN_REALLOC,
+		      "realloc", false);
+
   tmp = tree_cons (NULL_TREE, void_type_node, void_list_node);
   ftype = build_function_type (integer_type_node, tmp);
   gfc_define_builtin ("__builtin_isnan", ftype, BUILT_IN_ISNAN,
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 73a57e82c4c..09d20cd4291 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -843,17 +843,11 @@ gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
   /* Calculate the new array size.  */
   size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
   tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
-  arg1 = build2 (MULT_EXPR, gfc_array_index_type, tmp,
-		 fold_convert (gfc_array_index_type, size));
+  arg1 = build2 (MULT_EXPR, size_type_node, fold_convert (size_type_node, tmp),
+		 fold_convert (size_type_node, size));
 
-  /* Pick the realloc function.  */
-  if (gfc_index_integer_kind == 4 || gfc_index_integer_kind == 8)
-    tmp = gfor_fndecl_internal_realloc;
-  else
-    gcc_unreachable ();
-
-  /* Set the new data pointer.  */
-  tmp = build_call_expr (tmp, 2, arg0, arg1);
+  /* Call the realloc() function.  */
+  tmp = gfc_call_realloc (pblock, arg0, arg1);
   gfc_conv_descriptor_data_set (pblock, desc, tmp);
 }
 
@@ -3571,7 +3565,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
 {
   tree tmp;
   tree pointer;
-  tree allocate;
   tree offset;
   tree size;
   gfc_expr **lower;
@@ -3629,22 +3622,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
   pointer = gfc_conv_descriptor_data_get (se->expr);
   STRIP_NOPS (pointer);
 
-  if (TYPE_PRECISION (gfc_array_index_type) == 32 ||
-      TYPE_PRECISION (gfc_array_index_type) == 64)
-    {
-      if (allocatable_array)
-	allocate = gfor_fndecl_allocate_array;
-      else
-	allocate = gfor_fndecl_allocate;
-    }
-  else
-    gcc_unreachable ();
-
   /* The allocate_array variants take the old pointer as first argument.  */
   if (allocatable_array)
-    tmp = build_call_expr (allocate, 3, pointer, size, pstat);
+    tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat);
   else
-    tmp = build_call_expr (allocate, 2, size, pstat);
+    tmp = gfc_allocate_with_status (&se->pre, size, pstat);
   tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
   gfc_add_expr_to_block (&se->pre, tmp);
 
@@ -3680,7 +3662,7 @@ gfc_array_deallocate (tree descriptor, tree pstat)
   STRIP_NOPS (var);
 
   /* Parameter is the address of the data component.  */
-  tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, pstat);
+  tmp = gfc_deallocate_with_status (var, pstat, false);
   gfc_add_expr_to_block (&block, tmp);
 
   /* Zero the data pointer.  */
@@ -4998,7 +4980,6 @@ tree
 gfc_trans_dealloc_allocated (tree descriptor)
 { 
   tree tmp;
-  tree ptr;
   tree var;
   stmtblock_t block;
 
@@ -5006,13 +4987,11 @@ gfc_trans_dealloc_allocated (tree descriptor)
 
   var = gfc_conv_descriptor_data_get (descriptor);
   STRIP_NOPS (var);
-  tmp = gfc_create_var (gfc_array_index_type, NULL);
-  ptr = build_fold_addr_expr (tmp);
 
-  /* Call array_deallocate with an int* present in the second argument.
+  /* Call array_deallocate with an int * present in the second argument.
      Although it is ignored here, it's presence ensures that arrays that
      are already deallocated are ignored.  */
-  tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, ptr);
+  tmp = gfc_deallocate_with_status (var, NULL_TREE, true);
   gfc_add_expr_to_block (&block, tmp);
 
   /* Zero the data pointer.  */
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 047ced92c1b..8ea25fc2532 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -73,10 +73,6 @@ tree gfc_static_ctors;
 
 /* Function declarations for builtin library functions.  */
 
-tree gfor_fndecl_internal_realloc;
-tree gfor_fndecl_allocate;
-tree gfor_fndecl_allocate_array;
-tree gfor_fndecl_deallocate;
 tree gfor_fndecl_pause_numeric;
 tree gfor_fndecl_pause_string;
 tree gfor_fndecl_stop_numeric;
@@ -2273,35 +2269,10 @@ void
 gfc_build_builtin_function_decls (void)
 {
   tree gfc_int4_type_node = gfc_get_int_type (4);
-  tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
-
-  gfor_fndecl_internal_realloc =
-    gfc_build_library_function_decl (get_identifier
-				     (PREFIX("internal_realloc")),
-				     pvoid_type_node, 2, pvoid_type_node,
-				     gfc_array_index_type);
-
-  gfor_fndecl_allocate =
-    gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
-				     pvoid_type_node, 2,
-				     gfc_array_index_type, gfc_pint4_type_node);
-  DECL_IS_MALLOC (gfor_fndecl_allocate) = 1;
-
-  gfor_fndecl_allocate_array =
-    gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
-				     pvoid_type_node, 3, pvoid_type_node,
-				     gfc_array_index_type, gfc_pint4_type_node);
-  DECL_IS_MALLOC (gfor_fndecl_allocate_array) = 1;
-
-  gfor_fndecl_deallocate =
-    gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
-				     void_type_node, 2, pvoid_type_node,
-				     gfc_pint4_type_node);
 
   gfor_fndecl_stop_numeric =
     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
 				     void_type_node, 1, gfc_int4_type_node);
-
   /* Stop doesn't return.  */
   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
 
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 47e08229fe9..f900ec52f4b 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -3565,11 +3565,7 @@ gfc_trans_allocate (gfc_code * code)
       TREE_USED (error_label) = 1;
     }
   else
-    {
-      pstat = integer_zero_node;
-      stat = error_label = NULL_TREE;
-    }
-
+    pstat = stat = error_label = NULL_TREE;
 
   for (al = code->ext.alloc_list; al != NULL; al = al->next)
     {
@@ -3590,7 +3586,7 @@ gfc_trans_allocate (gfc_code * code)
 	  if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
 	    tmp = se.string_length;
 
-	  tmp = build_call_expr (gfor_fndecl_allocate, 2, tmp, pstat);
+	  tmp = gfc_allocate_with_status (&se.pre, tmp, pstat);
 	  tmp = build2 (MODIFY_EXPR, void_type_node, se.expr,
 			fold_convert (TREE_TYPE (se.expr), tmp));
 	  gfc_add_expr_to_block (&se.pre, tmp);
@@ -3679,10 +3675,7 @@ gfc_trans_deallocate (gfc_code * code)
       gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
     }
   else
-    {
-      pstat = apstat = null_pointer_node;
-      stat = astat = NULL_TREE;
-    }
+    pstat = apstat = stat = astat = NULL_TREE;
 
   for (al = code->ext.alloc_list; al != NULL; al = al->next)
     {
@@ -3720,7 +3713,7 @@ gfc_trans_deallocate (gfc_code * code)
 	tmp = gfc_array_deallocate (se.expr, pstat);
       else
 	{
-	  tmp = build_call_expr (gfor_fndecl_deallocate, 2, se.expr, pstat);
+	  tmp = gfc_deallocate_with_status (se.expr, pstat, false);
 	  gfc_add_expr_to_block (&se.pre, tmp);
 
 	  tmp = build2 (MODIFY_EXPR, void_type_node,
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 7092ac8cd0a..1113e80fdc3 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -473,6 +473,222 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
   return res;
 }
 
+/* The status variable of allocate statement is set to ERROR_ALLOCATION 
+   when the allocation wasn't successful. This value needs to be kept in
+   sync with libgfortran/libgfortran.h.  */
+#define ERROR_ALLOCATION 5014
+
+/* Allocate memory, using an optional status argument.
+ 
+   This function follows the following pseudo-code:
+
+    void *
+    allocate (size_t size, integer_type* stat)
+    {
+      void *newmem;
+    
+      if (stat)
+        *stat = 0;
+
+      // The only time this can happen is the size wraps around.
+      if (size < 0)
+      {
+        if (stat)
+        {
+          *stat = ERROR_ALLOCATION;
+          newmem = NULL;
+        }
+        else
+          runtime_error ("Attempt to allocate negative amount of memory. "
+                         "Possible integer overflow");
+      }
+      else
+      {
+        newmem = malloc (MAX (size, 1));
+        if (newmem == NULL)
+        {
+          if (stat)
+            *stat = ERROR_ALLOCATION;
+          else
+            runtime_error ("Out of memory");
+        }
+      }
+
+      return newmem;
+    }  */
+tree
+gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
+{
+  stmtblock_t alloc_block;
+  tree res, tmp, error, msg, cond;
+  tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
+
+  /* Evaluate size only once, and make sure it has the right type.  */
+  size = gfc_evaluate_now (size, block);
+  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+    size = fold_convert (size_type_node, size);
+
+  /* Create a variable to hold the result.  */
+  res = gfc_create_var (pvoid_type_node, NULL);
+
+  /* Set the optional status variable to zero.  */
+  if (status != NULL_TREE && !integer_zerop (status))
+    {
+      tmp = fold_build2 (MODIFY_EXPR, status_type,
+			 build1 (INDIRECT_REF, status_type, status),
+			 build_int_cst (status_type, 0));
+      tmp = fold_build3 (COND_EXPR, void_type_node,
+			 fold_build2 (NE_EXPR, boolean_type_node,
+				      status, build_int_cst (status_type, 0)),
+			 tmp, build_empty_stmt ());
+      gfc_add_expr_to_block (block, tmp);
+    }
+
+  /* Generate the block of code handling (size < 0).  */
+  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
+			("Attempt to allocate negative amount of memory. "
+			 "Possible integer overflow"));
+  error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
+
+  if (status != NULL_TREE && !integer_zerop (status))
+    {
+      /* Set the status variable if it's present.  */
+      stmtblock_t set_status_block;
+
+      gfc_start_block (&set_status_block);
+      gfc_add_modify_expr (&set_status_block,
+			   build1 (INDIRECT_REF, status_type, status),
+			   build_int_cst (status_type, ERROR_ALLOCATION));
+      gfc_add_modify_expr (&set_status_block, res,
+			   build_int_cst (pvoid_type_node, 0));
+
+      tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
+			 build_int_cst (status_type, 0));
+      error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
+			   gfc_finish_block (&set_status_block));
+    }
+
+  /* The allocation itself.  */
+  gfc_start_block (&alloc_block);
+  gfc_add_modify_expr (&alloc_block, res,
+		       build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
+					fold_build2 (MAX_EXPR, size_type_node,
+						     size,
+						     build_int_cst (size_type_node, 1))));
+
+  msg = gfc_build_addr_expr (pchar_type_node,
+			     gfc_build_cstring_const ("Out of memory"));
+  tmp = build_call_expr (gfor_fndecl_os_error, 1, msg);
+
+  if (status != NULL_TREE && !integer_zerop (status))
+    {
+      /* Set the status variable if it's present.  */
+      tree tmp2;
+
+      cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
+			  build_int_cst (status_type, 0));
+      tmp2 = fold_build2 (MODIFY_EXPR, status_type,
+			  build1 (INDIRECT_REF, status_type, status),
+			  build_int_cst (status_type, ERROR_ALLOCATION));
+      tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
+			 tmp2);
+    }
+
+  tmp = fold_build3 (COND_EXPR, void_type_node,
+		     fold_build2 (EQ_EXPR, boolean_type_node, res,
+				  build_int_cst (pvoid_type_node, 0)),
+		     tmp, build_empty_stmt ());
+  gfc_add_expr_to_block (&alloc_block, tmp);
+
+  cond = fold_build2 (LT_EXPR, boolean_type_node, size,
+		      build_int_cst (TREE_TYPE (size), 0));
+  tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
+		     gfc_finish_block (&alloc_block));
+  gfc_add_expr_to_block (block, tmp);
+
+  return res;
+}
+
+
+/* Generate code for an ALLOCATE statement when the argument is an
+   allocatable array.  If the array is currently allocated, it is an
+   error to allocate it again.
+ 
+   This function follows the following pseudo-code:
+  
+    void *
+    allocate_array (void *mem, size_t size, integer_type *stat)
+    {
+      if (mem == NULL)
+	return allocate (size, stat);
+      else
+      {
+	if (stat)
+	{
+	  free (mem);
+	  mem = allocate (size, stat);
+	  *stat = ERROR_ALLOCATION;
+	  return mem;
+	}
+	else
+	  runtime_error ("Attempting to allocate already allocated array");
+    }  */
+tree
+gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
+				tree status)
+{
+  stmtblock_t alloc_block;
+  tree res, tmp, null_mem, alloc, error, msg;
+  tree type = TREE_TYPE (mem);
+
+  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+    size = fold_convert (size_type_node, size);
+
+  /* Create a variable to hold the result.  */
+  res = gfc_create_var (pvoid_type_node, NULL);
+  null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
+			  build_int_cst (type, 0));
+
+  /* If mem is NULL, we call gfc_allocate_with_status.  */
+  gfc_start_block (&alloc_block);
+  tmp = gfc_allocate_with_status (&alloc_block, size, status);
+  gfc_add_modify_expr (&alloc_block, res, fold_convert (type, tmp));
+  alloc = gfc_finish_block (&alloc_block);
+
+  /* Otherwise, we issue a runtime error or set the status variable.  */
+  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
+			("Attempting to allocate already allocated array"));
+  error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
+
+  if (status != NULL_TREE && !integer_zerop (status))
+    {
+      tree status_type = TREE_TYPE (TREE_TYPE (status));
+      stmtblock_t set_status_block;
+
+      gfc_start_block (&set_status_block);
+      tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
+			     fold_convert (pvoid_type_node, mem));
+      gfc_add_expr_to_block (&set_status_block, tmp);
+
+      tmp = gfc_allocate_with_status (&set_status_block, size, status);
+      gfc_add_modify_expr (&set_status_block, res, fold_convert (type, tmp));
+
+      gfc_add_modify_expr (&set_status_block,
+			   build1 (INDIRECT_REF, status_type, status),
+			   build_int_cst (status_type, ERROR_ALLOCATION));
+
+      tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
+			 build_int_cst (status_type, 0));
+      error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
+			   gfc_finish_block (&set_status_block));
+    }
+
+  tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
+  gfc_add_expr_to_block (block, tmp);
+
+  return res;
+}
+
 
 /* Free a given variable, if it's not NULL.  */
 tree
@@ -497,6 +713,163 @@ gfc_call_free (tree var)
 }
 
 
+
+/* User-deallocate; we emit the code directly from the front-end, and the
+   logic is the same as the previous library function:
+
+    void
+    deallocate (void *pointer, GFC_INTEGER_4 * stat)
+    {
+      if (!pointer)
+	{
+	  if (stat)
+	    *stat = 1;
+	  else
+	    runtime_error ("Attempt to DEALLOCATE unallocated memory.");
+	}
+      else
+	{
+	  free (pointer);
+	  if (stat)
+	    *stat = 0;
+	}
+    }
+
+   In this front-end version, status doesn't have to be GFC_INTEGER_4.
+   Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
+   even when no status variable is passed to us (this is used for
+   unconditional deallocation generated by the front-end at end of
+   each procedure).  */
+tree
+gfc_deallocate_with_status (tree pointer, tree status, bool can_fail)
+{
+  stmtblock_t null, non_null;
+  tree cond, tmp, error, msg;
+
+  cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
+		      build_int_cst (TREE_TYPE (pointer), 0));
+
+  /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
+     we emit a runtime error.  */
+  gfc_start_block (&null);
+  if (!can_fail)
+    {
+      msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
+			("Attempt to DEALLOCATE unallocated memory."));
+      error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
+    }
+  else
+    error = build_empty_stmt ();
+
+  if (status != NULL_TREE && !integer_zerop (status))
+    {
+      tree status_type = TREE_TYPE (TREE_TYPE (status));
+      tree cond2;
+
+      cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
+			   build_int_cst (TREE_TYPE (status), 0));
+      tmp = fold_build2 (MODIFY_EXPR, status_type,
+			 build1 (INDIRECT_REF, status_type, status),
+			 build_int_cst (status_type, 1));
+      error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
+    }
+
+  gfc_add_expr_to_block (&null, error);
+
+  /* When POINTER is not NULL, we free it.  */
+  gfc_start_block (&non_null);
+  tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
+			 fold_convert (pvoid_type_node, pointer));
+  gfc_add_expr_to_block (&non_null, tmp);
+
+  if (status != NULL_TREE && !integer_zerop (status))
+    {
+      /* We set STATUS to zero if it is present.  */
+      tree status_type = TREE_TYPE (TREE_TYPE (status));
+      tree cond2;
+
+      cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
+			   build_int_cst (TREE_TYPE (status), 0));
+      tmp = fold_build2 (MODIFY_EXPR, status_type,
+			 build1 (INDIRECT_REF, status_type, status),
+			 build_int_cst (status_type, 0));
+      tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
+			 build_empty_stmt ());
+      gfc_add_expr_to_block (&non_null, tmp);
+    }
+
+  return fold_build3 (COND_EXPR, void_type_node, cond,
+		      gfc_finish_block (&null), gfc_finish_block (&non_null));
+}
+
+
+/* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
+   following pseudo-code:
+
+void *
+internal_realloc (void *mem, size_t size)
+{
+  if (size < 0)
+    runtime_error ("Attempt to allocate a negative amount of memory.");
+  mem = realloc (mem, size);
+  if (!mem && size != 0)
+    _gfortran_os_error ("Out of memory");
+
+  if (size == 0)
+    return NULL;
+
+  return mem;
+}  */
+tree
+gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
+{
+  tree msg, res, negative, zero, null_result, tmp;
+  tree type = TREE_TYPE (mem);
+
+  size = gfc_evaluate_now (size, block);
+
+  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+    size = fold_convert (size_type_node, size);
+
+  /* Create a variable to hold the result.  */
+  res = gfc_create_var (type, NULL);
+
+  /* size < 0 ?  */
+  negative = fold_build2 (LT_EXPR, boolean_type_node, size,
+			  build_int_cst (size_type_node, 0));
+  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
+      ("Attempt to allocate a negative amount of memory."));
+  tmp = fold_build3 (COND_EXPR, void_type_node, negative,
+		     build_call_expr (gfor_fndecl_runtime_error, 1, msg),
+		     build_empty_stmt ());
+  gfc_add_expr_to_block (block, tmp);
+
+  /* Call realloc and check the result.  */
+  tmp = build_call_expr (built_in_decls[BUILT_IN_REALLOC], 2,
+			 fold_convert (pvoid_type_node, mem), size);
+  gfc_add_modify_expr (block, res, fold_convert (type, tmp));
+  null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
+			     build_int_cst (pvoid_type_node, 0));
+  zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
+		      build_int_cst (size_type_node, 0));
+  null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
+			     zero);
+  msg = gfc_build_addr_expr (pchar_type_node,
+			     gfc_build_cstring_const ("Out of memory"));
+  tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
+		     build_call_expr (gfor_fndecl_os_error, 1, msg),
+		     build_empty_stmt ());
+  gfc_add_expr_to_block (block, tmp);
+
+  /* if (size == 0) then the result is NULL.  */
+  tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
+  tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
+		     build_empty_stmt ());
+  gfc_add_expr_to_block (block, tmp);
+
+  return res;
+}
+
 /* Add a statement to a block.  */
 
 void
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 48bc9fce8cb..1991748eccc 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -450,6 +450,18 @@ tree gfc_call_free (tree);
 /* Allocate memory after performing a few checks.  */
 tree gfc_call_malloc (stmtblock_t *, tree, tree);
 
+/* Allocate memory for arrays, with optional status variable.  */
+tree gfc_allocate_array_with_status (stmtblock_t *, tree, tree, tree);
+
+/* Allocate memory, with optional status variable.  */
+tree gfc_allocate_with_status (stmtblock_t *, tree, tree);
+
+/* Generate code to deallocate an array.  */
+tree gfc_deallocate_with_status (tree, tree, bool);
+
+/* Generate code to call realloc().  */
+tree gfc_call_realloc (stmtblock_t *, tree, tree);
+
 /* Generate code for an assignment, includes scalarization.  */
 tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool);
 
@@ -483,10 +495,6 @@ struct gimplify_omp_ctx;
 void gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *, tree);
 
 /* Runtime library function decls.  */
-extern GTY(()) tree gfor_fndecl_internal_realloc;
-extern GTY(()) tree gfor_fndecl_allocate;
-extern GTY(()) tree gfor_fndecl_allocate_array;
-extern GTY(()) tree gfor_fndecl_deallocate;
 extern GTY(()) tree gfor_fndecl_pause_numeric;
 extern GTY(()) tree gfor_fndecl_pause_string;
 extern GTY(()) tree gfor_fndecl_stop_numeric;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index eb9c329684a..1878af1d1fb 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-08-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* gfortran.dg/alloc_comp_basics_1.f90: Update check.
+	* gfortran.dg/alloc_comp_constructor_1.f90: Update check.
+
 2007-08-29  Douglas Gregor  <doug.gregor@gmail.com>
 
 	PR c++/33194
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
index a4617cbf01e..fc58bf44830 100644
--- a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
@@ -139,6 +139,6 @@ contains
     end subroutine check_alloc2
 
 end program alloc
-! { dg-final { scan-tree-dump-times "deallocate" 24 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 24 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
 ! { dg-final { cleanup-modules "alloc_m" } }
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
index 9beca6d0b7f..969e703094c 100644
--- a/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
@@ -104,5 +104,5 @@ contains
     end function blaha

 

 end program test_constructor

-! { dg-final { scan-tree-dump-times "deallocate" 18 "original" } }

+! { dg-final { scan-tree-dump-times "builtin_free" 19 "original" } }

 ! { dg-final { cleanup-tree-dump "original" } }

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 42d4da2c37b..aa1df6aa7a6 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,11 @@
+2007-08-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* runtime/memory.c (internal_realloc, allocate, allocate_array,
+	deallocate): Remove functions.
+	* gfortran.map (_gfortran_allocate, _gfortran_allocate_array,
+	_gfortran_deallocate, _gfortran_internal_realloc): Remove symbols.
+	* libgfortran.h (error_codes): Add comment.
+
 2007-08-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libfortran/33055
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index 31ca41e9f88..429c84c8c4a 100644
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -11,8 +11,6 @@ GFORTRAN_1.0 {
     _gfortran_all_l16;
     _gfortran_all_l4;
     _gfortran_all_l8;
-    _gfortran_allocate;
-    _gfortran_allocate_array;
     _gfortran_any_l16;
     _gfortran_any_l4;
     _gfortran_any_l8;
@@ -60,7 +58,6 @@ GFORTRAN_1.0 {
     _gfortran_ctime;
     _gfortran_ctime_sub;
     _gfortran_date_and_time;
-    _gfortran_deallocate;
     _gfortran_eoshift0_1;
     _gfortran_eoshift0_1_char;
     _gfortran_eoshift0_2;
@@ -167,7 +164,6 @@ GFORTRAN_1.0 {
     _gfortran_ierrno_i4;
     _gfortran_ierrno_i8;
     _gfortran_internal_pack;
-    _gfortran_internal_realloc;
     _gfortran_internal_unpack;
     _gfortran_irand;
     _gfortran_isatty_l4;
diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h
index 555c6bfd4a8..d068a753fa4 100644
--- a/libgfortran/libgfortran.h
+++ b/libgfortran/libgfortran.h
@@ -447,7 +447,9 @@ typedef enum
   ERROR_READ_OVERFLOW,
   ERROR_INTERNAL,
   ERROR_INTERNAL_UNIT,
-  ERROR_ALLOCATION,
+  ERROR_ALLOCATION,		/* Keep in sync with value used in
+				   gcc/fortran/trans.c
+				   (gfc_allocate_array_with_status).  */
   ERROR_DIRECT_EOR,
   ERROR_SHORT_RECORD,
   ERROR_CORRUPT_FILE,
diff --git a/libgfortran/runtime/memory.c b/libgfortran/runtime/memory.c
index f1991cda324..7407486b696 100644
--- a/libgfortran/runtime/memory.c
+++ b/libgfortran/runtime/memory.c
@@ -38,10 +38,6 @@ Boston, MA 02110-1301, USA.  */
    performance is desired, but it can help when you're debugging code.  */
 /* #define GFC_CLEAR_MEMORY */
 
-/* If GFC_CHECK_MEMORY is defined, we do some sanity checks at runtime.
-   This causes small overhead, but again, it also helps debugging.  */
-#define GFC_CHECK_MEMORY
-
 void *
 get_mem (size_t n)
 {
@@ -76,123 +72,3 @@ internal_malloc_size (size_t size)
 
   return get_mem (size);
 }
-
-
-/* Reallocate internal memory MEM so it has SIZE bytes of data.
-   Allocate a new block if MEM is zero, and free the block if
-   SIZE is 0.  */
-
-extern void *internal_realloc (void *, index_type);
-export_proto(internal_realloc);
-
-void *
-internal_realloc (void *mem, index_type size)
-{
-#ifdef GFC_CHECK_MEMORY
-  /* Under normal circumstances, this is _never_ going to happen!  */
-  if (size < 0)
-    runtime_error ("Attempt to allocate a negative amount of memory.");
-#endif
-  mem = realloc (mem, size);
-  if (!mem && size != 0)
-    os_error ("Out of memory.");
-  
-  if (size == 0)
-      return NULL;
-
-  return mem;
-}
-
-
-/* User-allocate, one call for each member of the alloc-list of an
-   ALLOCATE statement. */
-
-extern void *allocate (index_type, GFC_INTEGER_4 *) __attribute__ ((malloc));
-export_proto(allocate);
-
-void *
-allocate (index_type size, GFC_INTEGER_4 * stat)
-{
-  void *newmem;
-
-#ifdef GFC_CHECK_MEMORY
-  /* The only time this can happen is the size computed by the
-     frontend wraps around.  */
-  if (size < 0)
-    {
-      if (stat)
-	{
-	  *stat = ERROR_ALLOCATION;
-	  return NULL;
-	}
-      else
-	runtime_error ("Attempt to allocate negative amount of memory. "
-		       "Possible integer overflow");
-    }
-#endif
-  newmem = malloc (size ? size : 1);
-  if (!newmem)
-    {
-      if (stat)
-	{
-	  *stat = ERROR_ALLOCATION;
-	  return newmem;
-	}
-      else
-	runtime_error ("ALLOCATE: Out of memory.");
-    }
-
-  if (stat)
-    *stat = 0;
-
-  return newmem;
-}
-
-/* Function to call in an ALLOCATE statement when the argument is an
-   allocatable array.  If the array is currently allocated, it is
-   an error to allocate it again.  */
-
-extern void *allocate_array (void *, index_type, GFC_INTEGER_4 *);
-export_proto(allocate_array);
-
-void *
-allocate_array (void *mem, index_type size, GFC_INTEGER_4 * stat)
-{
-  if (mem == NULL)
-    return allocate (size, stat);
-  if (stat)
-    {
-      free (mem);
-      mem = allocate (size, stat);
-      *stat = ERROR_ALLOCATION;
-      return mem;
-    }
-
-  runtime_error ("Attempting to allocate already allocated array.");
-}
-
-
-/* User-deallocate; pointer is then NULLified by the front-end. */
-
-extern void deallocate (void *, GFC_INTEGER_4 *);
-export_proto(deallocate);
-
-void
-deallocate (void *mem, GFC_INTEGER_4 * stat)
-{
-  if (!mem)
-    {
-      if (stat)
-	{
-	  *stat = 1;
-	  return;
-	}
-      else
-	runtime_error ("Internal: Attempt to DEALLOCATE unallocated memory.");
-    }
-
-  free (mem);
-
-  if (stat)
-    *stat = 0;
-}