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;
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':
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. */
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_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
{
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_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;
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;
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
= 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
