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.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index af2d0c6..c033b6e 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,28 @@
+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.
 
 \f
 Copyright (C) 2010 Free Software Foundation, Inc.

diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 753e6e1..d37c807 100644 (file)
--- a/gcc/fortran/intrinsic.texi
+++ b/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

diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index b9ad170..21db293 100644 (file)
--- a/gcc/fortran/invoke.texi
+++ b/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
 
 

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 81a2613..a07af9a 100644 (file)
--- a/gcc/fortran/module.c
+++ b/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);
            }
        }
 

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 9a01dba..f93cc9f 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/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,13 +4387,18 @@ 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)
+         && !sym->attr.pointer)
        {
-         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);
+         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);

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b0c19c9..84eb585 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/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);

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 32c6efc..5159f42 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/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;
 
-         tmp = gfc_allocate_with_status (&se.pre, memsz, pstat);
+         /* 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);

diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 42d2238..a107392 100644 (file)
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -711,6 +711,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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c2b04d8..c16e2d4 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_5.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_5.f90
new file mode 100644 (file)
index 0000000..cee95a1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_5.f90
@@ -0,0 +1,62 @@
+! { 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

diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_6.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_6.f90
new file mode 100644 (file)
index 0000000..33daee4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_6.f90
@@ -0,0 +1,26 @@
+! { 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