This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
RFC: Experimental BLOCK implementation
- From: Daniel Kraft <d at domob dot eu>
- To: Fortran List <fortran at gcc dot gnu dot org>
- Date: Fri, 25 Sep 2009 13:28:06 +0200
- Subject: RFC: Experimental BLOCK implementation
Hi all,
attached is an experimental draft patch to implement the F2008 BLOCK
construct. There seem to be some interesting corner cases and
interpretations about BLOCK (see
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=39626, especially Tobias'
pointer), but I'm just trying to get the 'basic' stuff right without
caring for now about some peculiarities.
The patch works so far for what I would expect from BLOCK (see the test
cases), but misses some checks that only stuff really allowed with a
BLOCK is included there, and some other item that I think is wrong at
the moment is that variables that get implicitly typed within the block
would have only the block as their scope -- this is not in line with the
draft standard, AFAIK.
Additionally, I'm not sure if my implementation uses the 'best' and
'cleanest' ways... Comments very welcome! My plan is to work on the
missing checks and then submit the revised patch for review.
Yours,
Daniel
--
Done: Arc-Bar-Cav-Ran-Rog-Sam-Tou-Val-Wiz
To go: Hea-Kni-Mon-Pri
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 151672)
+++ gcc/fortran/decl.c (working copy)
@@ -5344,8 +5344,8 @@ set_enum_kind(void)
/* Match any of the various end-block statements. Returns the type of
- END to the caller. The END INTERFACE, END IF, END DO and END
- SELECT statements cannot be replaced by a single END statement. */
+ END to the caller. The END INTERFACE, END IF, END DO, END SELECT
+ and END BLOCK statements cannot be replaced by a single END statement. */
match
gfc_match_end (gfc_statement *st)
@@ -5366,6 +5366,9 @@ gfc_match_end (gfc_statement *st)
block_name = gfc_current_block () == NULL
? NULL : gfc_current_block ()->name;
+ if (state == COMP_BLOCK && !strcmp (block_name, "block@"))
+ block_name = NULL;
+
if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
{
state = gfc_state_stack->previous->state;
@@ -5419,6 +5422,12 @@ gfc_match_end (gfc_statement *st)
eos_ok = 0;
break;
+ case COMP_BLOCK:
+ *st = ST_END_BLOCK;
+ target = " block";
+ eos_ok = 0;
+ break;
+
case COMP_IF:
*st = ST_ENDIF;
target = " if";
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 151672)
+++ gcc/fortran/gfortran.h (working copy)
@@ -206,15 +206,17 @@ arith;
/* Statements. */
typedef enum
{
- ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_BACKSPACE, ST_BLOCK_DATA,
+ ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_BACKSPACE,
+ ST_BLOCK, ST_BLOCK_DATA,
ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE,
ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF,
- ST_ELSEWHERE, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO,
+ ST_ELSEWHERE, ST_END_BLOCK, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO,
ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF,
ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT,
ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE,
ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, ST_GOTO,
- ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT, ST_INQUIRE, ST_INTERFACE,
+ ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT,
+ ST_INQUIRE, ST_INTERFACE,
ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN,
ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND,
ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT,
@@ -1964,7 +1966,7 @@ typedef enum
EXEC_POINTER_ASSIGN,
EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
- EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
+ EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_BLOCK,
EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC,
EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE,
EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
@@ -2015,6 +2017,7 @@ typedef struct gfc_code
const char *omp_name;
gfc_namelist *omp_namelist;
bool omp_bool;
+ gfc_namespace *ns;
}
ext; /* Points to additional structures required by statement */
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 151672)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -756,6 +756,36 @@ gfc_trans_arithmetic_if (gfc_code * code
}
+/* Translate a BLOCK construct. This is basically what we would do for a
+ procedure body. */
+
+tree
+gfc_trans_block_construct (gfc_code* code)
+{
+ gfc_namespace* ns;
+ gfc_symbol* sym;
+ stmtblock_t body;
+ tree tmp;
+
+ ns = code->ext.ns;
+ gcc_assert (ns);
+ sym = ns->proc_name;
+ gcc_assert (sym);
+
+ gcc_assert (!sym->tlink);
+ sym->tlink = sym;
+
+ gfc_start_block (&body);
+ gfc_process_block_locals (ns);
+
+ tmp = gfc_trans_code (ns->code);
+ tmp = gfc_trans_deferred_vars (sym, tmp);
+
+ gfc_add_expr_to_block (&body, tmp);
+ return gfc_finish_block (&body);
+}
+
+
/* Translate the simple DO construct. This is where the loop variable has
integer type and step +-1. We can't use this in the general case
because integer overflow and floating point errors could give incorrect
Index: gcc/fortran/trans-stmt.h
===================================================================
--- gcc/fortran/trans-stmt.h (revision 151672)
+++ gcc/fortran/trans-stmt.h (working copy)
@@ -43,6 +43,7 @@ tree gfc_trans_call (gfc_code *, bool, t
tree gfc_trans_return (gfc_code *);
tree gfc_trans_if (gfc_code *);
tree gfc_trans_arithmetic_if (gfc_code *);
+tree gfc_trans_block_construct (gfc_code *);
tree gfc_trans_do (gfc_code *);
tree gfc_trans_do_while (gfc_code *);
tree gfc_trans_select (gfc_code *);
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 151672)
+++ gcc/fortran/trans.c (working copy)
@@ -1164,6 +1164,10 @@ gfc_trans_code (gfc_code * code)
res = gfc_trans_arithmetic_if (code);
break;
+ case EXEC_BLOCK:
+ res = gfc_trans_block_construct (code);
+ break;
+
case EXEC_DO:
res = gfc_trans_do (code);
break;
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 151672)
+++ gcc/fortran/trans.h (working copy)
@@ -498,6 +498,12 @@ void gfc_build_io_library_fndecls (void)
/* Build a function decl for a library function. */
tree gfc_build_library_function_decl (tree, tree, int, ...);
+/* Process the local variable decls of a block construct. */
+void gfc_process_block_locals (gfc_namespace*);
+
+/* XXX: comment and position this. */
+tree gfc_trans_deferred_vars (gfc_symbol*, tree);
+
/* somewhere! */
tree pushdecl (tree);
tree pushdecl_top_level (tree);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 151672)
+++ gcc/fortran/resolve.c (working copy)
@@ -1101,6 +1101,7 @@ is_illegal_recursion (gfc_symbol* sym, g
{
gfc_symbol* proc_sym;
gfc_symbol* context_proc;
+ gfc_namespace* real_context;
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
@@ -1114,11 +1115,20 @@ is_illegal_recursion (gfc_symbol* sym, g
if (proc_sym->attr.recursive || gfc_option.flag_recursive)
return false;
- /* Find the context procdure's "real" symbol if it has entries. */
- context_proc = (context->entries ? context->entries->sym
- : context->proc_name);
- if (!context_proc)
- return true;
+ /* Find the context procedure's "real" symbol if it has entries.
+ If we don't find any procedure, this may be a BLOCK construct; recurse
+ on the parent in this case. */
+ for (real_context = context; real_context;
+ real_context = real_context->parent)
+ {
+ context_proc = (context->entries ? context->entries->sym
+ : context->proc_name);
+ if (context_proc)
+ break;
+ }
+ /* XXX: Return true was here before? */
+ if (!real_context)
+ return false;
/* A call from sym's body to itself is recursion, of course. */
if (context_proc == proc_sym)
@@ -6838,6 +6848,17 @@ gfc_resolve_forall (gfc_code *code, gfc_
}
+/* Resolve a BLOCK construct statement. */
+
+static void
+resolve_block_construct (gfc_code* code)
+{
+ /* XXX: Do some checks, like the restrictions on the specifications-part
+ for a BLOCK construct. */
+ code = code;
+}
+
+
/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
DO code nodes. */
@@ -6875,6 +6896,10 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
resolve_branch (b->label1, b);
break;
+ case EXEC_BLOCK:
+ resolve_block_construct (b);
+ break;
+
case EXEC_SELECT:
case EXEC_FORALL:
case EXEC_DO:
@@ -6902,7 +6927,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
break;
default:
- gfc_internal_error ("resolve_block(): Bad block type");
+ gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
}
resolve_code (b->next, ns);
@@ -7066,6 +7091,7 @@ resolve_ordinary_assign (gfc_code *code,
return false;
}
+
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
@@ -7250,7 +7276,7 @@ resolve_code (gfc_code *code, gfc_namesp
break;
case EXEC_CALL_PPC:
- resolve_ppc_call (code);
+ resolve_ppc_call (code);
break;
case EXEC_SELECT:
@@ -7259,6 +7285,10 @@ resolve_code (gfc_code *code, gfc_namesp
resolve_select (code);
break;
+ case EXEC_BLOCK:
+ gfc_resolve (code->ext.ns);
+ break;
+
case EXEC_DO:
if (code->ext.iterator != NULL)
{
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c (revision 151672)
+++ gcc/fortran/st.c (working copy)
@@ -110,6 +110,10 @@ gfc_free_statement (gfc_code *p)
case EXEC_ARITHMETIC_IF:
break;
+ case EXEC_BLOCK:
+ gfc_free_namespace (p->ext.ns);
+ break;
+
case EXEC_COMPCALL:
case EXEC_CALL_PPC:
case EXEC_CALL:
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 151672)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -64,6 +64,10 @@ static GTY(()) tree saved_parent_functio
static struct pointer_set_t *nonlocal_dummy_decl_pset;
static GTY(()) tree nonlocal_dummy_decls;
+/* Holds the variable DECLs that are locals. */
+
+static GTY(()) tree saved_local_decls;
+
/* The namespace of the module we're currently generating. Only used while
outputting decls for module variables. Do not rely on this being set. */
@@ -180,6 +184,16 @@ gfc_add_decl_to_function (tree decl)
saved_function_decls = decl;
}
+static void
+add_decl_as_local (tree decl)
+{
+ gcc_assert (decl);
+ TREE_USED (decl) = 1;
+ DECL_CONTEXT (decl) = current_function_decl;
+ TREE_CHAIN (decl) = saved_local_decls;
+ saved_local_decls = decl;
+}
+
/* Build a backend label declaration. Set TREE_USED for named labels.
The context of the label is always the current_function_decl. All
@@ -504,8 +518,11 @@ gfc_finish_var_decl (tree decl, gfc_symb
if (current_function_decl != NULL_TREE)
{
if (sym->ns->proc_name->backend_decl == current_function_decl
- || sym->result == sym)
+ || sym->result == sym)
gfc_add_decl_to_function (decl);
+ else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
+ /* This is a BLOCK construct. */
+ add_decl_as_local (decl);
else
gfc_add_decl_to_parent_function (decl);
}
@@ -3054,7 +3071,7 @@ init_intent_out_dt (gfc_symbol * proc_sy
Initialization and possibly repacking of dummy arrays.
Initialization of ASSIGN statement auxiliary variable. */
-static tree
+tree
gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{
locus loc;
@@ -4570,4 +4587,28 @@ gfc_generate_block_data (gfc_namespace *
}
+/* Process the local variables of a BLOCK construct. */
+
+void
+gfc_process_block_locals (gfc_namespace* ns)
+{
+ tree decl;
+
+ gcc_assert (saved_local_decls == NULL_TREE);
+ generate_local_vars (ns);
+
+ decl = saved_local_decls;
+ while (decl)
+ {
+ tree next;
+
+ next = TREE_CHAIN (decl);
+ TREE_CHAIN (decl) = NULL_TREE;
+ pushdecl (decl);
+ decl = next;
+ }
+ saved_local_decls = NULL_TREE;
+}
+
+
#include "gt-fortran-trans-decl.h"
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 151672)
+++ gcc/fortran/match.c (working copy)
@@ -1705,6 +1705,30 @@ gfc_free_iterator (gfc_iterator *iter, i
}
+/* Match a BLOCK statement. */
+
+match
+gfc_match_block (void)
+{
+ match m;
+
+ if (gfc_match_label () == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (gfc_match (" block") != MATCH_YES)
+ return MATCH_NO;
+
+ /* For this to be a correct BLOCK statement, the line must end now. */
+ m = gfc_match_eos ();
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_NO)
+ return MATCH_NO;
+
+ return MATCH_YES;
+}
+
+
/* Match a DO statement. */
match
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h (revision 151672)
+++ gcc/fortran/match.h (working copy)
@@ -69,6 +69,7 @@ match gfc_match_assignment (void);
match gfc_match_if (gfc_statement *);
match gfc_match_else (void);
match gfc_match_elseif (void);
+match gfc_match_block (void);
match gfc_match_do (void);
match gfc_match_cycle (void);
match gfc_match_exit (void);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 151672)
+++ gcc/fortran/parse.c (working copy)
@@ -289,7 +289,7 @@ decode_statement (void)
gfc_undo_symbols ();
gfc_current_locus = old_locus;
- /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
+ /* Check for the IF, DO, SELECT, WHERE, FORALL and BLOCK statements, which
might begin with a block label. The match functions for these
statements are unusual in that their keyword is not seen before
the matcher is called. */
@@ -309,6 +309,10 @@ decode_statement (void)
gfc_undo_symbols ();
gfc_current_locus = old_locus;
+ /* XXX: Is this really correct, what's the difference between IF/WHERE/FORALL
+ above and DO/SELECT below? */
+ match (NULL, gfc_match_block, ST_BLOCK);
+
match (NULL, gfc_match_do, ST_DO);
match (NULL, gfc_match_select, ST_SELECT_CASE);
@@ -932,7 +936,8 @@ next_statement (void)
/* Statements that mark other executable statements. */
-#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
+#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_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
@@ -951,7 +956,8 @@ next_statement (void)
are detected in gfc_match_end(). */
#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
- case ST_END_PROGRAM: case ST_END_SUBROUTINE
+ case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
+ case ST_END_BLOCK
/* Push a new state onto the stack. */
@@ -1141,6 +1147,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_BACKSPACE:
p = "BACKSPACE";
break;
+ case ST_BLOCK:
+ p = "BLOCK";
+ break;
case ST_BLOCK_DATA:
p = "BLOCK DATA";
break;
@@ -1189,6 +1198,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_ELSEWHERE:
p = "ELSEWHERE";
break;
+ case ST_END_BLOCK:
+ p = "END BLOCK";
+ break;
case ST_END_BLOCK_DATA:
p = "END BLOCK DATA";
break;
@@ -2907,6 +2919,51 @@ check_do_closure (void)
}
+/* Parse a series of contained program units. */
+
+static void parse_progunit (gfc_statement);
+
+
+/* Parse a BLOCK construct. */
+
+static void
+parse_block_construct (void)
+{
+ 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);
+ if (gfc_new_block)
+ my_ns->proc_name = gfc_new_block;
+ else
+ {
+ gfc_try t;
+
+ gfc_get_symbol ("block@", my_ns, &my_ns->proc_name);
+ t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
+ my_ns->proc_name->name, NULL);
+ gcc_assert (t == SUCCESS);
+ }
+ my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
+
+ new_st.op = EXEC_BLOCK;
+ new_st.ext.ns = my_ns;
+ accept_statement (ST_BLOCK);
+
+ push_state (&s, COMP_BLOCK, my_ns->proc_name);
+ gfc_current_ns = my_ns;
+
+ parse_progunit (ST_NONE);
+
+ gfc_current_ns = parent_ns;
+ pop_state ();
+}
+
+
/* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
handled inside of parse_executable(), because they aren't really
loop statements. */
@@ -3300,6 +3357,10 @@ parse_executable (gfc_statement st)
return ST_IMPLIED_ENDDO;
break;
+ case ST_BLOCK:
+ parse_block_construct ();
+ break;
+
case ST_IF_BLOCK:
parse_if_block ();
break;
@@ -3358,11 +3419,6 @@ parse_executable (gfc_statement st)
}
-/* Parse a series of contained program units. */
-
-static void parse_progunit (gfc_statement);
-
-
/* Fix the symbols for sibling functions. These are incorrectly added to
the child namespace as the parser didn't know about this procedure. */
Index: gcc/fortran/parse.h
===================================================================
--- gcc/fortran/parse.h (revision 151672)
+++ gcc/fortran/parse.h (working copy)
@@ -29,7 +29,8 @@ along with GCC; see the file COPYING3.
typedef enum
{
COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION,
- COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_IF,
+ COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS,
+ COMP_BLOCK, COMP_IF,
COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
COMP_OMP_STRUCTURED_BLOCK
}
Index: gcc/testsuite/gfortran.dg/block_2.f08
===================================================================
--- gcc/testsuite/gfortran.dg/block_2.f08 (revision 0)
+++ gcc/testsuite/gfortran.dg/block_2.f08 (revision 0)
@@ -0,0 +1,36 @@
+! { dg-do run }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+
+! More sophisticated BLOCK runtime checks for correct initialization/clean-up.
+
+PROGRAM main
+ IMPLICIT NONE
+ INTEGER :: n
+
+ n = 5
+
+ myblock: BLOCK
+ INTEGER :: arr(n)
+ IF (SIZE (arr) /= 5) CALL abort ()
+ BLOCK
+ INTEGER :: arr(2*n)
+ IF (SIZE (arr) /= 10) CALL abort ()
+ END BLOCK
+ IF (SIZE (arr) /= 5) CALL abort ()
+ END BLOCK
+
+ BLOCK
+ INTEGER, ALLOCATABLE :: arr(:)
+ IF (ALLOCATED (arr)) CALL abort ()
+ ALLOCATE (arr(n))
+ IF (SIZE (arr) /= 5) CALL abort ()
+ ! XXX: Can we check it gets free'ed here?
+ END BLOCK
+
+ BLOCK
+ CHARACTER(LEN=n) :: str
+ IF (LEN (str) /= 5) CALL abort ()
+ str = "123456789"
+ IF (str /= "12345") CALL abort ()
+ END BLOCK
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/block_4.f08
===================================================================
--- gcc/testsuite/gfortran.dg/block_4.f08 (revision 0)
+++ gcc/testsuite/gfortran.dg/block_4.f08 (revision 0)
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+
+! Check for label mismatch errors with BLOCK statements.
+
+PROGRAM main
+ IMPLICIT NONE
+
+ BLOCK
+ END BLOCK wrongname ! { dg-error "Syntax error" }
+
+ myname: BLOCK
+ END BLOCK wrongname ! { dg-error "Expected label 'myname'" }
+END PROGRAM main ! { dg-error "Expecting END BLOCK" }
+! { dg-excess-errors "Unexpected end of file" }
Index: gcc/testsuite/gfortran.dg/block_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/block_1.f08 (revision 0)
+++ gcc/testsuite/gfortran.dg/block_1.f08 (revision 0)
@@ -0,0 +1,34 @@
+! { dg-do run }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+
+! Basic Fortran 2008 BLOCK construct test.
+
+PROGRAM main
+ IMPLICIT NONE
+ INTEGER :: i
+
+ i = 42
+
+ ! Empty block.
+ BLOCK
+ END BLOCK
+
+ ! Block without local variables but name.
+ emptyblock: BLOCK
+ IF (i /= 42) CALL abort ()
+ i = 5
+ END BLOCK ! No label here, should be ok.
+ IF (i /= 5) CALL abort ()
+
+ ! Named block with local variable and nested block.
+ myblock: BLOCK
+ INTEGER :: i
+ i = -1
+ BLOCK
+ IF (i /= -1) CALL abort ()
+ i = -2
+ END BLOCK
+ IF (i /= -2) CALL abort ()
+ END BLOCK myblock ! Matching end-label.
+ IF (i /= 5) CALL abort ()
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/block_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/block_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/block_3.f90 (revision 0)
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! BLOCK should be rejected without F2008.
+
+PROGRAM main
+ IMPLICIT NONE
+
+ BLOCK ! { dg-error "Fortran 2008" }
+ INTEGER :: i
+ END BLOCK
+END PROGRAM main