mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-22 03:30:29 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/39626 (Correctly implement details of Fortran 2008 BLOCK construct)

Browse Source 
2009-09-29  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-29  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.

From-SVN: r152266
This commit is contained in:
Daniel Kraft 2009-09-29 09:42:42 +02:00 committed by Daniel Kraft
parent 9b13eb8457
commit 9abe5e56e2
23 changed files with 559 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
gcc/fortran/ChangeLog
View File

@ -1,3 +1,41 @@
2009-09-29 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 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/35862

37
gcc/fortran/decl.c
View File

@ -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 (&current_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;

27
gcc/fortran/gfortran.h
View File

@ -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 */

24
gcc/fortran/match.c
View File

@ -1705,6 +1705,30 @@ gfc_free_iterator (gfc_iterator *iter, int flag)
}
/* 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

1
gcc/fortran/match.h
View File

@ -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);

109
gcc/fortran/parse.c
View File

@ -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);

3
gcc/fortran/parse.h
View File

@ -29,7 +29,8 @@ along with GCC; see the file COPYING3. If not see
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
}

56
gcc/fortran/resolve.c
View File

@ -1101,6 +1101,7 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
{
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, gfc_namespace* context)
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_namespace *ns, int forall_save)
}
/* 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_namespace *ns)
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_namespace *ns)
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, gfc_namespace *ns)
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_namespace *ns)
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_namespace *ns)
resolve_select (code);
break;
case EXEC_BLOCK:
gfc_resolve (code->ext.ns);
break;
case EXEC_DO:
if (code->ext.iterator != NULL)
{

4
gcc/fortran/st.c
View File

@ -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:

45
gcc/fortran/trans-decl.c
View File

@ -64,6 +64,10 @@ static GTY(()) tree saved_parent_function_decls;
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_symbol * sym)
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_sym, tree body)
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 * ns)
}
/* 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"

30
gcc/fortran/trans-stmt.c
View File

@ -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

1
gcc/fortran/trans-stmt.h
View File

@ -43,6 +43,7 @@ tree gfc_trans_call (gfc_code *, bool, tree, tree, bool);
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 *);

4
gcc/fortran/trans.c
View File

@ -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;

6
gcc/fortran/trans.h
View File

@ -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);

12
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,15 @@
2009-09-29 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.
2009-09-28 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/35862

34
gcc/testsuite/gfortran.dg/block_1.f08 Normal file
View File

@ -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

38
gcc/testsuite/gfortran.dg/block_2.f08 Normal file
View File

@ -0,0 +1,38 @@
! { dg-do run }
! { dg-options "-std=f2008 -fall-intrinsics -fdump-tree-original" }
! 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 :: alloc_arr(:)
IF (ALLOCATED (alloc_arr)) CALL abort ()
ALLOCATE (alloc_arr(n))
IF (SIZE (alloc_arr) /= 5) CALL abort ()
! Should be free'ed here (but at least somewhere), this is checked
! with pattern below.
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
! { dg-final { scan-tree-dump-times "free \\(\\(void \\*\\) alloc_arr\\.data" 1 "original" } }

12
gcc/testsuite/gfortran.dg/block_3.f90 Normal file
View File

@ -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

18
gcc/testsuite/gfortran.dg/block_4.f08 Normal file
View File

@ -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" }

38
gcc/testsuite/gfortran.dg/block_5.f08 Normal file
View File

@ -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

17
gcc/testsuite/gfortran.dg/block_6.f08 Normal file
View File

@ -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

24
gcc/testsuite/gfortran.dg/block_7.f08 Normal file
View File

@ -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

17
gcc/testsuite/gfortran.dg/block_8.f08 Normal file
View File

@ -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