OSDN Git Service

* builtin-types.def (BT_FN_PTR_PTR_SIZE): New type.
authorfxcoudert <fxcoudert@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 29 Aug 2007 12:44:32 +0000 (12:44 +0000)
committerfxcoudert <fxcoudert@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 29 Aug 2007 12:44:32 +0000 (12:44 +0000)
* 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:
gcc/ChangeLog
gcc/builtin-types.def
gcc/builtins.def
gcc/fortran/ChangeLog
gcc/fortran/f95-lang.c
gcc/fortran/trans-array.c
gcc/fortran/trans-decl.c
gcc/fortran/trans-stmt.c
gcc/fortran/trans.c
gcc/fortran/trans.h
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
libgfortran/ChangeLog
libgfortran/gfortran.map
libgfortran/libgfortran.h
libgfortran/runtime/memory.c

index 5300252..c649ee2 100644 (file)
@@ -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
index 792e8da..081a33f 100644 (file)
@@ -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,
index 628fd25..8bedfbf 100644 (file)
@@ -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)
index 582d035..b523e8a 100644 (file)
@@ -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
index 1e1b640..05f6750 100644 (file)
@@ -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,
index 73a57e8..09d20cd 100644 (file)
@@ -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.  */
index 047ced9..8ea25fc 100644 (file)
@@ -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;
 
index 47e0822..f900ec5 100644 (file)
@@ -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,
index 7092ac8..1113e80 100644 (file)
@@ -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
index 48bc9fc..1991748 100644 (file)
@@ -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;
index eb9c329..1878af1 100644 (file)
@@ -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
index a4617cb..fc58bf4 100644 (file)
@@ -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" } }
index 9beca6d..969e703 100644 (file)
@@ -104,5 +104,5 @@ contains
     end function blaha\r
 \r
 end program test_constructor\r
-! { dg-final { scan-tree-dump-times "deallocate" 18 "original" } }\r
+! { dg-final { scan-tree-dump-times "builtin_free" 19 "original" } }\r
 ! { dg-final { cleanup-tree-dump "original" } }\r
index 42d4da2..aa1df6a 100644 (file)
@@ -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
index 31ca41e..429c84c 100644 (file)
@@ -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;
index 555c6bf..d068a75 100644 (file)
@@ -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,
index f1991cd..7407486 100644 (file)
@@ -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;
-}