From 49a71dabbf3f3619262fa291ae03e7e398a01418 Mon Sep 17 00:00:00 2001
From: bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Fri, 2 Oct 2009 16:08:13 +0000
Subject: 2009-10-02 Basile Starynkevitch <basile@starynkevitch.net> MELT
branch merged with trunk rev 152404
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@152406 138bc75d-0d04-0410-961f-82ee72b054a4
---
gcc/fortran/parse.c | 96 ++++++++++++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 95 insertions(+), 1 deletion(-)
(limited to 'gcc/fortran/parse.c')
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index e6b5dbb1801..13199c91bb0 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -312,6 +312,7 @@ decode_statement (void)
match (NULL, gfc_match_block, ST_BLOCK);
match (NULL, gfc_match_do, ST_DO);
match (NULL, gfc_match_select, ST_SELECT_CASE);
+ match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
/* General statement matching: Instead of testing every possible
statement, we eliminate most possibilities by peeking at the
@@ -343,6 +344,7 @@ decode_statement (void)
match ("case", gfc_match_case, ST_CASE);
match ("common", gfc_match_common, ST_COMMON);
match ("contains", gfc_match_eos, ST_CONTAINS);
+ match ("class", gfc_match_class_is, ST_CLASS_IS);
break;
case 'd':
@@ -432,6 +434,7 @@ decode_statement (void)
case 't':
match ("target", gfc_match_target, ST_ATTR_DECL);
match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
+ match ("type is", gfc_match_type_is, ST_TYPE_IS);
break;
case 'u':
@@ -936,7 +939,8 @@ next_statement (void)
#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
case ST_IF_BLOCK: case ST_BLOCK: \
- case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
+ case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
+ case ST_OMP_PARALLEL: \
case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
@@ -1360,6 +1364,15 @@ gfc_ascii_statement (gfc_statement st)
case ST_SELECT_CASE:
p = "SELECT CASE";
break;
+ case ST_SELECT_TYPE:
+ p = "SELECT TYPE";
+ break;
+ case ST_TYPE_IS:
+ p = "TYPE IS";
+ break;
+ case ST_CLASS_IS:
+ p = "CLASS IS";
+ break;
case ST_SEQUENCE:
p = "SEQUENCE";
break;
@@ -2874,6 +2887,83 @@ parse_select_block (void)
}
+/* Parse a SELECT TYPE construct (F03:R821). */
+
+static void
+parse_select_type_block (void)
+{
+ gfc_statement st;
+ gfc_code *cp;
+ gfc_state_data s;
+
+ accept_statement (ST_SELECT_TYPE);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
+
+ /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
+ or END SELECT. */
+ for (;;)
+ {
+ st = next_statement ();
+ if (st == ST_NONE)
+ unexpected_eof ();
+ if (st == ST_END_SELECT)
+ {
+ /* Empty SELECT CASE is OK. */
+ accept_statement (st);
+ pop_state ();
+ return;
+ }
+ if (st == ST_TYPE_IS || st == ST_CLASS_IS)
+ break;
+
+ gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
+ "following SELECT TYPE at %C");
+
+ reject_statement ();
+ }
+
+ /* At this point, we're got a nonempty select block. */
+ cp = new_level (cp);
+ *cp = new_st;
+
+ accept_statement (st);
+
+ do
+ {
+ st = parse_executable (ST_NONE);
+ switch (st)
+ {
+ case ST_NONE:
+ unexpected_eof ();
+
+ case ST_TYPE_IS:
+ case ST_CLASS_IS:
+ cp = new_level (gfc_state_stack->head);
+ *cp = new_st;
+ gfc_clear_new_st ();
+
+ accept_statement (st);
+ /* Fall through */
+
+ case ST_END_SELECT:
+ break;
+
+ /* Can't have an executable statement because of
+ parse_executable(). */
+ default:
+ unexpected_statement (st);
+ break;
+ }
+ }
+ while (st != ST_END_SELECT);
+
+ pop_state ();
+ accept_statement (st);
+}
+
+
/* Given a symbol, make sure it is not an iteration variable for a DO
statement. This subroutine is called when the symbol is seen in a
context that causes it to become redefined. If the symbol is an
@@ -3395,6 +3485,10 @@ parse_executable (gfc_statement st)
parse_select_block ();
break;
+ case ST_SELECT_TYPE:
+ parse_select_type_block();
+ break;
+
case ST_DO:
parse_do_block ();
if (check_do_closure () == 1)
--
cgit v1.2.1