re PR fortran/25031 ([4.1 only] Allocatable array can be reallocated.)

2006-03-03  Thomas Koenig  <Thomas.Koenig@online.de>

	PR fortran/25031
	* trans-array.h:  Adjust gfc_array_allocate prototype.
	* trans-array.c (gfc_array_allocate):  Change type of
	gfc_array_allocatate to bool.  Function returns true if
	it operates on an array.  Change second argument to gfc_expr.
	Find last reference in chain.
	If the function operates on an allocatable array, emit call to
	allocate_array() or allocate64_array().
	* trans-stmt.c (gfc_trans_allocate):  Code to follow to last
	reference has been moved to gfc_array_allocate.
	* trans.h:  Add declaration for gfor_fndecl_allocate_array and
	gfor_fndecl_allocate64_array.
	(gfc_build_builtin_function_decls):  Add gfor_fndecl_allocate_array
	and gfor_fndecl_allocate64_array.

2006-03-03  Thomas Koenig  <Thomas.Koenig@online.de>

	PR fortran/25031
	* runtime/memory.c:  Adjust copyright years.
	(allocate_array):  New function.
	(allocate64_array):  New function.
	* libgfortran.h (error_codes):  Add ERROR_ALLOCATION.

2006-03-03  Thomas Koenig  <Thomas.Koenig@online.de>

	PR fortran/25031
	* multiple_allocation_1.f90:  New test.

From-SVN: r111677

gcc/fortran/ChangeLog

+2006-03-03  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/25031
+	* trans-array.h:  Adjust gfc_array_allocate prototype.
+	* trans-array.c (gfc_array_allocate):  Change type of
+	gfc_array_allocatate to bool.  Function returns true if
+	it operates on an array.  Change second argument to gfc_expr.
+	Find last reference in chain.
+	If the function operates on an allocatable array, emit call to
+	allocate_array() or allocate64_array().
+	* trans-stmt.c (gfc_trans_allocate):  Code to follow to last
+	reference has been moved to gfc_array_allocate.
+	* trans.h:  Add declaration for gfor_fndecl_allocate_array and
+	gfor_fndecl_allocate64_array.
+	(gfc_build_builtin_function_decls):  Add gfor_fndecl_allocate_array
+	and gfor_fndecl_allocate64_array.
+
 2006-03-01  Roger Sayle  <roger@eyesopen.com>
 
 	* trans-stmt.c (generate_loop_for_temp_to_lhs): Add an additional

gcc/fortran/trans-array.c

@@ -3001,8 +3001,8 @@ gfc_array_init_size (tree descriptor, int rank, tree * poffset,
    the work for an ALLOCATE statement.  */
 /*GCC ARRAYS*/
 
-void
-gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
+bool
+gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
 {
   tree tmp;
   tree pointer;
@@ -3011,6 +3011,20 @@ gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
   tree size;
   gfc_expr **lower;
   gfc_expr **upper;
+  gfc_ref *ref;
+  int allocatable_array;
+
+  ref = expr->ref;
+
+  /* Find the last reference in the chain.  */
+  while (ref && ref->next != NULL)
+    {
+      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
+      ref = ref->next;
+    }
+
+  if (ref == NULL || ref->type != REF_ARRAY)
+    return false;
 
   /* Figure out the size of the array.  */
   switch (ref->u.ar.type)
@@ -3044,10 +3058,22 @@ gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
   tmp = gfc_conv_descriptor_data_addr (se->expr);
   pointer = gfc_evaluate_now (tmp, &se->pre);
 
+  allocatable_array = expr->symtree->n.sym->attr.allocatable;
+
   if (TYPE_PRECISION (gfc_array_index_type) == 32)
-    allocate = gfor_fndecl_allocate;
+    {
+      if (allocatable_array)
+	allocate = gfor_fndecl_allocate_array;
+      else
+	allocate = gfor_fndecl_allocate;
+    }
   else if (TYPE_PRECISION (gfc_array_index_type) == 64)
-    allocate = gfor_fndecl_allocate64;
+    {
+      if (allocatable_array)
+	allocate = gfor_fndecl_allocate64_array;
+      else
+	allocate = gfor_fndecl_allocate64;
+    }
   else
     gcc_unreachable ();
 
@@ -3059,6 +3085,8 @@ gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
 
   tmp = gfc_conv_descriptor_offset (se->expr);
   gfc_add_modify_expr (&se->pre, tmp, offset);
+
+  return true;
 }
 
 

gcc/fortran/trans-array.h

@@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree);
 
 /* Generate code to initialize an allocate an array.  Statements are added to
    se, which should contain an expression for the array descriptor.  */
-void gfc_array_allocate (gfc_se *, gfc_ref *, tree);
+bool gfc_array_allocate (gfc_se *, gfc_expr *, tree);
 
 /* Allow the bounds of a loop to be set from a callee's array spec.  */
 void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,

gcc/fortran/trans-decl.c

@@ -80,6 +80,8 @@ tree gfor_fndecl_internal_realloc64;
 tree gfor_fndecl_internal_free;
 tree gfor_fndecl_allocate;
 tree gfor_fndecl_allocate64;
+tree gfor_fndecl_allocate_array;
+tree gfor_fndecl_allocate64_array;
 tree gfor_fndecl_deallocate;
 tree gfor_fndecl_pause_numeric;
 tree gfor_fndecl_pause_string;
@@ -2193,6 +2195,16 @@ gfc_build_builtin_function_decls (void)
 				     void_type_node, 2, ppvoid_type_node,
 				     gfc_int8_type_node);
 
+  gfor_fndecl_allocate_array =
+    gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
+				     void_type_node, 2, ppvoid_type_node,
+				     gfc_int4_type_node);
+
+  gfor_fndecl_allocate64_array =
+    gfc_build_library_function_decl (get_identifier (PREFIX("allocate64_array")),
+				     void_type_node, 2, ppvoid_type_node,
+				     gfc_int8_type_node);
+
   gfor_fndecl_deallocate =
     gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
 				     void_type_node, 2, ppvoid_type_node,

gcc/fortran/trans-stmt.c

@@ -3389,7 +3389,6 @@ gfc_trans_allocate (gfc_code * code)
   gfc_se se;
   tree tmp;
   tree parm;
-  gfc_ref *ref;
   tree stat;
   tree pstat;
   tree error_label;
@@ -3428,21 +3427,7 @@ gfc_trans_allocate (gfc_code * code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
-      ref = expr->ref;
-
-      /* Find the last reference in the chain.  */
-      while (ref && ref->next != NULL)
-	{
-	  gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
-	  ref = ref->next;
-	}
-
-      if (ref != NULL && ref->type == REF_ARRAY)
-	{
-	  /* An array.  */
-	  gfc_array_allocate (&se, ref, pstat);
-	}
-      else
+      if (!gfc_array_allocate (&se, expr, pstat))
 	{
 	  /* A scalar or derived type.  */
 	  tree val;

gcc/fortran/trans.h

@@ -455,6 +455,8 @@ extern GTY(()) tree gfor_fndecl_internal_realloc64;
 extern GTY(()) tree gfor_fndecl_internal_free;
 extern GTY(()) tree gfor_fndecl_allocate;
 extern GTY(()) tree gfor_fndecl_allocate64;
+extern GTY(()) tree gfor_fndecl_allocate_array;
+extern GTY(()) tree gfor_fndecl_allocate64_array;
 extern GTY(()) tree gfor_fndecl_deallocate;
 extern GTY(()) tree gfor_fndecl_pause_numeric;
 extern GTY(()) tree gfor_fndecl_pause_string;

gcc/testsuite/ChangeLog

+2006-03-03  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/25031
+	* multiple_allocation_1.f90:  New test.
+
 2006-03-03  Roger Sayle  <roger@eyesopen.com>
 
 	PR tree-optimization/26524

gcc/testsuite/gfortran.dg/multiple_allocation_1.f90

+! { dg-do run }
+! PR 25031 - We didn't cause an error when allocating an already
+!            allocated array.
+program alloc_test
+  implicit none
+  integer :: i
+  integer, allocatable :: a(:)
+  integer, pointer :: b(:)
+
+  allocate(a(4))
+  ! This should set the stat code without changing the size
+  allocate(a(4),stat=i)
+  if (i == 0) call abort
+  if (.not. allocated(a)) call abort
+  ! It's OK to allocate pointers twice (even though this causes
+  ! a memory leak)
+  allocate(b(4))
+  allocate(b(4))
+end program

libgfortran/ChangeLog

+2006-03-03  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR fortran/25031
+	* runtime/memory.c:  Adjust copyright years.
+	(allocate_array):  New function.
+	(allocate64_array):  New function.
+	* libgfortran.h (error_codes):  Add ERROR_ALLOCATION.
+
 2006-02-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libgfortran/26136

libgfortran/libgfortran.h

@@ -379,6 +379,7 @@ typedef enum
   ERROR_READ_OVERFLOW,
   ERROR_INTERNAL,
   ERROR_INTERNAL_UNIT,
+  ERROR_ALLOCATION,
   ERROR_LAST			/* Not a real error, the last error # + 1.  */
 }
 error_codes;

libgfortran/runtime/memory.c

 /* Memory mamagement routines.
-   Copyright 2002, 2005 Free Software Foundation, Inc.
+   Copyright 2002, 2005, 2006 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -233,6 +233,51 @@ allocate64 (void **mem, GFC_INTEGER_8 size, GFC_INTEGER_4 * stat)
   allocate_size (mem, (size_t) size, stat);
 }
 
+/* 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.  32-bit version.  */
+
+extern void allocate_array (void **, GFC_INTEGER_4, GFC_INTEGER_4 *);
+export_proto(allocate_array);
+
+void
+allocate_array (void **mem, GFC_INTEGER_4 size, GFC_INTEGER_4 * stat)
+{
+  if (*mem == NULL)
+    {
+      allocate (mem, size, stat);
+      return;
+    }
+  if (stat)
+    *stat = ERROR_ALLOCATION;
+  else
+    runtime_error ("Attempting to allocate already allocated array.");
+
+  return;
+}
+
+/* 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.  64-bit version.  */
+
+extern void allocate64_array (void **, GFC_INTEGER_8, GFC_INTEGER_4 *);
+export_proto(allocate64_array);
+
+void
+allocate64_array (void **mem, GFC_INTEGER_8 size, GFC_INTEGER_4 * stat)
+{
+  if (*mem == NULL)
+    {
+      allocate64 (mem, size, stat);
+      return;
+    }
+  if (stat)
+    *stat = ERROR_ALLOCATION;
+  else
+    runtime_error ("Attempting to allocate already allocated array.");
+  
+  return;
+}
 
 /* User-deallocate; pointer is NULLified. */