2009-08-31 Janus Weil <janus@gcc.gnu.org>

	PR fortran/40996
	* check.c (gfc_check_allocated): Implement allocatable scalars.
	* resolve.c (resolve_allocate_expr,resolve_fl_var_and_proc): Ditto.
	* trans-intrinsic.c (gfc_conv_allocated): Ditto.

2009-08-31  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40996
	* gfortran.dg/allocatable_scalar_1.f90: New.
	* gfortran.dg/allocatable_scalar_2.f90: Renamed from finalize_9.f03.
	* gfortran.dg/finalize_9.f03: Renamed to allocatable_scalar_2.f90.
	* gfortran.dg/proc_ptr_comp_pass_4.f90: Modified.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ce732e0..3d2aad6 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2009-08-31  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/40996
+       * check.c (gfc_check_allocated): Implement allocatable scalars.
+       * resolve.c (resolve_allocate_expr,resolve_fl_var_and_proc): Ditto.
+       * trans-intrinsic.c (gfc_conv_allocated): Ditto.
+
 2009-08-30  Daniel Kraft  <d@domob.eu>
 
        PR fortran/37425

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 6e2ce41..01775ab 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -546,9 +546,6 @@ gfc_check_allocated (gfc_expr *array)
       return FAILURE;
     }
 
-  if (array_check (array, 0) == FAILURE)
-    return FAILURE;
-
   return SUCCESS;
 }
 

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f10a412..b665c35 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5643,7 +5643,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
       code->next = init_st;
     }
 
-  if (pointer && dimension == 0)
+  if (pointer || dimension == 0)
     return SUCCESS;
 
   /* Make sure the next-to-last reference node is an array specification.  */
@@ -7955,11 +7955,14 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
       if (sym->attr.allocatable)
        {
          if (sym->attr.dimension)
-           gfc_error ("Allocatable array '%s' at %L must have "
-                      "a deferred shape", sym->name, &sym->declared_at);
-         else
-           gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
-                      sym->name, &sym->declared_at);
+           {
+             gfc_error ("Allocatable array '%s' at %L must have "
+                        "a deferred shape", sym->name, &sym->declared_at);
+             return FAILURE;
+           }
+         else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
+                                  "may not be ALLOCATABLE", sym->name,
+                                  &sym->declared_at) == FAILURE)
            return FAILURE;
        }
 

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 3b2cbd1..b9e5b86 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -4564,10 +4564,22 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
   gfc_init_se (&arg1se, NULL);
   arg1 = expr->value.function.actual;
   ss1 = gfc_walk_expr (arg1->expr);
-  arg1se.descriptor_only = 1;
-  gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
 
-  tmp = gfc_conv_descriptor_data_get (arg1se.expr);
+  if (ss1 == gfc_ss_terminator)
+    {
+      /* Allocatable scalar.  */
+      arg1se.want_pointer = 1;
+      gfc_conv_expr (&arg1se, arg1->expr);
+      tmp = arg1se.expr;
+    }
+  else
+    {
+      /* Allocatable array.  */
+      arg1se.descriptor_only = 1;
+      gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
+      tmp = gfc_conv_descriptor_data_get (arg1se.expr);
+    }
+
   tmp = fold_build2 (NE_EXPR, boolean_type_node,
                     tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3173f57..6641a43 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2009-08-31  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/40996
+       * gfortran.dg/allocatable_scalar_1.f90: New.
+       * gfortran.dg/allocatable_scalar_2.f90: Renamed from finalize_9.f03.
+       * gfortran.dg/finalize_9.f03: Renamed to allocatable_scalar_2.f90.
+       * gfortran.dg/proc_ptr_comp_pass_4.f90: Modified.
+
 2009-08-30  Richard Guenther  <rguenther@suse.de>
 
        PR tree-optimization/41186

diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_1.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_1.f90
new file mode 100644 (file)
index 0000000..d83d2f7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_1.f90
@@ -0,0 +1,18 @@
+! { dg-do run }
+!
+! PR 40996: [F03] ALLOCATABLE scalars
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+implicit none
+real, allocatable :: scalar
+
+allocate(scalar)
+scalar = exp(1.)
+print *,scalar
+if (.not. allocated(scalar)) call abort()
+deallocate(scalar)
+if (allocated(scalar)) call abort()
+
+end
+

diff --git a/gcc/testsuite/gfortran.dg/finalize_9.f03 b/gcc/testsuite/gfortran.dg/allocatable_scalar_2.f90
similarity index 89%
rename from gcc/testsuite/gfortran.dg/finalize_9.f03
rename to gcc/testsuite/gfortran.dg/allocatable_scalar_2.f90
index 464036e..5ad58ca 100644 (file)
--- a/gcc/testsuite/gfortran.dg/finalize_9.f03
+++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_2.f90
@@ -1,8 +1,11 @@
 ! { dg-do compile }
+! { dg-options "-std=f95" }
 
 ! Parsing of finalizer procedure definitions.
 ! While ALLOCATABLE scalars are not implemented, this even used to ICE.
 ! Thanks Tobias Burnus for the test!
 
 integer, allocatable :: x ! { dg-error "may not be ALLOCATABLE" }
+
 end
+

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90
index b52c810..0a28b53 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90
@@ -51,7 +51,7 @@ contains
   type(t2) :: y2
  end subroutine
 
- subroutine foo3 (x3,y3)  ! { dg-error "may not be ALLOCATABLE" }
+ subroutine foo3 (x3,y3)
   type(t3),allocatable :: x3
   type(t3) :: y3
  end subroutine