re PR fortran/56816 (ICE in delete_root)

fortran/
	PR fortran/56816
	* match.c (gfc_match_select_type): Add syntax error. Move namespace
	allocation and cleanup...
	* parse.c (decode_statement): ... here.

testsuite/
	PR fortran/56816
	* gfortran.dg/select_type_33.f03: New test.

From-SVN: r197950

5 files changed, 65 insertions, 7 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8f88b0b..2b1f82a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2013-04-14  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/56816
+	* match.c (gfc_match_select_type): Add syntax error. Move namespace
+	allocation and cleanup...
+	* parse.c (decode_statement): ... here.
+
 2013-04-13  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/55959
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index a1529da..b5e9609 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5337,7 +5337,6 @@ gfc_match_select_type (void)
   char name[GFC_MAX_SYMBOL_LEN];
   bool class_array;
   gfc_symbol *sym;
-  gfc_namespace *parent_ns;
 
   m = gfc_match_label ();
   if (m == MATCH_ERROR)
@@ -5347,8 +5346,6 @@ gfc_match_select_type (void)
   if (m != MATCH_YES)
     return m;
 
-  gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
-
   m = gfc_match (" %n => %e", name, &expr2);
   if (m == MATCH_YES)
     {
@@ -5379,7 +5376,10 @@ gfc_match_select_type (void)
 
   m = gfc_match (" )%t");
   if (m != MATCH_YES)
-    goto cleanup;
+    {
+      gfc_error ("parse error in SELECT TYPE statement at %C");
+      goto cleanup;
+    }
 
   /* This ghastly expression seems to be needed to distinguish a CLASS
      array, which can have a reference, from other expressions that
@@ -5417,9 +5417,6 @@ gfc_match_select_type (void)
   return MATCH_YES;
 
 cleanup:
-  parent_ns = gfc_current_ns->parent;
-  gfc_free_namespace (gfc_current_ns);
-  gfc_current_ns = parent_ns;
   return m;
 }
 
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 6dde0c6..74a5b4b 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -262,6 +262,7 @@ end_of_block:
 static gfc_statement
 decode_statement (void)
 {
+  gfc_namespace *ns;
   gfc_statement st;
   locus old_locus;
   match m;
@@ -363,7 +364,12 @@ decode_statement (void)
   match (NULL, gfc_match_associate, ST_ASSOCIATE);
   match (NULL, gfc_match_critical, ST_CRITICAL);
   match (NULL, gfc_match_select, ST_SELECT_CASE);
+
+  gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
   match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
+  ns = gfc_current_ns;
+  gfc_current_ns = gfc_current_ns->parent;
+  gfc_free_namespace (ns);
 
   /* General statement matching: Instead of testing every possible
      statement, we eliminate most possibilities by peeking at the
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 28b9b62..cdff281 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2013-04-14  Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/56816
+	* gfortran.dg/select_type_33.f03: New test.
+
 2013-04-13  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/55959
diff --git a/gcc/testsuite/gfortran.dg/select_type_33.f03 b/gcc/testsuite/gfortran.dg/select_type_33.f03
new file mode 100644
index 0000000..3ba27e0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_33.f03
@@ -0,0 +1,43 @@
+! { dg-do compile }
+!
+! PR fortran/56816
+! The unfinished SELECT TYPE statement below was leading to an ICE because
+! at the time the statement was rejected, the compiler tried to free
+! some symbols that had already been freed with the SELECT TYPE
+! namespace.
+!
+! Original testcase from Dominique Pelletier <dominique.pelletier@polymtl.ca>
+!
+module any_list_module
+    implicit none
+
+    private
+    public :: anylist, anyitem
+
+    type anylist
+    end type
+
+    type anyitem
+        class(*), allocatable :: value
+    end type
+end module any_list_module
+
+
+module my_item_list_module
+
+    use any_list_module
+    implicit none
+
+    type, extends (anyitem) :: myitem
+    end type myitem
+
+contains
+
+    subroutine myprint (this)
+        class (myitem) ::   this
+
+        select type ( v => this % value ! { dg-error "parse error in SELECT TYPE" }
+        end select                      ! { dg-error "Expecting END SUBROUTINE" }
+    end subroutine myprint
+
+end module my_item_list_module