/* Main parser.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
match m;
char c;
-#ifdef GFC_DEBUG
- gfc_symbol_state ();
-#endif
+ gfc_enforce_clean_symbol_state ();
gfc_clear_error (); /* Clear any pending errors. */
gfc_clear_warning (); /* Clear any pending warnings. */
match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
break;
+ case 'l':
+ match ("lock", gfc_match_lock, ST_LOCK);
+ break;
+
case 'm':
- match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC);
+ match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
match ("module", gfc_match_module, ST_MODULE);
break;
break;
case 'u':
+ match ("unlock", gfc_match_unlock, ST_UNLOCK);
match ("use", gfc_match_use, ST_USE);
break;
locus old_locus;
char c;
-#ifdef GFC_DEBUG
- gfc_symbol_state ();
-#endif
+ gfc_enforce_clean_symbol_state ();
gfc_clear_error (); /* Clear any pending errors. */
gfc_clear_warning (); /* Clear any pending warnings. */
return ST_NONE;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
old_locus = gfc_current_locus;
/* General OpenMP directive matching: Instead of testing every possible
match ("do", gfc_match_omp_do, ST_OMP_DO);
break;
case 'e':
+ match ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC);
match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
case 't':
match ("task", gfc_match_omp_task, ST_OMP_TASK);
match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
+ match ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
match ("threadprivate", gfc_match_omp_threadprivate,
ST_OMP_THREADPRIVATE);
case 'w':
{
locus old_locus;
-#ifdef GFC_DEBUG
- gfc_symbol_state ();
-#endif
+ gfc_enforce_clean_symbol_state ();
gfc_clear_error (); /* Clear any pending errors. */
gfc_clear_warning (); /* Clear any pending warnings. */
return decode_gcc_attribute ();
}
- else if (c == '$' && gfc_option.flag_openmp)
+ else if (c == '$' && gfc_option.gfc_flag_openmp)
{
int i;
for (i = 0; i < 5; i++)
{
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
switch (c)
{
here, except for GCC attributes and OpenMP directives. */
case '*':
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
if (TOLOWER (c) == 'g')
{
- for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+ for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
gcc_assert (TOLOWER (c) == "gcc$"[i]);
return decode_gcc_attribute ();
}
- else if (c == '$' && gfc_option.flag_openmp)
+ else if (c == '$' && gfc_option.gfc_flag_openmp)
{
- for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+ for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
if (c != ' ' && c != '0')
of a previous statement. If we see something here besides a
space or zero, it must be a bad continuation line. */
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
if (c == '\n')
goto blank_line;
do
{
loc = gfc_current_locus;
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
}
while (gfc_is_whitespace (c));
gfc_statement st;
locus old_locus;
+ gfc_enforce_clean_symbol_state ();
+
gfc_new_block = NULL;
gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
+ gfc_current_ns->old_equiv = gfc_current_ns->equiv;
for (;;)
{
gfc_statement_label = NULL;
case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
- case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_ERROR_STOP: \
- case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY
+ case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
+ case ST_ERROR_STOP: case ST_SYNC_ALL: case ST_SYNC_IMAGES: \
+ case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK
/* Statements that mark other executable statements. */
p->sym = sym;
p->head = p->tail = NULL;
p->do_variable = NULL;
+
+ /* If this the state of a construct like BLOCK, DO or IF, the corresponding
+ construct statement was accepted right before pushing the state. Thus,
+ the construct's gfc_code is available as tail of the parent state. */
+ gcc_assert (gfc_state_stack);
+ p->construct = gfc_state_stack->tail;
+
gfc_state_stack = p;
}
case ST_ENDIF:
case ST_END_SELECT:
case ST_END_CRITICAL:
+ case ST_END_BLOCK:
+ case ST_END_ASSOCIATE:
case_executable:
case_exec_markers:
type = ST_LABEL_TARGET;
case ST_INTERFACE:
p = "INTERFACE";
break;
+ case ST_LOCK:
+ p = "LOCK";
+ break;
case ST_PARAMETER:
p = "PARAMETER";
break;
case ST_TYPE:
p = "TYPE";
break;
+ case ST_UNLOCK:
+ p = "UNLOCK";
+ break;
case ST_USE:
p = "USE";
break;
case ST_OMP_DO:
p = "!$OMP DO";
break;
+ case ST_OMP_END_ATOMIC:
+ p = "!$OMP END ATOMIC";
+ break;
case ST_OMP_END_CRITICAL:
p = "!$OMP END CRITICAL";
break;
case ST_OMP_TASKWAIT:
p = "!$OMP TASKWAIT";
break;
+ case ST_OMP_TASKYIELD:
+ p = "!$OMP TASKYIELD";
+ break;
case ST_OMP_THREADPRIVATE:
p = "!$OMP THREADPRIVATE";
break;
case ST_END_CRITICAL:
if (gfc_statement_label != NULL)
{
+ new_st.op = EXEC_END_NESTED_BLOCK;
+ add_statement ();
+ }
+ break;
+
+ /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
+ one parallel block. Thus, we add the special code to the nested block
+ itself, instead of the parent one. */
+ case ST_END_BLOCK:
+ case ST_END_ASSOCIATE:
+ if (gfc_statement_label != NULL)
+ {
new_st.op = EXEC_END_BLOCK;
add_statement ();
}
gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list);
gfc_current_ns->cl_list = gfc_current_ns->old_cl_list;
+ gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
+ gfc_current_ns->equiv = gfc_current_ns->old_equiv;
+
gfc_new_block = NULL;
gfc_undo_symbols ();
gfc_clear_warning ();
case ST_DATA_DECL:
gfc_error ("Components in TYPE at %C must precede CONTAINS");
- error_flag = true;
- break;
+ goto error;
case ST_PROCEDURE:
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Type-bound"
" procedure at %C") == FAILURE)
- error_flag = true;
+ goto error;
accept_statement (ST_PROCEDURE);
seen_comps = true;
case ST_GENERIC:
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC binding"
" at %C") == FAILURE)
- error_flag = true;
+ goto error;
accept_statement (ST_GENERIC);
seen_comps = true;
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: FINAL procedure declaration"
" at %C") == FAILURE)
- error_flag = true;
+ goto error;
accept_statement (ST_FINAL);
seen_comps = true;
&& (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
"definition at %C with empty CONTAINS "
"section") == FAILURE))
- error_flag = true;
+ goto error;
/* ST_END_TYPE is accepted by parse_derived after return. */
break;
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
"a MODULE");
- error_flag = true;
- break;
+ goto error;
}
if (seen_comps)
{
gfc_error ("PRIVATE statement at %C must precede procedure"
" bindings");
- error_flag = true;
- break;
+ goto error;
}
if (seen_private)
{
gfc_error ("Duplicate PRIVATE statement at %C");
- error_flag = true;
+ goto error;
}
accept_statement (ST_PRIVATE);
case ST_SEQUENCE:
gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
- error_flag = true;
- break;
+ goto error;
case ST_CONTAINS:
gfc_error ("Already inside a CONTAINS block at %C");
- error_flag = true;
- break;
+ goto error;
default:
unexpected_statement (st);
break;
}
+
+ continue;
+
+error:
+ error_flag = true;
+ reject_statement ();
}
pop_state ();
gfc_statement st;
gfc_state_data s;
gfc_symbol *sym;
- gfc_component *c;
+ gfc_component *c, *lock_comp = NULL;
accept_statement (ST_DERIVED_DECL);
push_state (&s, COMP_DERIVED, gfc_new_block);
sym = gfc_current_block ();
for (c = sym->components; c; c = c->next)
{
+ bool coarray, lock_type, allocatable, pointer;
+ coarray = lock_type = allocatable = pointer = false;
+
/* Look for allocatable components. */
if (c->attr.allocatable
- || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->attr.allocatable)
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
- sym->attr.alloc_comp = 1;
+ {
+ allocatable = true;
+ sym->attr.alloc_comp = 1;
+ }
/* Look for pointer components. */
if (c->attr.pointer
- || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer)
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->attr.class_pointer)
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
- sym->attr.pointer_comp = 1;
+ {
+ pointer = true;
+ sym->attr.pointer_comp = 1;
+ }
/* Look for procedure pointer components. */
if (c->attr.proc_pointer
/* Looking for coarray components. */
if (c->attr.codimension
- || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
- sym->attr.coarray_comp = 1;
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->attr.codimension))
+ {
+ coarray = true;
+ sym->attr.coarray_comp = 1;
+ }
+
+ if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp)
+ {
+ coarray = true;
+ if (!pointer && !allocatable)
+ sym->attr.coarray_comp = 1;
+ }
+
+ /* Looking for lock_type components. */
+ if ((c->ts.type == BT_DERIVED
+ && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_LOCK_TYPE)
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
+ && !allocatable && !pointer))
+ {
+ lock_type = 1;
+ lock_comp = c;
+ sym->attr.lock_comp = 1;
+ }
+
+ /* Check for F2008, C1302 - and recall that pointers may not be coarrays
+ (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
+ unless there are nondirect [allocatable or pointer] components
+ involved (cf. 1.3.33.1 and 1.3.33.3). */
+
+ if (pointer && !coarray && lock_type)
+ gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
+ "codimension or be a subcomponent of a coarray, "
+ "which is not possible as the component has the "
+ "pointer attribute", c->name, &c->loc);
+ else if (pointer && !coarray && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.lock_comp)
+ gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
+ "of type LOCK_TYPE, which must have a codimension or be a "
+ "subcomponent of a coarray", c->name, &c->loc);
+
+ if (lock_type && allocatable && !coarray)
+ gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
+ "a codimension", c->name, &c->loc);
+ else if (lock_type && allocatable && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.lock_comp)
+ gfc_error ("Allocatable component %s at %L must have a codimension as "
+ "it has a noncoarray subcomponent of type LOCK_TYPE",
+ c->name, &c->loc);
+
+ if (sym->attr.coarray_comp && !coarray && lock_type)
+ gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
+ "subcomponent of type LOCK_TYPE must have a codimension or "
+ "be a subcomponent of a coarray. (Variables of type %s may "
+ "not have a codimension as already a coarray "
+ "subcomponent exists)", c->name, &c->loc, sym->name);
+
+ if (sym->attr.lock_comp && coarray && !lock_type)
+ gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
+ "subcomponent of type LOCK_TYPE must have a codimension or "
+ "be a subcomponent of a coarray. (Variables of type %s may "
+ "not have a codimension as %s at %L has a codimension or a "
+ "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
+ sym->name, c->name, &c->loc);
/* Look for private components. */
if (sym->component_access == ACCESS_PRIVATE
}
- /* Make sure that a generic interface has only subroutines or
- functions and that the generic name has the right attribute. */
- if (current_interface.type == INTERFACE_GENERIC)
+ /* Make sure that the generic name has the right attribute. */
+ if (current_interface.type == INTERFACE_GENERIC
+ && current_state == COMP_NONE)
{
- if (current_state == COMP_NONE)
- {
- if (new_state == COMP_FUNCTION && sym)
- gfc_add_function (&sym->attr, sym->name, NULL);
- else if (new_state == COMP_SUBROUTINE && sym)
- gfc_add_subroutine (&sym->attr, sym->name, NULL);
+ if (new_state == COMP_FUNCTION && sym)
+ gfc_add_function (&sym->attr, sym->name, NULL);
+ else if (new_state == COMP_SUBROUTINE && sym)
+ gfc_add_subroutine (&sym->attr, sym->name, NULL);
- current_state = new_state;
- }
- else
- {
- if (new_state != current_state)
- {
- if (new_state == COMP_SUBROUTINE)
- gfc_error ("SUBROUTINE at %C does not belong in a "
- "generic function interface");
-
- if (new_state == COMP_FUNCTION)
- gfc_error ("FUNCTION at %C does not belong in a "
- "generic subroutine interface");
- }
- }
+ current_state = new_state;
}
if (current_interface.type == INTERFACE_ABSTRACT)
gfc_commit_symbols ();
}
else
- gfc_error_check ();
+ {
+ gfc_error_check ();
+ gfc_undo_symbols ();
+ }
gfc_current_locus =loc;
return m;
case ST_STATEMENT_FUNCTION:
gfc_error ("%s statement is not allowed inside of BLOCK at %C",
gfc_ascii_statement (st));
+ reject_statement ();
break;
default:
{
gfc_error ("%s statement must appear in a MODULE",
gfc_ascii_statement (st));
+ reject_statement ();
break;
}
{
gfc_error ("%s statement at %C follows another accessibility "
"specification", gfc_ascii_statement (st));
+ reject_statement ();
break;
}
{
gfc_error ("ELSEWHERE statement at %C follows previous "
"unmasked ELSEWHERE");
+ reject_statement ();
break;
}
{
gfc_select_type_stack *old = select_type_stack;
select_type_stack = old->prev;
- gfc_free (old);
+ free (old);
}
return 0;
for (p = gfc_state_stack; p; p = p->previous)
- if (p->state == COMP_DO)
+ if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
break;
if (p == NULL)
/* At this point, the label doesn't terminate the innermost loop.
Make sure it doesn't terminate another one. */
for (; p; p = p->previous)
- if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
+ if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
+ && p->ext.end_do_label == gfc_statement_label)
{
gfc_error ("End of nonblock DO statement at %C is interwoven "
"with another DO loop");
gfc_build_block_ns (gfc_namespace *parent_ns)
{
gfc_namespace* my_ns;
+ static int numblock = 1;
my_ns = gfc_get_namespace (parent_ns, 1);
my_ns->construct_entities = 1;
else
{
gfc_try t;
+ char buffer[20]; /* Enough to hold "block@2147483648\n". */
- gfc_get_symbol ("block@", my_ns, &my_ns->proc_name);
+ snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
+ gfc_get_symbol (buffer, 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);
+ gfc_commit_symbol (my_ns->proc_name);
}
if (parent_ns->proc_name)
gfc_state_data s;
gfc_statement st;
gfc_association_list* a;
- gfc_code* assignTail;
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C");
new_st.ext.block.ns = my_ns;
gcc_assert (new_st.ext.block.assoc);
- /* Add all associations to expressions as BLOCK variables, and create
- assignments to them giving their values. */
+ /* Add all associate-names as BLOCK variables. Creating them is enough
+ for now, they'll get their values during trans-* phase. */
gfc_current_ns = my_ns;
- assignTail = NULL;
for (a = new_st.ext.block.assoc; a; a = a->next)
- if (!a->variable)
- {
- gfc_code* newAssign;
-
- if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
- gcc_unreachable ();
-
- /* Note that in certain cases, the target-expression's type is not yet
- known and so we have to adapt the symbol's ts also during resolution
- for these cases. */
- a->st->n.sym->ts = a->target->ts;
- a->st->n.sym->attr.flavor = FL_VARIABLE;
- a->st->n.sym->assoc = a;
- gfc_set_sym_referenced (a->st->n.sym);
-
- /* Create the assignment to calculate the expression and set it. */
- newAssign = gfc_get_code ();
- newAssign->op = EXEC_ASSIGN;
- newAssign->loc = gfc_current_locus;
- newAssign->expr1 = gfc_get_variable_expr (a->st);
- newAssign->expr2 = a->target;
-
- /* Hang it in. */
- if (assignTail)
- assignTail->next = newAssign;
- else
- gfc_current_ns->code = newAssign;
- assignTail = newAssign;
- }
- else
- {
- gfc_error ("Association to variables is not yet supported at %C");
- return;
- }
- gcc_assert (assignTail);
+ {
+ gfc_symbol* sym;
+
+ if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
+ gcc_unreachable ();
+
+ sym = a->st->n.sym;
+ sym->attr.flavor = FL_VARIABLE;
+ sym->assoc = a;
+ sym->declared_at = a->where;
+ gfc_set_sym_referenced (sym);
+
+ /* Initialize the typespec. It is not available in all cases,
+ however, as it may only be set on the target during resolution.
+ Still, sometimes it helps to have it right now -- especially
+ for parsing component references on the associate-name
+ in case of assication to a derived-type. */
+ sym->ts = a->target->ts;
+ }
accept_statement (ST_ASSOCIATE);
push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
case_end:
accept_statement (st);
- assignTail->next = gfc_state_stack->head;
+ my_ns->code = gfc_state_stack->head;
break;
default:
gfc_code *top;
gfc_state_data s;
gfc_symtree *stree;
+ gfc_exec_op do_op;
+ do_op = new_st.op;
s.ext.end_do_label = new_st.label1;
if (new_st.ext.iterator != NULL)
accept_statement (ST_DO);
top = gfc_state_stack->tail;
- push_state (&s, COMP_DO, gfc_new_block);
+ push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
+ gfc_new_block);
s.do_variable = stree;
/* Parse the statements of OpenMP atomic directive. */
-static void
+static gfc_statement
parse_omp_atomic (void)
{
gfc_statement st;
gfc_code *cp, *np;
gfc_state_data s;
+ int count;
accept_statement (ST_OMP_ATOMIC);
np = new_level (cp);
np->op = cp->op;
np->block = NULL;
+ count = 1 + (cp->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE);
- for (;;)
+ while (count)
{
st = next_statement ();
if (st == ST_NONE)
unexpected_eof ();
else if (st == ST_ASSIGNMENT)
- break;
+ {
+ accept_statement (st);
+ count--;
+ }
else
unexpected_statement (st);
}
- accept_statement (st);
-
pop_state ();
+
+ st = next_statement ();
+ if (st == ST_OMP_END_ATOMIC)
+ {
+ gfc_clear_new_st ();
+ gfc_commit_symbols ();
+ gfc_warning_check ();
+ st = next_statement ();
+ }
+ else if (cp->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE)
+ gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
+ return st;
}
continue;
case ST_OMP_ATOMIC:
- parse_omp_atomic ();
- break;
+ st = parse_omp_atomic ();
+ continue;
default:
cycle = false;
&& strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
gfc_error ("Name after !$omp critical and !$omp end critical does "
"not match at %C");
- gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
+ free (CONST_CAST (char *, new_st.ext.omp_name));
break;
case EXEC_OMP_END_SINGLE:
cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
continue;
case ST_OMP_ATOMIC:
- parse_omp_atomic ();
- break;
+ st = parse_omp_atomic ();
+ continue;
default:
return st;
st->n.sym = sym;
sym->refs++;
- /* Free the old (local) symbol. */
- old_sym->refs--;
- if (old_sym->refs == 0)
- gfc_free_symbol (old_sym);
+ gfc_release_symbol (old_sym);
}
fixup_contained:
sym->attr.contained = 1;
sym->attr.referenced = 1;
+ /* Set implicit_pure so that it can be reset if any of the
+ tests for purity fail. This is used for some optimisation
+ during translation. */
+ if (!sym->attr.pure)
+ sym->attr.implicit_pure = 1;
+
parse_progunit (ST_NONE);
/* Fix up any sibling functions that refer to this one. */
{
gfc_error ("CONTAINS statement at %C is already in a contained "
"program unit");
+ reject_statement ();
st = next_statement ();
goto loop;
}
gfc_current_ns = gfc_global_ns_list;
for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
{
- gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ continue; /* Already resolved. */
+
+ if (gfc_current_ns->proc_name)
+ gfc_current_locus = gfc_current_ns->proc_name->declared_at;
gfc_resolve (gfc_current_ns);
gfc_current_ns->derived_types = gfc_derived_types;
gfc_derived_types = NULL;
is active. This could be in a different order to resolution if
there are forward references in the file. */
static void
-translate_all_program_units (gfc_namespace *gfc_global_ns_list)
+translate_all_program_units (gfc_namespace *gfc_global_ns_list,
+ bool main_in_tu)
{
int errors;
gfc_current_ns = gfc_global_ns_list;
gfc_get_errors (NULL, &errors);
+ /* If the main program is in the translation unit and we have
+ -fcoarray=libs, generate the static variables. */
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB && main_in_tu)
+ gfc_init_coarray_decl (true);
+
+ /* We first translate all modules to make sure that later parts
+ of the program can use the decl. Then we translate the nonmodules. */
+
for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
{
+ if (!gfc_current_ns->proc_name
+ || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+ continue;
+
+ gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+ gfc_derived_types = gfc_current_ns->derived_types;
+ gfc_generate_module_code (gfc_current_ns);
+ gfc_current_ns->translated = 1;
+ }
+
+ gfc_current_ns = gfc_global_ns_list;
+ for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+ {
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ continue;
+
gfc_current_locus = gfc_current_ns->proc_name->declared_at;
gfc_derived_types = gfc_current_ns->derived_types;
gfc_generate_code (gfc_current_ns);
gfc_current_ns = gfc_global_ns_list;
for (;gfc_current_ns;)
{
- gfc_namespace *ns = gfc_current_ns->sibling;
+ gfc_namespace *ns;
+
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ gfc_current_ns = gfc_current_ns->sibling;
+ continue;
+ }
+
+ ns = gfc_current_ns->sibling;
gfc_derived_types = gfc_current_ns->derived_types;
gfc_done_2 ();
gfc_current_ns = ns;
gfc_resolve (gfc_current_ns);
/* Dump the parse tree if requested. */
- if (gfc_option.dump_parse_tree)
+ if (gfc_option.dump_fortran_original)
gfc_dump_parse_tree (gfc_current_ns, stdout);
gfc_get_errors (NULL, &errors);
if (s.state == COMP_MODULE)
{
gfc_dump_module (s.sym->name, errors_before == errors);
- if (errors == 0)
- gfc_generate_module_code (gfc_current_ns);
- pop_state ();
if (!gfc_option.flag_whole_file)
- gfc_done_2 ();
+ {
+ if (errors == 0)
+ gfc_generate_module_code (gfc_current_ns);
+ pop_state ();
+ gfc_done_2 ();
+ }
else
{
gfc_current_ns->derived_types = gfc_derived_types;
gfc_derived_types = NULL;
- gfc_current_ns = NULL;
+ goto prog_units;
}
}
else
/* Do the parse tree dump. */
gfc_current_ns
- = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
+ = gfc_option.dump_fortran_original ? gfc_global_ns_list : NULL;
for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
- {
- gfc_dump_parse_tree (gfc_current_ns, stdout);
- fputs ("------------------------------------------\n\n", stdout);
- }
+ if (!gfc_current_ns->proc_name
+ || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+ {
+ gfc_dump_parse_tree (gfc_current_ns, stdout);
+ fputs ("------------------------------------------\n\n", stdout);
+ }
/* Do the translation. */
- translate_all_program_units (gfc_global_ns_list);
+ translate_all_program_units (gfc_global_ns_list, seen_program);
termination:
OSDN Git Service
