This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, Fortran] PR fortran/39626: Implement Fortran 2008's BLOCK construct
- From: Daniel Kraft <d at domob dot eu>
- To: Fortran List <fortran at gcc dot gnu dot org>
- Cc: gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Mon, 28 Sep 2009 16:47:09 +0200
- Subject: [Patch, Fortran] PR fortran/39626: Implement Fortran 2008's BLOCK construct
Hi all,
here's my revised patch to implement the BLOCK construct that will
appear in the upcoming Fortran 2008 standard. I personally believe that
this is some really nice feature that missed for a long time, and also
heard others say they'd like to have something like this in Fortran.
Especially nice is that you can have automatic variables with dynamic
array size or string length, as per the block_2.f08 test case.
Something like:
INTEGER :: n
... get n somewhere ...
BLOCK
INTEGER :: arr(n)
CHARACTER(LEN=n) :: str
... work with arr and str here ...
END BLOCK
Additionally, I believe it is sometimes helpful to keep local variable
declarations near the place they belong (especially for long routines),
but that's of course some point of preferrence and style.
In any case, what this patch does is implement BLOCK somewhat
"basically" -- see the test cases for what exactly it is supposed to do
and which errors to catch. As Richard Maine pointed out in some c.l.f
thread, there are a lot of fine points and corner cases; I do not strive
to handle them here mostly. I did target to implement the "reasonable"
semantics I would expect as user not thinking about the standard and
ugly cases, just defining lexically scoped local variables including
automatic variable length arrays and strings as mentiond above.
Regarding the draft F2008 standard, I tried to implement the section
about "The BLOCK construct" as fully as possible. However, so far I do
not care about VOLATILE and ASYNCHONOUS declarations inside the BLOCK,
did not implement the clause that a SAVE list may not target common
names and also do nothing special about locals being "construct
entities". block_7.f08 is a test case designed for some special
handling required with implicit typing because of that (as per Richard
Maine's answer on c.l.f, linked from bugzilla), but it seemed harder to
me to implement than I first thought. Because this is something I do
not think really important for real-world users, I XFAILed the test and
would like to defer this along with other points mentioned to some later
patch/"bugfix". I will document this in the PR and keep it open.
Additionally, I may add some words about BLOCK to the gfc-internals
documentation in some later patch when I find time to do so.
The patch is against today's trunk and passed both a full bootstrap and
regression test on GNU/Linux-x86-32. Ok for trunk?
Yours,
Daniel
PS: Here are some words about how I actually implemented BLOCK.
I tried to re-use most of existing handling of namespaces/program-units,
as a BLOCK is somewhat similar to a contained procedure. Internally, a
BLOCK statement is a gfc_code of type EXEC_BLOCK. It "owns" a namespace
in ext.ns, which keeps the local variable symbols. This namespace has
the containing procedure (or block in case of nested blocks) as parent
and is the gfc_current_ns for the block's body; so quite everything is
automagically handled "right" by the existing code, just as it would in
case of a contained procedure.
The proc_name symbol of the BLOCK's namespace is set to a FL_LABEL
symbol with either the block's name if it is given one or "block@" if
there is none. We need this proc_name symbol later for code generation
(because the symbol's tlink field is used there -- this seems to be not
a particular beautiful design in handling intialization/clean-up for
variables).
Parsing of a block is also done mainly with the already existing code in
parse_progunit. A block gets resolved by resolving its namespace, and
in the future we may want to add some more checks or special handling to
the resolution routine resolve_block_construct, though at the moment it
is quite small.
Finally, the code generation also "just" uses the existing code for
procedures/local variables; we generate a block, add the body and local
variables as well as their initialization/clean-up code by means of the
existing trans code, and finish it.
While this may seem a little "hackish" because of generating this symbol
as part of a statement, I really do think that it is quite a good
solution because a lot of things work just with existing code
out-of-the-box.
PPS: In block_2.f08, is there an easy way to check that the local
allocatable array gets free'ed on exit of the block? (Marked by an XXX
comment) If not, I think it won't hurt much to just get rid of the
comment and not check this, but if there is, it would be cool to add
this check.
PPPS: This patch (or a nearly finished version without some error checks
and clean-up) was already tested a little in real-world, somewhat... I
used patched gfortran and BLOCK constructs (mainly for automatic
variable-size arrays and variable-size strings as noted above) for round
2 of Google CodeJam last Saturday. Well, I did perform really, really
bad :D But the patch and gfortran were not once the reason for it ;)
--
Done: Arc-Bar-Cav-Ran-Rog-Sam-Tou-Val-Wiz
To go: Hea-Kni-Mon-Pri
2009-09-28 Daniel Kraft <d@domob.eu>
PR fortran/39626
* gfortran.h (enum gfc_statement): Add ST_BLOCK and ST_END_BLOCK.
(struct gfc_namespace): Convert flags to bit-fields and add flag
`construct_entities' for use with BLOCK constructs.
(enum gfc_exec_code): Add EXEC_BLOCK.
(struct gfc_code): Add namespace field to union for EXEC_BLOCK.
* match.h (gfc_match_block): New prototype.
* parse.h (enum gfc_compile_state): Add COMP_BLOCK.
* trans.h (gfc_process_block_locals): New prototype.
(gfc_trans_deferred_vars): Made public, new prototype.
* trans-stmt.h (gfc_trans_block_construct): New prototype.
* decl.c (gfc_match_end): Handle END BLOCK correctly.
(gfc_match_intent): Error if inside of BLOCK.
(gfc_match_optional), (gfc_match_value): Ditto.
* match.c (gfc_match_block): New routine.
* parse.c (decode_statement): Handle BLOCK statement.
(case_exec_markers): Add ST_BLOCK.
(case_end): Add ST_END_BLOCK.
(gfc_ascii_statement): Handle ST_BLOCK and ST_END_BLOCK.
(parse_spec): Check for statements not allowed inside of BLOCK.
(parse_block_construct): New routine.
(parse_executable): Parse BLOCKs.
(parse_progunit): Disallow CONTAINS in BLOCK constructs.
* resolve.c (is_illegal_recursion): Find real container procedure and
don't get confused by BLOCK constructs.
(resolve_block_construct): New routine.
(gfc_resolve_blocks), (resolve_code): Handle EXEC_BLOCK.
* st.c (gfc_free_statement): Handle EXEC_BLOCK statements.
* trans-decl.c (saved_local_decls): New static variable.
(add_decl_as_local): New routine.
(gfc_finish_var_decl): Add variable as local if inside BLOCK.
(gfc_trans_deferred_vars): Make public.
(gfc_process_block_locals): New routine.
* trans-stmt.c (gfc_trans_block_construct): New routine.
* trans.c (gfc_trans_code): Handle EXEC_BLOCK statements.
2009-09-28 Daniel Kraft <d@domob.eu>
PR fortran/39626
* gfortran.dg/block_1.f08: New test.
* gfortran.dg/block_2.f08: New test.
* gfortran.dg/block_3.f90: New test.
* gfortran.dg/block_4.f08: New test.
* gfortran.dg/block_5.f08: New test.
* gfortran.dg/block_6.f08: New test.
* gfortran.dg/block_7.f08: New test.
* gfortran.dg/block_8.f08: New test.
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 152233)
+++ 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";
@@ -5488,10 +5497,10 @@ gfc_match_end (gfc_statement *st)
{
if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
- && *st != ST_END_FORALL && *st != ST_END_WHERE)
+ && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK)
return MATCH_YES;
- if (gfc_current_block () == NULL)
+ if (!block_name)
return MATCH_YES;
gfc_error ("Expected block name of '%s' in %s statement at %C",
@@ -5854,6 +5863,13 @@ gfc_match_intent (void)
{
sym_intent intent;
+ /* This is not allowed within a BLOCK construct! */
+ if (gfc_current_state () == COMP_BLOCK)
+ {
+ gfc_error ("INTENT is not allowed inside of BLOCK at %C");
+ return MATCH_ERROR;
+ }
+
intent = match_intent_spec ();
if (intent == INTENT_UNKNOWN)
return MATCH_ERROR;
@@ -5879,6 +5895,12 @@ gfc_match_intrinsic (void)
match
gfc_match_optional (void)
{
+ /* This is not allowed within a BLOCK construct! */
+ if (gfc_current_state () == COMP_BLOCK)
+ {
+ gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
+ return MATCH_ERROR;
+ }
gfc_clear_attr (¤t_attr);
current_attr.optional = 1;
@@ -6362,6 +6384,13 @@ gfc_match_value (void)
gfc_symbol *sym;
match m;
+ /* This is not allowed within a BLOCK construct! */
+ if (gfc_current_state () == COMP_BLOCK)
+ {
+ gfc_error ("VALUE is not allowed inside of BLOCK at %C");
+ return MATCH_ERROR;
+ }
+
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
== FAILURE)
return MATCH_ERROR;
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 152233)
+++ 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,
@@ -1278,8 +1280,8 @@ gfc_dt_list;
/* A list of all derived types. */
extern gfc_dt_list *gfc_derived_types;
-/* A namespace describes the contents of procedure, module or
- interface block. */
+/* A namespace describes the contents of procedure, module, interface block
+ or BLOCK construct. */
/* ??? Anything else use these? */
typedef struct gfc_namespace
@@ -1357,16 +1359,20 @@ typedef struct gfc_namespace
gfc_use_list *use_stmts;
/* Set to 1 if namespace is a BLOCK DATA program unit. */
- int is_block_data;
+ unsigned is_block_data:1;
/* Set to 1 if namespace is an interface body with "IMPORT" used. */
- int has_import_set;
+ unsigned has_import_set:1;
/* Set to 1 if resolved has been called for this namespace. */
- int resolved;
+ unsigned resolved:1;
/* Set to 1 if code has been generated for this namespace. */
- int translated;
+ unsigned translated:1;
+
+ /* Set to 1 if symbols in this namespace should be 'construct entities',
+ i.e. for BLOCK local variables. */
+ unsigned construct_entities:1;
}
gfc_namespace;
@@ -1964,7 +1970,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 +2021,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 152233)
+++ 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 152233)
+++ 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 152233)
+++ gcc/fortran/trans.c (working copy)
@@ -1157,6 +1157,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 152233)
+++ 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*);
+
+/* Output initialization/clean-up code that was deferred. */
+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 152233)
+++ 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,29 @@ 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.
+ We look for a procedure symbol, so recurse on the parents if we don't
+ find one (like in case of a BLOCK construct). */
+ for (real_context = context; ; real_context = real_context->parent)
+ {
+ /* We should find something, eventually! */
+ gcc_assert (real_context);
+
+ context_proc = (real_context->entries ? real_context->entries->sym
+ : real_context->proc_name);
+
+ /* In some special cases, there may not be a proc_name, like for this
+ invalid code:
+ real(bad_kind()) function foo () ...
+ when checking the call to bad_kind ().
+ In these cases, we simply return here and assume that the
+ call is ok. */
+ if (!context_proc)
+ return false;
+
+ if (context_proc->attr.flavor != FL_LABEL)
+ break;
+ }
/* A call from sym's body to itself is recursion, of course. */
if (context_proc == proc_sym)
@@ -6838,7 +6857,19 @@ gfc_resolve_forall (gfc_code *code, gfc_
}
-/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
+/* Resolve a BLOCK construct statement. */
+
+static void
+resolve_block_construct (gfc_code* code)
+{
+ /* Eventually, we may want to do some checks here or handle special stuff.
+ But so far the only thing we can do is resolving the local namespace. */
+
+ gfc_resolve (code->ext.ns);
+}
+
+
+/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
DO code nodes. */
static void resolve_code (gfc_code *, gfc_namespace *);
@@ -6875,6 +6906,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 +6937,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 +7101,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 +7286,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 +7295,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 152233)
+++ 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 152233)
+++ 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);
}
@@ -3036,7 +3053,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;
@@ -4552,4 +4569,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 152233)
+++ 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 152233)
+++ 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 152233)
+++ 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,7 @@ decode_statement (void)
gfc_undo_symbols ();
gfc_current_locus = old_locus;
+ match (NULL, gfc_match_block, ST_BLOCK);
match (NULL, gfc_match_do, ST_DO);
match (NULL, gfc_match_select, ST_SELECT_CASE);
@@ -933,7 +934,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: \
@@ -952,7 +954,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. */
@@ -1142,6 +1145,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;
@@ -1190,6 +1196,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;
@@ -2391,6 +2400,27 @@ parse_spec (gfc_statement st)
}
loop:
+
+ /* If we're inside a BLOCK construct, some statements are disallowed.
+ Check this here. Attribute declaration statements like INTENT, OPTIONAL
+ or VALUE are also disallowed, but they don't have a particular ST_*
+ key so we have to check for them individually in their matcher routine. */
+ if (gfc_current_state () == COMP_BLOCK)
+ switch (st)
+ {
+ case ST_IMPLICIT:
+ case ST_IMPLICIT_NONE:
+ case ST_NAMELIST:
+ case ST_COMMON:
+ case ST_EQUIVALENCE:
+ case ST_STATEMENT_FUNCTION:
+ gfc_error ("%s statement is not allowed inside of BLOCK at %C",
+ gfc_ascii_statement (st));
+ break;
+
+ default:
+ break;
+ }
/* If we find a statement that can not be followed by an IMPLICIT statement
(and thus we can expect to see none any further), type the function result
@@ -2908,6 +2938,58 @@ 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);
+ my_ns->construct_entities = 1;
+
+ /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
+ code generation (so it must not be NULL).
+ We set its recursive argument if our container procedure is recursive, so
+ that local variables are accordingly placed on the stack when it
+ will be necessary. */
+ 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. */
@@ -3301,6 +3383,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;
@@ -3359,11 +3445,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. */
@@ -3545,7 +3626,7 @@ parse_contained (int module)
}
-/* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
+/* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
static void
parse_progunit (gfc_statement st)
@@ -3560,7 +3641,10 @@ parse_progunit (gfc_statement st)
unexpected_eof ();
case ST_CONTAINS:
- goto contains;
+ /* This is not allowed within BLOCK! */
+ if (gfc_current_state () != COMP_BLOCK)
+ goto contains;
+ break;
case_end:
accept_statement (st);
@@ -3584,7 +3668,10 @@ loop:
unexpected_eof ();
case ST_CONTAINS:
- goto contains;
+ /* This is not allowed within BLOCK! */
+ if (gfc_current_state () != COMP_BLOCK)
+ goto contains;
+ break;
case_end:
accept_statement (st);
Index: gcc/fortran/parse.h
===================================================================
--- gcc/fortran/parse.h (revision 152233)
+++ 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 myblock
+
+ 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,18 @@
+! { 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'" }
+
+ myname2: BLOCK
+ END BLOCK ! { dg-error "Expected block name of 'myname2'" }
+END PROGRAM main ! { dg-error "Expecting END BLOCK" }
+! { dg-excess-errors "Unexpected end of file" }
Index: gcc/testsuite/gfortran.dg/block_6.f08
===================================================================
--- gcc/testsuite/gfortran.dg/block_6.f08 (revision 0)
+++ gcc/testsuite/gfortran.dg/block_6.f08 (revision 0)
@@ -0,0 +1,17 @@
+! { dg-do run { xfail *-*-* } }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+
+! Check for correct scope of variables that are implicit typed within a BLOCK.
+! This is not yet implemented, thus XFAIL'ed the test.
+
+PROGRAM main
+ IMPLICIT INTEGER(a-z)
+
+ BLOCK
+ ! a gets implicitly typed, but scope should not be limited to BLOCK.
+ a = 42
+ END BLOCK
+
+ ! Here, we should still access the same a that was set above.
+ IF (a /= 42) CALL abort ()
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/block_8.f08
===================================================================
--- gcc/testsuite/gfortran.dg/block_8.f08 (revision 0)
+++ gcc/testsuite/gfortran.dg/block_8.f08 (revision 0)
@@ -0,0 +1,17 @@
+! { dg-do run }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+
+! Check BLOCK with SAVE'ed variables.
+
+PROGRAM main
+ IMPLICIT NONE
+ INTEGER :: i
+
+ DO i = 1, 100
+ BLOCK
+ INTEGER, SAVE :: summed = 0
+ summed = summed + i
+ IF (i == 100 .AND. summed /= 5050) CALL abort ()
+ END BLOCK
+ END DO
+END PROGRAM main
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.
+ BLOCK
+ IF (i /= 42) CALL abort ()
+ i = 5
+ END BLOCK
+ 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_5.f08
===================================================================
--- gcc/testsuite/gfortran.dg/block_5.f08 (revision 0)
+++ gcc/testsuite/gfortran.dg/block_5.f08 (revision 0)
@@ -0,0 +1,38 @@
+! { dg-do compile }
+! { dg-options "-std=legacy" }
+! We want to check for statement functions, thus legacy mode.
+
+! Check for errors with declarations not allowed within BLOCK.
+
+SUBROUTINE proc (a)
+ IMPLICIT NONE
+ INTEGER :: a
+
+ BLOCK
+ INTENT(IN) :: a ! { dg-error "not allowed inside of BLOCK" }
+ VALUE :: a ! { dg-error "not allowed inside of BLOCK" }
+ OPTIONAL :: a ! { dg-error "not allowed inside of BLOCK" }
+ END BLOCK
+END SUBROUTINE proc
+
+PROGRAM main
+ IMPLICIT NONE
+
+ BLOCK
+ IMPLICIT INTEGER(a-z) ! { dg-error "not allowed inside of BLOCK" }
+ INTEGER :: a, b, c, d
+ INTEGER :: stfunc
+ stfunc(a, b) = a + b ! { dg-error "not allowed inside of BLOCK" }
+ EQUIVALENCE (a, b) ! { dg-error "not allowed inside of BLOCK" }
+ NAMELIST /NLIST/ a, b ! { dg-error "not allowed inside of BLOCK" }
+ COMMON /CBLOCK/ c, d ! { dg-error "not allowed inside of BLOCK" }
+ ! This contains is in the specification part.
+ CONTAINS ! { dg-error "Unexpected CONTAINS statement" }
+ END BLOCK
+
+ BLOCK
+ PRINT *, "Hello, world"
+ ! This one in the executable statement part.
+ CONTAINS ! { dg-error "Unexpected CONTAINS statement" }
+ END BLOCK
+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
Index: gcc/testsuite/gfortran.dg/block_7.f08
===================================================================
--- gcc/testsuite/gfortran.dg/block_7.f08 (revision 0)
+++ gcc/testsuite/gfortran.dg/block_7.f08 (revision 0)
@@ -0,0 +1,24 @@
+! { dg-do run }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+
+! Check for correct placement (on the stack) of local variables with BLOCK
+! and recursive container procedures.
+
+RECURSIVE SUBROUTINE myproc (i)
+ INTEGER, INTENT(IN) :: i
+ ! Wrap the block up in some other construct so we see this doesn't mess
+ ! things up, either.
+ DO
+ BLOCK
+ INTEGER :: x
+ x = i
+ IF (i > 0) CALL myproc (i - 1)
+ IF (x /= i) CALL abort ()
+ END BLOCK
+ EXIT
+ END DO
+END SUBROUTINE myproc
+
+PROGRAM main
+ CALL myproc (42)
+END PROGRAM main