re PR fortran/41872 (wrong-code: Issues with allocatable scalars)

2009-01-04  Tobias Burnus  <burnus@net-b.de>

        PR fortran/41872
        * trans-expr.c (gfc_conv_procedure_call): Add indirect ref
        for functions returning allocatable scalars.
        * trans-stmt.c (gfc_trans_allocate): Emmit error when
        reallocating an allocatable scalar.
        * trans.c (gfc_allocate_with_status): Fix pseudocode syntax
        in comment.
        * trans-decl.c (gfc_trans_deferred_vars): Nullify local
        allocatable scalars.
        (gfc_generate_function_code): Nullify result variable for
        allocatable scalars.
        
        PR fortran/40849
        * module.c (gfc_use_module): Fix warning string to allow
        for translation.

        PR fortran/42517
        * invoke.texi (-fcheck=recursion): Mention that the checking
        is also disabled for -frecursive.
        * trans-decl.c (gfc_generate_function_code): Disable
        -fcheck=recursion when -frecursive is used.

        * intrinsic.texi (iso_c_binding): Improve wording.

2009-01-04  Tobias Burnus  <burnus@net-b.de>

        PR fortran/41872
        * gfortran.dg/allocatable_scalar_5.f90: New test.
        * gfortran.dg/allocatable_scalar_6.f90: New test.

From-SVN: r155606

gcc/fortran/ChangeLog

+2010-01-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41872
+	* trans-expr.c (gfc_conv_procedure_call): Add indirect ref
+	for functions returning allocatable scalars.
+	* trans-stmt.c (gfc_trans_allocate): Emmit error when
+	reallocating an allocatable scalar.
+	* trans.c (gfc_allocate_with_status): Fix pseudocode syntax
+	in comment.
+	* trans-decl.c (gfc_trans_deferred_vars): Nullify local
+	allocatable scalars.
+	(gfc_generate_function_code): Nullify result variable for
+	allocatable scalars.
+	
+	PR fortran/40849
+	* module.c (gfc_use_module): Fix warning string to allow
+	for translation.
+
+	PR fortran/42517
+	* invoke.texi (-fcheck=recursion): Mention that the checking
+	is also disabled for -frecursive.
+	* trans-decl.c (gfc_generate_function_code): Disable
+	-fcheck=recursion when -frecursive is used.
+
+	* intrinsic.texi (iso_c_binding): Improve wording.
 
 
 Copyright (C) 2010 Free Software Foundation, Inc.

gcc/fortran/intrinsic.texi

@@ -11350,8 +11350,8 @@ C_INT_LEAST128_T, C_INT_FAST128_T}.
 @item @code{CHARACTER}@tab @code{C_CHAR}        @tab @code{char}
 @end multitable
 
-Additionally, the following @code{(CHARACTER(KIND=C_CHAR))} are
-defined.
+Additionally, the following parameters of type @code{CHARACTER(KIND=C_CHAR)}
+are defined.
 
 @multitable @columnfractions .20 .45 .15
 @item Name                     @tab C definition    @tab Value

gcc/fortran/invoke.texi

@@ -1258,7 +1258,7 @@ Enable generation of run-time checks for pointers and allocatables.
 Enable generation of run-time checks for recursively called subroutines and
 functions which are not marked as recursive. See also @option{-frecursive}.
 Note: This check does not work for OpenMP programs and is disabled if used
-together with @option{-fopenmp}.
+together with @option{-frecursive} and @option{-fopenmp}.
 @end table
 
 

gcc/fortran/module.c

@@ -5491,9 +5491,9 @@ gfc_use_module (void)
 
 	  if (strcmp (atom_string, MOD_VERSION))
 	    {
-	      gfc_fatal_error ("Wrong module version '%s' (expected '"
-			       MOD_VERSION "') for file '%s' opened"
-			       " at %C", atom_string, filename);
+	      gfc_fatal_error ("Wrong module version '%s' (expected '%s') "
+			       "for file '%s' opened at %C", atom_string,
+			       MOD_VERSION, filename);
 	    }
 	}
 

gcc/fortran/trans-decl.c

@@ -3188,7 +3188,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	       || (sym->ts.type == BT_CLASS
 		   && sym->ts.u.derived->components->attr.allocatable))
 	{
-	  /* Automatic deallocatation of allocatable scalars.  */
+	  /* Nullify and automatic deallocatation of allocatable scalars.  */
 	  tree tmp;
 	  gfc_expr *e;
 	  gfc_se se;
@@ -3203,10 +3203,13 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	  gfc_conv_expr (&se, e);
 	  gfc_free_expr (e);
 
+	  /* Nullify when entering the scope.  */
 	  gfc_start_block (&block);
+	  gfc_add_modify (&block, se.expr, fold_convert (TREE_TYPE (se.expr),
+							 null_pointer_node));
 	  gfc_add_expr_to_block (&block, fnbody);
 
-	  /* Note: Nullifying is not needed.  */
+	  /* Deallocate when leaving the scope. Nullifying is not needed.  */
 	  tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true, NULL);
 	  gfc_add_expr_to_block (&block, tmp);
 	  fnbody = gfc_finish_block (&block);
@@ -4319,7 +4322,7 @@ gfc_generate_function_code (gfc_namespace * ns)
 		  || (sym->attr.entry_master
 		      && sym->ns->entries->sym->attr.recursive);
    if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive
-       && !gfc_option.flag_openmp)
+       && !gfc_option.flag_recursive)
      {
        char * msg;
 
@@ -4384,14 +4387,19 @@ gfc_generate_function_code (gfc_namespace * ns)
 	result = sym->result->backend_decl;
 
       if (result != NULL_TREE && sym->attr.function
-	    && sym->ts.type == BT_DERIVED
-	    && sym->ts.u.derived->attr.alloc_comp
 	  && !sym->attr.pointer)
 	{
+	  if (sym->ts.type == BT_DERIVED
+	      && sym->ts.u.derived->attr.alloc_comp)
+	    {
 	      rank = sym->as ? sym->as->rank : 0;
 	      tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
 	      gfc_add_expr_to_block (&block, tmp2);
 	    }
+	  else if (sym->attr.allocatable && sym->attr.dimension == 0)
+	    gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),
+							  null_pointer_node));
+	}
 
       gfc_add_expr_to_block (&block, tmp);
 

gcc/fortran/trans-expr.c

@@ -3413,7 +3413,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
      something like
         x = f()
      where f is pointer valued, we have to dereference the result.  */
-  if (!se->want_pointer && !byref && sym->attr.pointer
+  if (!se->want_pointer && !byref
+      && (sym->attr.pointer || sym->attr.allocatable)
       && !gfc_is_proc_ptr_comp (expr, NULL))
     se->expr = build_fold_indirect_ref_loc (input_location,
 					se->expr);

gcc/fortran/trans-stmt.c

@@ -4059,7 +4059,32 @@ gfc_trans_allocate (gfc_code * code)
 	  if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
 	    memsz = se.string_length;
 
+	  /* Allocate - for non-pointers with re-alloc checking.  */
+	  {
+	    gfc_ref *ref;
+	    bool allocatable;
+
+	    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)
+	      allocatable = expr->symtree->n.sym->attr.allocatable;
+	    else
+	      allocatable = ref->u.c.component->attr.allocatable;
+
+	    if (allocatable)
+	      tmp = gfc_allocate_array_with_status (&se.pre, se.expr, memsz,
+						    pstat, expr);
+	    else
 	      tmp = gfc_allocate_with_status (&se.pre, memsz, pstat);
+	  }
+
 	  tmp = fold_build2 (MODIFY_EXPR, void_type_node, se.expr,
 			     fold_convert (TREE_TYPE (se.expr), tmp));
 	  gfc_add_expr_to_block (&se.pre, tmp);

gcc/fortran/trans.c

@@ -712,6 +712,7 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
 	else
 	  runtime_error ("Attempting to allocate already allocated array");
       }
+    }
     
     expr must be set to the original expression being allocated for its locus
     and variable name in case a runtime error has to be printed.  */

gcc/testsuite/ChangeLog

+2009-01-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41872
+	* gfortran.dg/allocatable_scalar_5.f90: New test.
+	* gfortran.dg/allocatable_scalar_6.f90: New test.
+
 2010-01-03  Richard Guenther  <rguenther@suse.de>
 
 	PR testsuite/42583

gcc/testsuite/gfortran.dg/allocatable_scalar_5.f90

+! { dg-do run }
+! { dg-options "-Wall -pedantic" }
+!
+! PR fortran/41872
+!
+!  More tests for allocatable scalars
+!
+program test
+  implicit none
+  integer, allocatable :: a
+  integer :: b
+
+  if (allocated (a)) call abort ()
+  if (allocated (func (.false.))) call abort ()
+  if (.not.allocated (func (.true.))) call abort ()
+  b = 7
+  b = func(.true.)
+  if (b /= 5332) call abort () 
+  b = 7
+  b = func(.true.) + 1
+  if (b /= 5333) call abort () 
+   
+  call intout (a, .false.)
+  if (allocated (a)) call abort ()
+  call intout (a, .true.)
+  if (.not.allocated (a)) call abort ()
+  if (a /= 764) call abort ()
+  call intout2 (a)
+  if (allocated (a)) call abort ()
+
+  if (allocated (func2 ())) call abort ()
+contains
+
+  function func (alloc)
+    integer, allocatable ::  func
+    logical :: alloc
+    if (allocated (func)) call abort ()
+    if (alloc) then
+      allocate(func)
+      func = 5332
+    end if
+  end function func
+
+  function func2 ()
+    integer, allocatable ::  func2
+  end function func2
+
+  subroutine intout (dum, alloc)
+    implicit none
+    integer, allocatable,intent(out) :: dum
+    logical :: alloc
+    if (allocated (dum)) call abort()
+    if (alloc) then
+      allocate (dum)
+      dum = 764
+    end if
+  end subroutine intout
+
+  subroutine intout2 (dum) ! { dg-warning "declared INTENT.OUT. but was not set" }
+    integer, allocatable,intent(out) :: dum
+  end subroutine intout2
+end program test

gcc/testsuite/gfortran.dg/allocatable_scalar_6.f90

+! { dg-do run }
+! { dg-options "-Wall -pedantic" }
+!
+! PR fortran/41872
+!
+!  (De)allocate tests
+!
+program test
+  implicit none
+  integer, allocatable :: a, b, c
+  integer :: stat
+  stat=99
+  allocate(a, stat=stat)
+  if (stat /= 0) call abort ()
+  allocate(a, stat=stat)
+  if (stat == 0) call abort ()
+
+  allocate (b)
+  deallocate (b, stat=stat)
+  if (stat /= 0) call abort ()
+  deallocate (b, stat=stat)
+  if (stat == 0) call abort ()
+
+  deallocate (c, stat=stat)
+  if (stat == 0) call abort ()
+end program test