2011-01-13 Tobias Burnus <burnus@net-b.de>

            Mikael Morin  <mikael@gcc.gnu.org>

        PR fortran/45848
        PR fortran/47204
        * gfortran.h (gfc_code): Move union ext's case_list into
        the struct block.
        * dump-parse-tree.c (show_code_node): Adapt by prefixing
        * case_list
        by "block.".
        * frontend-passes.c (gfc_code_walker): Ditto.
        * match.c (gfc_match_goto, gfc_match_call, gfc_match_case,
        gfc_match_type_is, gfc_match_class_is): Ditto.
        * resolve.c (resolve_select, resolve_select_type): Ditto.
        * st.c (gfc_free_statement): Ditto.
        * trans-stmt.c (gfc_trans_integer_select,
        * gfc_trans_logical_select,
        gfc_trans_character_select): Ditto.
        * parse.c (resolve_all_program_units): For error recovery, avoid
        segfault is proc_name is NULL.

2011-01-13  Tobias Burnus  <burnus@net-b.de>
            Mikael Morin  <mikael@gcc.gnu.org>

        PR fortran/45848
        PR fortran/47204
        * gfortran.dg/select_type_20.f90: New.
        * gfortran.dg/select_type_21.f90: New.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c61ed92..fa84641 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,22 @@
+2011-01-13  Tobias Burnus  <burnus@net-b.de>
+           Mikael Morin  <mikael@gcc.gnu.org>
+
+       PR fortran/45848
+       PR fortran/47204
+       * gfortran.h (gfc_code): Move union ext's case_list into
+       the struct block.
+       * dump-parse-tree.c (show_code_node): Adapt by prefixing case_list
+       by "block.".
+       * frontend-passes.c (gfc_code_walker): Ditto.
+       * match.c (gfc_match_goto, gfc_match_call, gfc_match_case,
+       gfc_match_type_is, gfc_match_class_is): Ditto.
+       * resolve.c (resolve_select, resolve_select_type): Ditto.
+       * st.c (gfc_free_statement): Ditto.
+       * trans-stmt.c (gfc_trans_integer_select, gfc_trans_logical_select,
+       gfc_trans_character_select): Ditto.
+       * parse.c (resolve_all_program_units): For error recovery, avoid
+       segfault is proc_name is NULL.
+
 2011-01-11  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/47051

diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index d4b1cb5..24e9ea5 100644 (file)
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1467,7 +1467,7 @@ show_code_node (int level, gfc_code *c)
          code_indent (level, 0);
 
          fputs ("CASE ", dumpfile);
-         for (cp = d->ext.case_list; cp; cp = cp->next)
+         for (cp = d->ext.block.case_list; cp; cp = cp->next)
            {
              fputc ('(', dumpfile);
              show_expr (cp->low);

diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 0777dba..7c55767 100644 (file)
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -659,7 +659,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
              for (b = (*c)->block; b; b = b->block)
                {
                  gfc_case *cp;
-                 for (cp = b->ext.case_list; cp; cp = cp->next)
+                 for (cp = b->ext.block.case_list; cp; cp = cp->next)
                    {
                      WALK_SUBEXPR (cp->low);
                      WALK_SUBEXPR (cp->high);

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index d0377f9..2622f22 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2079,7 +2079,6 @@ typedef struct gfc_code
   union
   {
     gfc_actual_arglist *actual;
-    gfc_case *case_list;
     gfc_iterator *iterator;
 
     struct
@@ -2093,6 +2092,7 @@ typedef struct gfc_code
     {
       gfc_namespace *ns;
       gfc_association_list *assoc;
+      gfc_case *case_list;
     }
     block;
 

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 926fea7..70f5862 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2651,7 +2651,7 @@ gfc_match_goto (void)
                                             NULL, i++);
 
       tail->op = EXEC_SELECT;
-      tail->ext.case_list = cp;
+      tail->ext.block.case_list = cp;
 
       tail->next = gfc_get_code ();
       tail->next->op = EXEC_GOTO;
@@ -3607,7 +3607,7 @@ gfc_match_call (void)
          new_case = gfc_get_case ();
          new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
          new_case->low = new_case->high;
-         c->ext.case_list = new_case;
+         c->ext.block.case_list = new_case;
 
          c->next = gfc_get_code ();
          c->next->op = EXEC_GOTO;
@@ -4658,7 +4658,7 @@ gfc_match_case (void)
       new_st.op = EXEC_SELECT;
       c = gfc_get_case ();
       c->where = gfc_current_locus;
-      new_st.ext.case_list = c;
+      new_st.ext.block.case_list = c;
       return MATCH_YES;
     }
 
@@ -4690,7 +4690,7 @@ gfc_match_case (void)
     goto cleanup;
 
   new_st.op = EXEC_SELECT;
-  new_st.ext.case_list = head;
+  new_st.ext.block.case_list = head;
 
   return MATCH_YES;
 
@@ -4738,7 +4738,7 @@ gfc_match_type_is (void)
     goto cleanup;
 
   new_st.op = EXEC_SELECT_TYPE;
-  new_st.ext.case_list = c;
+  new_st.ext.block.case_list = c;
 
   /* Create temporary variable.  */
   select_type_set_tmp (&c->ts);
@@ -4778,7 +4778,7 @@ gfc_match_class_is (void)
       c = gfc_get_case ();
       c->where = gfc_current_locus;
       c->ts.type = BT_UNKNOWN;
-      new_st.ext.case_list = c;
+      new_st.ext.block.case_list = c;
       select_type_set_tmp (NULL);
       return MATCH_YES;
     }
@@ -4811,7 +4811,7 @@ gfc_match_class_is (void)
     goto cleanup;
 
   new_st.op = EXEC_SELECT_TYPE;
-  new_st.ext.case_list = c;
+  new_st.ext.block.case_list = c;
   
   /* Create temporary variable.  */
   select_type_set_tmp (&c->ts);

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index e7898cc..b51e12b 100644 (file)
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -4190,7 +4190,8 @@ resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
   gfc_current_ns = gfc_global_ns_list;
   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
     {
-      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+      if (gfc_current_ns->proc_name)
+       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
       gfc_resolve (gfc_current_ns);
       gfc_current_ns->derived_types = gfc_derived_types;
       gfc_derived_types = NULL;

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 88acb55..a1c9917 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7361,7 +7361,7 @@ resolve_select (gfc_code *code)
 
   if (type == BT_INTEGER)
     for (body = code->block; body; body = body->block)
-      for (cp = body->ext.case_list; cp; cp = cp->next)
+      for (cp = body->ext.block.case_list; cp; cp = cp->next)
        {
          if (cp->low
              && gfc_check_integer_range (cp->low->value.integer,
@@ -7389,7 +7389,7 @@ resolve_select (gfc_code *code)
       for (body = code->block; body; body = body->block)
        {
          /* Walk the case label list.  */
-         for (cp = body->ext.case_list; cp; cp = cp->next)
+         for (cp = body->ext.block.case_list; cp; cp = cp->next)
            {
              /* Intercept the DEFAULT case.  It does not have a kind.  */
              if (cp->low == NULL && cp->high == NULL)
@@ -7426,7 +7426,7 @@ resolve_select (gfc_code *code)
 
       /* Walk the case label list, making sure that all case labels
         are legal.  */
-      for (cp = body->ext.case_list; cp; cp = cp->next)
+      for (cp = body->ext.block.case_list; cp; cp = cp->next)
        {
          /* Count the number of cases in the whole construct.  */
          ncases++;
@@ -7527,19 +7527,19 @@ resolve_select (gfc_code *code)
       if (seen_unreachable)
       {
        /* Advance until the first case in the list is reachable.  */
-       while (body->ext.case_list != NULL
-              && body->ext.case_list->unreachable)
+       while (body->ext.block.case_list != NULL
+              && body->ext.block.case_list->unreachable)
          {
-           gfc_case *n = body->ext.case_list;
-           body->ext.case_list = body->ext.case_list->next;
+           gfc_case *n = body->ext.block.case_list;
+           body->ext.block.case_list = body->ext.block.case_list->next;
            n->next = NULL;
            gfc_free_case_list (n);
          }
 
        /* Strip all other unreachable cases.  */
-       if (body->ext.case_list)
+       if (body->ext.block.case_list)
          {
-           for (cp = body->ext.case_list; cp->next; cp = cp->next)
+           for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
              {
                if (cp->next->unreachable)
                  {
@@ -7575,7 +7575,7 @@ resolve_select (gfc_code *code)
      unreachable case labels for a block.  */
   for (body = code; body && body->block; body = body->block)
     {
-      if (body->block->ext.case_list == NULL)
+      if (body->block->ext.block.case_list == NULL)
        {
          /* Cut the unreachable block from the code chain.  */
          gfc_code *c = body->block;
@@ -7714,7 +7714,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
   /* Loop over TYPE IS / CLASS IS cases.  */
   for (body = code->block; body; body = body->block)
     {
-      c = body->ext.case_list;
+      c = body->ext.block.case_list;
 
       /* Check F03:C815.  */
       if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
@@ -7744,7 +7744,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
            {
              gfc_error ("The DEFAULT CASE at %L cannot be followed "
                         "by a second DEFAULT CASE at %L",
-                        &default_case->ext.case_list->where, &c->where);
+                        &default_case->ext.block.case_list->where, &c->where);
              error++;
              continue;
            }
@@ -7799,7 +7799,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
   /* Loop over TYPE IS / CLASS IS cases.  */
   for (body = code->block; body; body = body->block)
     {
-      c = body->ext.case_list;
+      c = body->ext.block.case_list;
 
       if (c->ts.type == BT_DERIVED)
        c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
@@ -7845,7 +7845,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
   body = code;
   while (body && body->block)
     {
-      if (body->block->ext.case_list->ts.type == BT_CLASS)
+      if (body->block->ext.block.case_list->ts.type == BT_CLASS)
        {
          /* Add to class_is list.  */
          if (class_is == NULL)
@@ -7878,8 +7878,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
          tail->block = gfc_get_code ();
          tail = tail->block;
          tail->op = EXEC_SELECT_TYPE;
-         tail->ext.case_list = gfc_get_case ();
-         tail->ext.case_list->ts.type = BT_UNKNOWN;
+         tail->ext.block.case_list = gfc_get_case ();
+         tail->ext.block.case_list->ts.type = BT_UNKNOWN;
          tail->next = NULL;
          default_case = tail;
        }
@@ -7897,15 +7897,16 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
                {
                  c2 = (*c1)->block;
                  /* F03:C817 (check for doubles).  */
-                 if ((*c1)->ext.case_list->ts.u.derived->hash_value
-                     == c2->ext.case_list->ts.u.derived->hash_value)
+                 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
+                     == c2->ext.block.case_list->ts.u.derived->hash_value)
                    {
                      gfc_error ("Double CLASS IS block in SELECT TYPE "
-                                "statement at %L", &c2->ext.case_list->where);
+                                "statement at %L",
+                                &c2->ext.block.case_list->where);
                      return;
                    }
-                 if ((*c1)->ext.case_list->ts.u.derived->attr.extension
-                     < c2->ext.case_list->ts.u.derived->attr.extension)
+                 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
+                     < c2->ext.block.case_list->ts.u.derived->attr.extension)
                    {
                      /* Swap.  */
                      (*c1)->block = c2->block;
@@ -7940,7 +7941,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
          new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
          new_st->expr1->value.function.actual->expr->where = code->loc;
          gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
-         vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
+         vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
          st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
          new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
          new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);

diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index f9ad5d8..28d69b9 100644 (file)
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -129,8 +129,8 @@ gfc_free_statement (gfc_code *p)
 
     case EXEC_SELECT:
     case EXEC_SELECT_TYPE:
-      if (p->ext.case_list)
-       gfc_free_case_list (p->ext.case_list);
+      if (p->ext.block.case_list)
+       gfc_free_case_list (p->ext.block.case_list);
       break;
 
     case EXEC_DO:

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 5f6b1d0..8781d0e 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1560,7 +1560,7 @@ gfc_trans_integer_select (gfc_code * code)
 
   for (c = code->block; c; c = c->block)
     {
-      for (cp = c->ext.case_list; cp; cp = cp->next)
+      for (cp = c->ext.block.case_list; cp; cp = cp->next)
        {
          tree low, high;
           tree label;
@@ -1672,7 +1672,7 @@ gfc_trans_logical_select (gfc_code * code)
      always executed, and we don't generate code a COND_EXPR.  */
   for (c = code->block; c; c = c->block)
     {
-      for (cp = c->ext.case_list; cp; cp = cp->next)
+      for (cp = c->ext.block.case_list; cp; cp = cp->next)
        {
          if (cp->low)
            {
@@ -1771,7 +1771,7 @@ gfc_trans_character_select (gfc_code *code)
   static tree ss_string2[2], ss_string2_len[2];
   static tree ss_target[2];
 
-  cp = code->block->ext.case_list;
+  cp = code->block->ext.block.case_list;
   while (cp->left != NULL)
     cp = cp->left;
 
@@ -1840,7 +1840,7 @@ gfc_trans_character_select (gfc_code *code)
 
          for (c = code->block; c; c = c->block)
            {
-             for (cp = c->ext.case_list; cp; cp = cp->next)
+             for (cp = c->ext.block.case_list; cp; cp = cp->next)
                {
                  tree low, high;
                  tree label;
@@ -1969,7 +1969,7 @@ gfc_trans_character_select (gfc_code *code)
 
   for (c = code->block; c; c = c->block)
     {
-      for (d = c->ext.case_list; d; d = d->next)
+      for (d = c->ext.block.case_list; d; d = d->next)
         {
          label = gfc_build_label_decl (NULL_TREE);
          tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR,

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c171c3d..5bbc5d8 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2011-01-13  Tobias Burnus  <burnus@net-b.de>
+           Mikael Morin  <mikael@gcc.gnu.org>
+
+       PR fortran/45848
+       PR fortran/47204
+       * gfortran.dg/select_type_20.f90: New.
+       * gfortran.dg/select_type_21.f90: New.
+
 2011-01-13  Michael Meissner  <meissner@linux.vnet.ibm.com>
 
        PR target/47251

diff --git a/gcc/testsuite/gfortran.dg/select_type_20.f90 b/gcc/testsuite/gfortran.dg/select_type_20.f90
new file mode 100644 (file)
index 0000000..a247f7b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_20.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! PR fortran/45848
+! PR fortran/47204
+!
+! Contributed by Harald Anlauf and Zdenek Sojka
+!
+module gfcbug111
+  implicit none
+
+  type, abstract :: inner_product_class
+  end type inner_product_class
+
+  type, extends(inner_product_class) :: trivial_inner_product_type
+  end type trivial_inner_product_type
+
+contains
+
+  function my_dot_v_v (this,a,b) ! { dg-error "has no IMPLICIT type" }
+    class(trivial_inner_product_type), intent(in) :: this
+    class(vector_class),               intent(in) :: a,b ! { dg-error "Derived type" }
+    real :: my_dot_v_v
+
+    select type (a)
+    class is (trivial_vector_type) ! { dg-error "Syntax error in CLASS IS" }
+       select type (b) ! { dg-error "Expected TYPE IS" }
+       class is (trivial_vector_type) ! { dg-error "Syntax error in CLASS IS" }
+       class default
+       end select
+    class default ! { dg-error "Unclassifiable statement" }
+    end select ! { dg-error "Expecting END FUNCTION" }
+  end function my_dot_v_v
+end module gfcbug111
+
+select type (a)
+! { dg-excess-errors "Unexpected end of file" }

diff --git a/gcc/testsuite/gfortran.dg/select_type_21.f90 b/gcc/testsuite/gfortran.dg/select_type_21.f90
new file mode 100644 (file)
index 0000000..48d6968
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_21.f90
@@ -0,0 +1,7 @@
+! { dg-do compile }
+! PR fortran/45848
+! PR fortran/47204
+!
+select type (a) ! { dg-error "Selector shall be polymorphic" }
+end select
+end