fortran/

2005-03-05  Erik Edelmann  <eedelman@gcc.gnu.org>

        PR fortran/16136
        * symbol.c (conf_std): New macro.
        (check_conflict): Use it to allow ALLOCATABLE dummy
        arguments for F2003.
        * trans-expr.c (gfc_conv_function_call): Pass the
        address of the array descriptor when dummy argument is
        ALLOCATABLE.
        * interface.c (compare_allocatable): New function.
        (compare_actual_formal): Use it.
        resolve.c (resolve_deallocate_expr,
        resolve_allocate_expr): Check that INTENT(IN) variables
        aren't (de)allocated.
        * gfortran.texi (Fortran 2003 status): List ALLOCATABLE
        dummy arguments as supported.

testsuite/
2005-03-05  Erik Edelmann  <eedelman@gcc.gnu.org>

        PR fortran/16136
        * allocatable_dummy_1.f90: New.
        * allocatable_dummy_2.f90: New.



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

9 files changed, 161 insertions, 9 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4e4b241f488..e3fb42c97b3 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,20 @@
+2005-03-05  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/16136
+	* symbol.c (conf_std): New macro.
+	(check_conflict): Use it to allow ALLOCATABLE dummy
+	arguments for F2003.
+	* trans-expr.c (gfc_conv_function_call): Pass the
+	address of the array descriptor when dummy argument is
+	ALLOCATABLE.
+	* interface.c (compare_allocatable): New function.
+	(compare_actual_formal): Use it.
+	* resolve.c (resolve_deallocate_expr,
+	resolve_allocate_expr): Check that INTENT(IN) variables
+	aren't (de)allocated.
+	* gfortran.texi (Fortran 2003 status): List ALLOCATABLE
+	dummy arguments as supported.
+
 2006-03-03  Roger Sayle  <roger@eyesopen.com>
 
 	* dependency.c (gfc_check_element_vs_element): Revert last change.
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index c19b669a338..76969626391 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -1331,6 +1331,10 @@ Support for the declaration of enumeration constants via the
 @command{gcc} is guaranteed also for the case where the
 @command{-fshort-enums} command line option is given.
 
+@item
+@cindex @code{ALLOCATABLE} dummy arguments
+The @code{ALLOCATABLE} attribute for dummy arguments.
+
 @end itemize
 
 
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 7c8627952af..f4e522aadd9 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1065,6 +1065,26 @@ symbol_rank (gfc_symbol * sym)
 
 
 /* Given a symbol of a formal argument list and an expression, if the
+   formal argument is allocatable, check that the actual argument is
+   allocatable. Returns nonzero if compatible, zero if not compatible.  */
+
+static int
+compare_allocatable (gfc_symbol * formal, gfc_expr * actual)
+{
+  symbol_attribute attr;
+
+  if (formal->attr.allocatable)
+    {
+      attr = gfc_expr_attr (actual);
+      if (!attr.allocatable)
+	return 0;
+    }
+
+  return 1;
+}
+
+
+/* Given a symbol of a formal argument list and an expression, if the
    formal argument is a pointer, see if the actual argument is a
    pointer. Returns nonzero if compatible, zero if not compatible.  */
 
@@ -1276,6 +1296,15 @@ compare_actual_formal (gfc_actual_arglist ** ap,
 	  return 0;
 	}
 
+      if (a->expr->expr_type != EXPR_NULL
+	  && compare_allocatable (f->sym, a->expr) == 0)
+	{
+	  if (where)
+	    gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
+		       f->sym->name, &a->expr->where);
+	  return 0;
+	}
+
       /* Check intent = OUT/INOUT for definable actual argument.  */
       if (a->expr->expr_type != EXPR_VARIABLE
 	     && (f->sym->attr.intent == INTENT_OUT
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 63b2cd9904d..4bf394a1ff6 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2914,6 +2914,13 @@ resolve_deallocate_expr (gfc_expr * e)
 		 "ALLOCATABLE or a POINTER", &e->where);
     }
 
+  if (e->symtree->n.sym->attr.intent == INTENT_IN)
+    {
+      gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
+                 e->symtree->n.sym->name, &e->where);
+      return FAILURE;
+    }
+
   return SUCCESS;
 }
 
@@ -3015,6 +3022,13 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
       return FAILURE;
     }
 
+  if (e->symtree->n.sym->attr.intent == INTENT_IN)
+    {
+      gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
+                 e->symtree->n.sym->name, &e->where);
+      return FAILURE;
+    }
+
   /* Add default initializer for those derived types that need them.  */
   if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
     {
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 285c276be9e..e98556d2e1a 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -251,6 +251,13 @@ gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
 
 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
+#define conf_std(a, b, std) if (attr->a && attr->b)\
+                              {\
+                                a1 = a;\
+                                a2 = b;\
+                                standard = std;\
+                                goto conflict_std;\
+                              }
 
 static try
 check_conflict (symbol_attribute * attr, const char * name, locus * where)
@@ -268,6 +275,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
   static const char *threadprivate = "THREADPRIVATE";
 
   const char *a1, *a2;
+  int standard;
 
   if (where == NULL)
     where = &gfc_current_locus;
@@ -328,7 +336,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
     }
 
   conf (allocatable, pointer);
-  conf (allocatable, dummy);	/* TODO: Allowed in Fortran 200x.  */
+  conf_std (allocatable, dummy, GFC_STD_F2003);
   conf (allocatable, function);	/* TODO: Allowed in Fortran 200x.  */
   conf (allocatable, result);	/* TODO: Allowed in Fortran 200x.  */
   conf (elemental, recursive);
@@ -519,10 +527,25 @@ conflict:
 	       a1, a2, name, where);
 
   return FAILURE;
+
+conflict_std:
+  if (name == NULL)
+    {
+      return gfc_notify_std (standard, "In the selected standard, %s attribute "
+                             "conflicts with %s attribute at %L", a1, a2,
+                             where);
+    }
+  else
+    {
+      return gfc_notify_std (standard, "In the selected standard, %s attribute "
+                             "conflicts with %s attribute in '%s' at %L",
+                             a1, a2, name, where);
+    }
 }
 
 #undef conf
 #undef conf2
+#undef conf_std
 
 
 /* Mark a symbol as referenced.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9f5774bf815..1fc7f06feb0 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1870,16 +1870,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
             }
 	  else
 	    {
-	      /* If the procedure requires an explicit interface, the
-		 actual argument is passed according to the
-		 corresponding formal argument.  If the corresponding
-		 formal argument is a POINTER or assumed shape, we do
-		 not use g77's calling convention, and pass the
-		 address of the array descriptor instead. Otherwise we
-		 use g77's calling convention.  */
+              /* If the procedure requires an explicit interface, the actual
+                 argument is passed according to the corresponding formal
+                 argument.  If the corresponding formal argument is a POINTER,
+                 ALLOCATABLE or assumed shape, we do not use g77's calling
+                 convention, and pass the address of the array descriptor
+                 instead. Otherwise we use g77's calling convention.  */
 	      int f;
 	      f = (formal != NULL)
-		  && !formal->sym->attr.pointer
+		  && !(formal->sym->attr.pointer || formal->sym->attr.allocatable)
 		  && formal->sym->as->type != AS_ASSUMED_SHAPE;
 	      f = f || !sym->attr.always_explicit;
 	      if (arg->expr->expr_type == EXPR_VARIABLE
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e6f9d5e4df9..d38d9599825 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2005-03-05  Erik Edelmann  <eedelman@gcc.gnu.org>
+
+	PR fortran/16136
+	* allocatable_dummy_1.f90: New.
+	* allocatable_dummy_2.f90: New.
+
 2006-03-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libgfortran/26554
diff --git a/gcc/testsuite/gfortran.dg/allocatable_dummy_1.f90 b/gcc/testsuite/gfortran.dg/allocatable_dummy_1.f90
new file mode 100644
index 00000000000..f0581adf1e2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocatable_dummy_1.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+! Test procedures with allocatable dummy arguments
+program alloc_dummy
+
+    implicit none
+    integer, allocatable :: a(:)
+
+    call init(a)
+    if (.NOT.allocated(a)) call abort()
+    if (.NOT.all(a == [ 1, 2, 3 ])) call abort()
+
+    call kill(a)
+    if (allocated(a)) call abort()
+
+
+contains
+
+    subroutine init(x)
+        integer, allocatable, intent(out) :: x(:)
+
+        allocate(x(3))
+        x = [ 1, 2, 3 ]
+    end subroutine init
+
+    
+    subroutine kill(x)
+        integer, allocatable, intent(out) :: x(:)
+
+        deallocate(x)
+    end subroutine kill
+
+end program alloc_dummy
diff --git a/gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90 b/gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90
new file mode 100644
index 00000000000..46a6f4fa671
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+! Check a few constraints for ALLOCATABLE dummy arguments.
+program alloc_dummy
+
+    implicit none
+    integer :: a(5)
+
+    call init(a) ! { dg-error "must be ALLOCATABLE" }
+
+contains
+
+    subroutine init(x)
+        integer, allocatable, intent(out) :: x(:)
+    end subroutine init
+
+    subroutine init2(x)
+        integer, allocatable, intent(in) :: x(:)
+
+        allocate(x(3)) ! { dg-error "Can't allocate" }
+    end subroutine init2
+
+    subroutine kill(x)
+        integer, allocatable, intent(in) :: x(:)
+        
+        deallocate(x) ! { dg-error "Can't deallocate" }
+    end subroutine kill
+
+end program alloc_dummy