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, 15 insertions, 20 deletions

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index b07632d..f6ceae9 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2007,7 +2007,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
 
-  ref = expr->ref;
   sym = expr->symtree->n.sym;
   attr = sym->attr;
 
@@ -2031,7 +2030,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
     *ts = sym->ts;
 
-  for (; ref; ref = ref->next)
+  for (ref = expr->ref; ref; ref = ref->next)
     switch (ref->type)
       {
       case REF_ARRAY:
@@ -2986,13 +2985,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
   switch (sym->attr.flavor)
     {
     case FL_VARIABLE:
-      if (sym->attr.is_protected && sym->attr.use_assoc)
-	{
-	  gfc_error ("Assigning to PROTECTED variable at %C");
-	  return MATCH_ERROR;
-	}
-      if (sym->assoc)
-	sym->assoc->variable = 1;
+      /* Everything is alright.  */
       break;
 
     case FL_UNKNOWN:
@@ -3024,22 +3017,24 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
 
     case FL_PARAMETER:
       if (equiv_flag)
-	gfc_error ("Named constant at %C in an EQUIVALENCE");
-      else
-	gfc_error ("Cannot assign to a named constant at %C");
-      return MATCH_ERROR;
+	{
+	  gfc_error ("Named constant at %C in an EQUIVALENCE");
+	  return MATCH_ERROR;
+	}
+      /* Otherwise this is checked for and an error given in the
+	 variable definition context checks.  */
       break;
 
     case FL_PROCEDURE:
       /* Check for a nonrecursive function result variable.  */
       if (sym->attr.function
-          && !sym->attr.external
-          && sym->result == sym
-          && (gfc_is_function_return_value (sym, gfc_current_ns)
-              || (sym->attr.entry
-                  && sym->ns == gfc_current_ns)
-              || (sym->attr.entry
-                  && sym->ns == gfc_current_ns->parent)))
+	  && !sym->attr.external
+	  && sym->result == sym
+	  && (gfc_is_function_return_value (sym, gfc_current_ns)
+	      || (sym->attr.entry
+		  && sym->ns == gfc_current_ns)
+	      || (sym->attr.entry
+		  && sym->ns == gfc_current_ns->parent)))
 	{
 	  /* If a function result is a derived type, then the derived
 	     type may still have to be resolved.  */