+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
/* 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)
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;
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";
{
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",
{
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;
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;
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;
/* 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,
/* 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
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;
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,
const char *omp_name;
gfc_namelist *omp_namelist;
bool omp_bool;
+ gfc_namespace *ns;
}
ext; /* Points to additional structures required by statement */
}
+/* 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
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);
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. */
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);
/* 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: \
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. */
case ST_BACKSPACE:
p = "BACKSPACE";
break;
+ case ST_BLOCK:
+ p = "BLOCK";
+ break;
case ST_BLOCK_DATA:
p = "BLOCK DATA";
break;
case ST_ELSEWHERE:
p = "ELSEWHERE";
break;
+ case ST_END_BLOCK:
+ p = "END BLOCK";
+ break;
case ST_END_BLOCK_DATA:
p = "END BLOCK DATA";
break;
}
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
}
+/* 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. */
return ST_IMPLIED_ENDDO;
break;
+ case ST_BLOCK:
+ parse_block_construct ();
+ break;
+
case ST_IF_BLOCK:
parse_if_block ();
break;
}
-/* 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. */
}
-/* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
+/* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
static void
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);
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);
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
}
{
gfc_symbol* proc_sym;
gfc_symbol* context_proc;
+ gfc_namespace* real_context;
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
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)
}
-/* 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 *);
resolve_branch (b->label1, b);
break;
+ case EXEC_BLOCK:
+ resolve_block_construct (b);
+ break;
+
case EXEC_SELECT:
case EXEC_FORALL:
case EXEC_DO:
break;
default:
- gfc_internal_error ("resolve_block(): Bad block type");
+ gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
}
resolve_code (b->next, ns);
return false;
}
+
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
break;
case EXEC_CALL_PPC:
- resolve_ppc_call (code);
+ resolve_ppc_call (code);
break;
case EXEC_SELECT:
resolve_select (code);
break;
+ case EXEC_BLOCK:
+ gfc_resolve (code->ext.ns);
+ break;
+
case EXEC_DO:
if (code->ext.iterator != NULL)
{
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:
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. */
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
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);
}
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;
}
+/* 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"
}
+/* 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
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 *);
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;
/* 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);
+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
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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" }
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
git://gcc.gnu.org / gcc.git / commitdiff