OSDN Git Service

2009-10-07 Janus Weil <janus@gcc.gnu.org>
authorjanus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 7 Oct 2009 10:54:35 +0000 (10:54 +0000)
committerjanus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 7 Oct 2009 10:54:35 +0000 (10:54 +0000)
* 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.

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

gcc/fortran/ChangeLog
gcc/fortran/expr.c
gcc/fortran/match.c
gcc/fortran/parse.c
gcc/fortran/parse.h
gcc/fortran/resolve.c
gcc/fortran/symbol.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/same_type_as_2.f03
gcc/testsuite/gfortran.dg/select_type_1.f03
gcc/testsuite/gfortran.dg/select_type_5.f03 [new file with mode: 0644]

index f833c20..7b4ecc6 100644 (file)
@@ -1,3 +1,23 @@
+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
index 32aa682..cbd3172 100644 (file)
@@ -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, 
index 3e969e7..d2c3ef0 100644 (file)
@@ -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;
 }
index 13199c9..770c7ef 100644 (file)
@@ -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 ();
 }
 
index 2b92661..e0a2969 100644 (file)
@@ -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  */
index 8acd580..4092891 100644 (file)
@@ -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:
index 8cd18db..befa90b 100644 (file)
@@ -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);
index aa3886c..f67f671 100644 (file)
@@ -1,3 +1,9 @@
+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
index 9a2110d..6fd0311 100644 (file)
@@ -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
 
index e764ec9..6a7db2e 100644 (file)
@@ -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)
diff --git a/gcc/testsuite/gfortran.dg/select_type_5.f03 b/gcc/testsuite/gfortran.dg/select_type_5.f03
new file mode 100644 (file)
index 0000000..ec9d3cd
--- /dev/null
@@ -0,0 +1,47 @@
+! { 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