diff options
author | Daniel Kraft <d@domob.eu> | 2009-09-29 09:42:42 +0200 |
---|---|---|
committer | Daniel Kraft <domob@gcc.gnu.org> | 2009-09-29 09:42:42 +0200 |
commit | 9abe5e56e20294d899363abc8898d4fa6a72e2f7 (patch) | |
tree | 8bbc9942644ae27a9137a47480f2dfeeba5ab54c /gcc/fortran | |
parent | 9b13eb8457f5b02769cfd6762c8885d58be80f78 (diff) | |
download | gcc-9abe5e56e20294d899363abc8898d4fa6a72e2f7.zip gcc-9abe5e56e20294d899363abc8898d4fa6a72e2f7.tar.gz gcc-9abe5e56e20294d899363abc8898d4fa6a72e2f7.tar.bz2 |
re PR fortran/39626 (Correctly implement details of Fortran 2008 BLOCK construct)
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
Diffstat (limited to 'gcc/fortran')
-rw-r--r-- | gcc/fortran/ChangeLog | 38 | ||||
-rw-r--r-- | gcc/fortran/decl.c | 37 | ||||
-rw-r--r-- | gcc/fortran/gfortran.h | 27 | ||||
-rw-r--r-- | gcc/fortran/match.c | 24 | ||||
-rw-r--r-- | gcc/fortran/match.h | 1 | ||||
-rw-r--r-- | gcc/fortran/parse.c | 109 | ||||
-rw-r--r-- | gcc/fortran/parse.h | 3 | ||||
-rw-r--r-- | gcc/fortran/resolve.c | 56 | ||||
-rw-r--r-- | gcc/fortran/st.c | 4 | ||||
-rw-r--r-- | gcc/fortran/trans-decl.c | 45 | ||||
-rw-r--r-- | gcc/fortran/trans-stmt.c | 30 | ||||
-rw-r--r-- | gcc/fortran/trans-stmt.h | 1 | ||||
-rw-r--r-- | gcc/fortran/trans.c | 4 | ||||
-rw-r--r-- | gcc/fortran/trans.h | 6 |
14 files changed, 349 insertions, 36 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 39b96e6..addfcbee 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 3ce7fd4..cfd8b81 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b6ac254..0dce218 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 */ diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index ccd1071..919d5d1 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -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 diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 196115c..a53c7f0 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -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); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 93a6cfd..e6b5dbb 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -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); diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 7fe2330..7239c38 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -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 } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f208f40..3eec50e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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) { diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index d77ef81..c3c640a 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -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: diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 4e72a23..3d6a5e2 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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" diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 6aed99b..25a5b3b 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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 diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index d7307df..0b8461c 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -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 *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 136987a..f53f75e 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -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; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 4469023..27b040a 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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); |