re PR fortran/38936 ([F03] ASSOCIATE construct / improved SELECT TYPE (a=>expr))

2010-09-23  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	PR fortran/44044
	PR fortran/45474
	* gfortran.h (gfc_check_vardef_context): New method.
	(struct symbol_attribute): New flag `select_type_temporary'.
	* primary.c (gfc_variable_attr): Clarify initialization of ref.
	(match_variable): Remove PROTECTED check and assignment check
	for PARAMETERs (this is now done later).
	* match.c (gfc_match_iterator): Remove INTENT(IN) check.
	(gfc_match_associate): Defer initialization of newAssoc->variable.
	(gfc_match_nullify): Remove PURE definability check.
	(select_type_set_tmp): Set new `select_type_temporary' flag.
	* expr.c (gfc_check_assign): Remove INTENT(IN) check here.
	(gfc_check_pointer_assign): Ditto (and other checks removed).
	(gfc_check_vardef_context): New method.
	* interface.c (compare_parameter_protected): Removed.
	(compare_actual_formal): Use `gfc_check_vardef_context' for checks
	related to INTENT([IN]OUT) arguments.
	* intrinsic.c (check_arglist): Check INTENT for intrinsics.
	* resolve.c (gfc_resolve_iterator): Use `gfc_check_vardef_context'.
	(remove_last_array_ref): New method.
	(resolve_deallocate_expr), (resolve_allocate_expr): Ditto.
	(resolve_allocate_deallocate): Ditto (for STAT and ERRMSG).
	(resolve_assoc_var): Remove checks for definability here.
	(resolve_select_type): Handle resolving of code->block here.
	(resolve_ordinary_assign): Remove PURE check.
	(resolve_code): Do not resolve code->blocks for SELECT TYPE here.
	Use `gfc_check_vardef_context' for assignments and pointer-assignments.

2010-09-23  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	PR fortran/44044
	PR fortran/45474
	* gfortran.dg/intrinsic_intent_1.f03: New test.
	* gfortran.dg/select_type_17.f03: New test.
	* gfortran.dg/associate_5.f03: More definability tests.
	* gfortran.dg/enum_2.f90: Check definability.
	* gfortran.dg/allocatable_dummy_2.f90: Change expected error message.
	* gfortran.dg/allocate_alloc_opt_2.f90: Ditto.
	* gfortran.dg/char_expr_2.f90: Ditto.
	* gfortran.dg/deallocate_alloc_opt_2.f90: Ditto.
	* gfortran.dg/enum_5.f90: Ditto.
	* gfortran.dg/equiv_constraint_8.f90: Ditto.
	* gfortran.dg/impure_assignment_2.f90: Ditto.
	* gfortran.dg/impure_assignment_3.f90: Ditto.
	* gfortran.dg/intent_out_1.f90: Ditto.
	* gfortran.dg/intent_out_3.f90: Ditto.
	* gfortran.dg/pointer_assign_7.f90: Ditto.
	* gfortran.dg/pointer_intent_3.f90: Ditto.
	* gfortran.dg/pr19936_1.f90: Ditto.
	* gfortran.dg/proc_ptr_comp_3.f90: Ditto.
	* gfortran.dg/simpleif_2.f90: Ditto.
	* gfortran.dg/protected_5.f90: Ditto.
	* gfortran.dg/protected_4.f90: Ditto and remove invalid error check.
	* gfortran.dg/protected_6.f90: Ditto.
	* gfortran.dg/protected_7.f90: Ditto.

From-SVN: r164550

1 files changed, 12 insertions, 49 deletions

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 044ccd6..5024fe8 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1655,36 +1655,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 }
 
 
-/* Given a symbol of a formal argument list and an expression, see if
-   the two are compatible as arguments.  Returns nonzero if
-   compatible, zero if not compatible.  */
-
-static int
-compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
-{
-  if (actual->expr_type != EXPR_VARIABLE)
-    return 1;
-
-  if (!actual->symtree->n.sym->attr.is_protected)
-    return 1;
-
-  if (!actual->symtree->n.sym->attr.use_assoc)
-    return 1;
-
-  if (formal->attr.intent == INTENT_IN
-      || formal->attr.intent == INTENT_UNKNOWN)
-    return 1;
-
-  if (!actual->symtree->n.sym->attr.pointer)
-    return 0;
-
-  if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
-    return 0;
-
-  return 1;
-}
-
-
 /* Returns the storage size of a symbol (formal argument) or
    zero if it cannot be determined.  */
 
@@ -2205,27 +2175,20 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	}
 
       /* Check intent = OUT/INOUT for definable actual argument.  */
-      if ((a->expr->expr_type != EXPR_VARIABLE
-	   || (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE
-	       && a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE))
-	  && (f->sym->attr.intent == INTENT_OUT
-	      || f->sym->attr.intent == INTENT_INOUT))
+      if ((f->sym->attr.intent == INTENT_OUT
+	  || f->sym->attr.intent == INTENT_INOUT))
 	{
-	  if (where)
-	    gfc_error ("Actual argument at %L must be definable as "
-		       "the dummy argument '%s' is INTENT = OUT/INOUT",
-		       &a->expr->where, f->sym->name);
-	  return 0;
-	}
+	  const char* context = (where
+				 ? _("actual argument to INTENT = OUT/INOUT")
+				 : NULL);
 
-      if (!compare_parameter_protected(f->sym, a->expr))
-	{
-	  if (where)
-	    gfc_error ("Actual argument at %L is use-associated with "
-		       "PROTECTED attribute and dummy argument '%s' is "
-		       "INTENT = OUT/INOUT",
-		       &a->expr->where,f->sym->name);
-	  return 0;
+	  if (f->sym->attr.pointer
+	      && gfc_check_vardef_context (a->expr, true, context)
+		   == FAILURE)
+	    return 0;
+	  if (gfc_check_vardef_context (a->expr, false, context)
+		== FAILURE)
+	    return 0;
 	}
 
       if ((f->sym->attr.intent == INTENT_OUT