expr.c (gfc_check_pointer_assign): Do the correct type checking when CLASS variables are involved.

2009-10-07  Janus Weil  <janus@gcc.gnu.org>

	* expr.c (gfc_check_pointer_assign): Do the correct type checking when
	CLASS variables are involved.
	* match.c (gfc_match_select_type): Parse associate-name in SELECT TYPE
	statements, and set up a local namespace for the SELECT TYPE block.
	* parse.h (gfc_build_block_ns): New prototype.
	* parse.c (parse_select_type_block): Return from local namespace to its
	parent after SELECT TYPE block.
	(gfc_build_block_ns): New function for setting up the local namespace
	for a BLOCK construct.
	(parse_block_construct): Use gfc_build_block_ns.
	* resolve.c (resolve_select_type): Insert assignment for the selector
	variable, in case an associate-name is given, and put the SELECT TYPE
	statement inside a BLOCK.
	(resolve_code): Call resolve_class_assign after checking the assignment.
	* symbol.c (gfc_find_sym_tree): Moved some code here from
	gfc_get_ha_sym_tree.
	(gfc_get_ha_sym_tree): Moved some code to gfc_find_sym_tree.


2009-10-07  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/same_type_as_2.f03: Modified (was illegal).
	* gfortran.dg/select_type_1.f03: Modified error message.
	* gfortran.dg/select_type_5.f03: New test.

From-SVN: r152526

gcc/fortran/ChangeLog

+2009-10-07  Janus Weil  <janus@gcc.gnu.org>
+
+	* expr.c (gfc_check_pointer_assign): Do the correct type checking when
+	CLASS variables are involved.
+	* match.c (gfc_match_select_type): Parse associate-name in SELECT TYPE
+	statements, and set up a local namespace for the SELECT TYPE block.
+	* parse.h (gfc_build_block_ns): New prototype.
+	* parse.c (parse_select_type_block): Return from local namespace to its
+	parent after SELECT TYPE block.
+	(gfc_build_block_ns): New function for setting up the local namespace
+	for a BLOCK construct.
+	(parse_block_construct): Use gfc_build_block_ns.
+	* resolve.c (resolve_select_type): Insert assignment for the selector
+	variable, in case an associate-name is given, and put the SELECT TYPE
+	statement inside a BLOCK.
+	(resolve_code): Call resolve_class_assign after checking the assignment.
+	* symbol.c (gfc_find_sym_tree): Moved some code here from
+	gfc_get_ha_sym_tree.
+	(gfc_get_ha_sym_tree): Moved some code to gfc_find_sym_tree.
+
 2009-10-07  Paul Thomas <pault@gcc.gnu.org>
 
         PR fortran/41613

gcc/fortran/expr.c

@@ -3277,8 +3277,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       return SUCCESS;
     }
 
-  if (lvalue->ts.type != BT_CLASS && lvalue->symtree->n.sym->ts.type != BT_CLASS
-	&& !gfc_compare_types (&lvalue->ts, &rvalue->ts))
+  if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
     {
       gfc_error ("Different types in pointer assignment at %L; attempted "
 		 "assignment of %s to %s", &lvalue->where, 

gcc/fortran/match.c

@@ -4026,41 +4026,51 @@ gfc_match_select (void)
 match
 gfc_match_select_type (void)
 {
-  gfc_expr *expr;
+  gfc_expr *expr1, *expr2 = NULL;
   match m;
+  char name[GFC_MAX_SYMBOL_LEN];
 
   m = gfc_match_label ();
   if (m == MATCH_ERROR)
     return m;
 
-  m = gfc_match (" select type ( %e ", &expr);
+  m = gfc_match (" select type ( ");
   if (m != MATCH_YES)
     return m;
 
-  /* TODO: Implement ASSOCIATE.  */
-  m = gfc_match (" => ");
+  gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
+
+  m = gfc_match (" %n => %e", name, &expr2);
   if (m == MATCH_YES)
     {
-      gfc_error ("Associate-name in SELECT TYPE statement at %C "
-		 "is not yet supported");
-      return MATCH_ERROR;
+      expr1 = gfc_get_expr();
+      expr1->expr_type = EXPR_VARIABLE;
+      if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
+	return MATCH_ERROR;
+      expr1->symtree->n.sym->ts = expr2->ts;
+      expr1->symtree->n.sym->attr.referenced = 1;
+    }
+  else
+    {
+      m = gfc_match (" %e ", &expr1);
+      if (m != MATCH_YES)
+	return m;
     }
 
   m = gfc_match (" )%t");
   if (m != MATCH_YES)
     return m;
 
-  /* Check for F03:C811.
-     TODO: Change error message once ASSOCIATE is implemented.  */
-  if (expr->expr_type != EXPR_VARIABLE || expr->ref != NULL)
+  /* Check for F03:C811.  */
+  if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
     {
-      gfc_error ("Selector must be a named variable in SELECT TYPE statement "
-		 "at %C");
+      gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
+		 "use associate-name=>");
       return MATCH_ERROR;
     }
 
   /* Check for F03:C813.  */
-  if (expr->ts.type != BT_CLASS)
+  if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS))
     {
       gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
 		 "at %C");
@@ -4068,9 +4078,11 @@ gfc_match_select_type (void)
     }
 
   new_st.op = EXEC_SELECT_TYPE;
-  new_st.expr1 = expr;
+  new_st.expr1 = expr1;
+  new_st.expr2 = expr2;
+  new_st.ext.ns = gfc_current_ns;
 
-  type_selector = expr->symtree->n.sym;
+  type_selector = expr1->symtree->n.sym;
 
   return MATCH_YES;
 }

gcc/fortran/parse.c

@@ -2909,12 +2909,8 @@ parse_select_type_block (void)
       if (st == ST_NONE)
 	unexpected_eof ();
       if (st == ST_END_SELECT)
-	{
-	  /* Empty SELECT CASE is OK.  */
-	  accept_statement (st);
-	  pop_state ();
-	  return;
-	}
+	/* Empty SELECT CASE is OK.  */
+	goto done;
       if (st == ST_TYPE_IS || st == ST_CLASS_IS)
 	break;
 
@@ -2959,8 +2955,10 @@ parse_select_type_block (void)
     }
   while (st != ST_END_SELECT);
 
+done:
   pop_state ();
   accept_statement (st);
+  gfc_current_ns = gfc_current_ns->parent;
 }
 
 
@@ -3033,18 +3031,13 @@ check_do_closure (void)
 static void parse_progunit (gfc_statement);
 
 
-/* Parse a BLOCK construct.  */
+/* Set up the local namespace for a BLOCK construct.  */
 
-static void
-parse_block_construct (void)
+gfc_namespace*
+gfc_build_block_ns (gfc_namespace *parent_ns)
 {
-  gfc_namespace* parent_ns;
   gfc_namespace* my_ns;
-  gfc_state_data s;
 
-  gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
-
-  parent_ns = gfc_current_ns;
   my_ns = gfc_get_namespace (parent_ns, 1);
   my_ns->construct_entities = 1;
 
@@ -3066,6 +3059,22 @@ parse_block_construct (void)
     }
   my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
 
+  return my_ns;
+}
+
+
+/* Parse a BLOCK construct.  */
+
+static void
+parse_block_construct (void)
+{
+  gfc_namespace* my_ns;
+  gfc_state_data s;
+
+  gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
+
+  my_ns = gfc_build_block_ns (gfc_current_ns);
+
   new_st.op = EXEC_BLOCK;
   new_st.ext.ns = my_ns;
   accept_statement (ST_BLOCK);
@@ -3075,7 +3084,7 @@ parse_block_construct (void)
 
   parse_progunit (ST_NONE);
 
-  gfc_current_ns = parent_ns;
+  gfc_current_ns = gfc_current_ns->parent;
   pop_state ();
 }
 

gcc/fortran/parse.h

@@ -70,4 +70,5 @@ match gfc_match_enumerator_def (void);
 void gfc_free_enum_history (void);
 extern bool gfc_matching_function;
 match gfc_match_prefix (gfc_typespec *);
+gfc_namespace* gfc_build_block_ns (gfc_namespace *);
 #endif  /* GFC_PARSE_H  */

gcc/fortran/resolve.c

@@ -6661,8 +6661,15 @@ resolve_select_type (gfc_code *code)
   gfc_case *c, *default_case;
   gfc_symtree *st;
   char name[GFC_MAX_SYMBOL_LEN];
+  gfc_namespace *ns;
+
+  ns = code->ext.ns;
+  gfc_resolve (ns);
 
-  selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
+  if (code->expr2)
+    selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
+  else
+    selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
 
   /* Assume there is no DEFAULT case.  */
   default_case = NULL;
@@ -6704,6 +6711,32 @@ resolve_select_type (gfc_code *code)
 	}
     }
 
+  if (code->expr2)
+    {
+      /* Insert assignment for selector variable.  */
+      new_st = gfc_get_code ();
+      new_st->op = EXEC_ASSIGN;
+      new_st->expr1 = gfc_copy_expr (code->expr1);
+      new_st->expr2 = gfc_copy_expr (code->expr2);
+      ns->code = new_st;
+    }
+
+  /* Put SELECT TYPE statement inside a BLOCK.  */
+  new_st = gfc_get_code ();
+  new_st->op = code->op;
+  new_st->expr1 = code->expr1;
+  new_st->expr2 = code->expr2;
+  new_st->block = code->block;
+  if (!ns->code)
+    ns->code = new_st;
+  else
+    ns->code->next = new_st;
+  code->op = EXEC_BLOCK;
+  code->expr1 = code->expr2 =  NULL;
+  code->block = NULL;
+
+  code = new_st;
+
   /* Transform to EXEC_SELECT.  */
   code->op = EXEC_SELECT;
   gfc_add_component_ref (code->expr1, "$vindex");
@@ -6723,7 +6756,7 @@ resolve_select_type (gfc_code *code)
 	continue;
       /* Assign temporary to selector.  */
       sprintf (name, "tmp$%s", c->ts.u.derived->name);
-      st = gfc_find_symtree (code->expr1->symtree->n.sym->ns->sym_root, name);
+      st = gfc_find_symtree (ns->sym_root, name);
       new_st = gfc_get_code ();
       new_st->op = EXEC_POINTER_ASSIGN;
       new_st->expr1 = gfc_get_variable_expr (st);
@@ -7669,9 +7702,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  if (t == FAILURE)
 	    break;
 
-	  if (code->expr1->ts.type == BT_CLASS)
-	    resolve_class_assign (code);
-
 	  if (resolve_ordinary_assign (code, ns))
 	    {
 	      if (code->op == EXEC_COMPCALL)
@@ -7680,6 +7710,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 		goto call;
 	    }
 
+	  if (code->expr1->ts.type == BT_CLASS)
+	    resolve_class_assign (code);
+
 	  break;
 
 	case EXEC_LABEL_ASSIGN:
@@ -7700,11 +7733,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  if (t == FAILURE)
 	    break;
 
+	  gfc_check_pointer_assign (code->expr1, code->expr2);
+
 	  if (code->expr1->ts.type == BT_CLASS)
 	    resolve_class_assign (code);
 
-	  gfc_check_pointer_assign (code->expr1, code->expr2);
-
 	  break;
 
 	case EXEC_ARITHMETIC_IF:

gcc/fortran/symbol.c

@@ -2479,6 +2479,12 @@ gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
       st = gfc_find_symtree (ns->sym_root, name);
       if (st != NULL)
 	{
+	  /* Special case: If we're in a SELECT TYPE block,
+	    replace the selector variable by a temporary.  */
+	  if (gfc_current_state () == COMP_SELECT_TYPE
+	      && st && st->n.sym == type_selector)
+	    st = select_type_tmp;
+
 	  *result = st;
 	  /* Ambiguous generic interfaces are permitted, as long
 	     as the specific interfaces are different.  */
@@ -2645,12 +2651,6 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
 
   i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
 
-  /* Special case: If we're in a SELECT TYPE block,
-     replace the selector variable by a temporary.  */
-  if (gfc_current_state () == COMP_SELECT_TYPE
-      && st && st->n.sym == type_selector)
-    st = select_type_tmp;
-
   if (st != NULL)
     {
       save_symbol_data (st->n.sym);

gcc/testsuite/ChangeLog

+2009-10-07  Janus Weil  <janus@gcc.gnu.org>
+
+	* gfortran.dg/same_type_as_2.f03: Modified (was illegal).
+	* gfortran.dg/select_type_1.f03: Modified error message.
+	* gfortran.dg/select_type_5.f03: New test.
+
 2009-10-06  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libgfortran/41612

gcc/testsuite/gfortran.dg/same_type_as_2.f03

@@ -8,12 +8,11 @@
   integer :: i
  end type 
 
- type :: t2
+ type, extends(t1) :: t2
   integer :: j
  end type
 
- CLASS(t1), pointer :: c1
- CLASS(t2), pointer :: c2
+ CLASS(t1), pointer :: c1,c2
  TYPE(t1), target :: x1
  TYPE(t2) ,target :: x2
 

gcc/testsuite/gfortran.dg/select_type_1.f03

@@ -30,8 +30,8 @@
 
   type is (t1)  ! { dg-error "Unexpected TYPE IS statement" }
 
-  select type (3.5)  ! { dg-error "Selector must be a named variable" }
-  select type (a%cp) ! { dg-error "Selector must be a named variable" }
+  select type (3.5)  ! { dg-error "is not a named variable" }
+  select type (a%cp) ! { dg-error "is not a named variable" }
   select type (b)    ! { dg-error "Selector shall be polymorphic" }
 
   select type (a)

gcc/testsuite/gfortran.dg/select_type_5.f03

+! { dg-do run }
+!
+! SELECT TYPE with associate-name
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+  type :: t1
+    integer :: i = -1
+    class(t1), pointer :: c
+  end type t1
+
+  type, extends(t1) :: t2
+    integer :: j = -1
+  end type t2
+
+  type(t2), target :: b
+  integer :: aa
+
+  b%c => b
+  aa = 5
+
+  select type (aa => b%c)
+  type is (t1)
+    aa%i = 1
+  type is (t2)
+    aa%j = 2
+  end select
+
+  print *,b%i,b%j
+  if (b%i /= -1) call abort()
+  if (b%j /= 2) call abort()
+
+  select type (aa => b%c)
+  type is (t1)
+    aa%i = 4
+  type is (t2)
+    aa%i = 3*aa%j
+  end select
+
+  print *,b%i,b%j
+  if (b%i /= 6) call abort()
+  if (b%j /= 2) call abort()
+
+  print *,aa
+  if (aa/=5) call abort()
+
+end