2017-03-31 Cesar Philippidis <cesar@codesourcery.com>
gcc/fortran
* gfortran.h (struct gfc_omp_clauses): Add bind_name member.
* match.c (gfc_match_call_name): New function.
(gfc_match_call): Break out function name parsing to
gfc_match_call_name. Call it.
* match.h (gfc_match_call_named): Declare.
* openmp.c (gfc_match_oacc_bind_clause): New function.
(gfc_match_omp_clauses): Call it to parse the bind clause.
* trans-openmp.c (gfc_trans_omp_clauses_1): Lower OMP_CLAUSE_BIND.
gcc/testsuite/
* gfortran.dg/goacc/routine-bind-1.f90: New test.
libgomp/
* testsuite/libgomp.oacc-fortran/routine-8.f90: Adjust xfails.
@@ -1315,7 +1315,7 @@ typedef struct gfc_omp_clauses
unsigned async:1, gang:1, worker:1, vector:1, seq:1, independent:1;
unsigned wait:1, par_auto:1, gang_static:1, nohost:1, acc_collapse:1, bind:1;
locus loc;
-
+ char bind_name[GFC_MAX_SYMBOL_LEN+1];
}
gfc_omp_clauses;
@@ -4476,6 +4476,52 @@ match_typebound_call (gfc_symtree* varst)
return MATCH_YES;
}
+match
+gfc_match_call_name (char *name, gfc_symbol **sym, gfc_symtree **st, bool &exit)
+{
+ exit = true;
+
+ if (gfc_get_ha_sym_tree (name, st))
+ return MATCH_ERROR;
+
+ *sym = (*st)->n.sym;
+
+ /* If this is a variable of derived-type, it probably starts a type-bound
+ procedure call. */
+ if (((*sym)->attr.flavor != FL_PROCEDURE
+ || gfc_is_function_return_value (*sym, gfc_current_ns))
+ && ((*sym)->ts.type == BT_DERIVED || (*sym)->ts.type == BT_CLASS))
+ return match_typebound_call (*st);
+
+ /* If it does not seem to be callable (include functions so that the
+ right association is made. They are thrown out in resolution.)
+ ... */
+ if (!(*sym)->attr.generic
+ && !(*sym)->attr.subroutine
+ && !(*sym)->attr.function)
+ {
+ if (!((*sym)->attr.external && !(*sym)->attr.referenced))
+ {
+ /* ...create a symbol in this scope... */
+ if ((*sym)->ns != gfc_current_ns
+ && gfc_get_sym_tree (name, NULL, st, false) == 1)
+ return MATCH_ERROR;
+
+ if (*sym != (*st)->n.sym)
+ *sym = (*st)->n.sym;
+ }
+
+ /* ...and then to try to make the symbol into a subroutine. */
+ if (!gfc_add_subroutine (&(*sym)->attr, (*sym)->name, NULL))
+ return MATCH_ERROR;
+ }
+
+ gfc_set_sym_referenced (*sym);
+ exit = false;
+
+ return MATCH_YES;
+}
+
/* Match a CALL statement. The tricky part here are possible
alternate return specifiers. We handle these by having all
@@ -4495,6 +4541,7 @@ gfc_match_call (void)
gfc_code *c;
match m;
int i;
+ bool exit;
arglist = NULL;
@@ -4504,42 +4551,9 @@ gfc_match_call (void)
if (m != MATCH_YES)
return m;
- if (gfc_get_ha_sym_tree (name, &st))
- return MATCH_ERROR;
-
- sym = st->n.sym;
-
- /* If this is a variable of derived-type, it probably starts a type-bound
- procedure call. */
- if ((sym->attr.flavor != FL_PROCEDURE
- || gfc_is_function_return_value (sym, gfc_current_ns))
- && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
- return match_typebound_call (st);
-
- /* If it does not seem to be callable (include functions so that the
- right association is made. They are thrown out in resolution.)
- ... */
- if (!sym->attr.generic
- && !sym->attr.subroutine
- && !sym->attr.function)
- {
- if (!(sym->attr.external && !sym->attr.referenced))
- {
- /* ...create a symbol in this scope... */
- if (sym->ns != gfc_current_ns
- && gfc_get_sym_tree (name, NULL, &st, false) == 1)
- return MATCH_ERROR;
-
- if (sym != st->n.sym)
- sym = st->n.sym;
- }
-
- /* ...and then to try to make the symbol into a subroutine. */
- if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
- return MATCH_ERROR;
- }
-
- gfc_set_sym_referenced (sym);
+ m = gfc_match_call_name (name, &sym, &st, exit);
+ if (exit)
+ return m;
if (gfc_match_eos () != MATCH_YES)
{
@@ -95,6 +95,7 @@ match gfc_match_nullify (void);
match gfc_match_deallocate (void);
match gfc_match_return (void);
match gfc_match_call (void);
+match gfc_match_call_name (char *, gfc_symbol **, gfc_symtree **, bool &);
/* We want to use this function to check for a common-block-name
that can exist in a bind statement, so removed the "static"
@@ -736,6 +736,26 @@ cleanup:
return MATCH_ERROR;
}
+static match
+gfc_match_oacc_bind_clause (gfc_omp_clauses *clauses)
+{
+ if (gfc_match (" %n )", clauses->bind_name) == MATCH_YES)
+ {
+ gfc_symbol *sym;
+ gfc_symtree *st;
+ bool exit;
+ match m = gfc_match_call_name (clauses->bind_name, &sym, &st, exit);
+
+ if (exit)
+ return m;
+ }
+ else if (gfc_match (" \"%n\" )", clauses->bind_name) != MATCH_YES)
+ return MATCH_ERROR;
+
+ clauses->bind = 1;
+ return MATCH_YES;
+}
+
/* OpenMP 4.5 clauses. */
enum omp_mask1
{
@@ -1027,11 +1047,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, omp_mask mask,
break;
case 'b':
if ((mask & OMP_CLAUSE_BIND) && c->routine_bind == NULL
- && gfc_match ("bind ( %s )", &c->routine_bind) == MATCH_YES)
- {
- c->bind = 1;
- continue;
- }
+ && gfc_match ("bind (") == MATCH_YES
+ && gfc_match_oacc_bind_clause (c))
+ continue;
break;
case 'c':
if ((mask & OMP_CLAUSE_COLLAPSE)
@@ -3033,6 +3033,12 @@ gfc_trans_omp_clauses_1 (stmtblock_t *block, gfc_omp_clauses *clauses,
//TODO
gcc_unreachable();
}
+ if (clauses->bind)
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_BIND);
+ OMP_CLAUSE_BIND_NAME (c) = get_identifier (clauses->bind_name);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
return nreverse (omp_clauses);
}
new file mode 100644
@@ -0,0 +1,43 @@
+! Test if the bind clause accepts named arguments in quotes, and
+! implicit none symbols.
+
+module routines
+implicit none
+contains
+
+ subroutine sr1 (a)
+ implicit none
+ !$acc routine seq
+ integer a
+
+ a = 1
+ end subroutine sr1
+
+ subroutine sr (a)
+ implicit none
+ !$acc routine seq bind(sr1)
+ integer a
+
+ a = 0
+ end subroutine sr
+
+ integer function f1 (a)
+ implicit none
+ !$acc routine seq bind("f")
+ integer a
+ f1 = -1
+ end function f1
+end module routines
+
+program main
+ use routines
+ implicit none
+
+ integer z
+
+ !$acc parallel copyout (z)
+ call sr (z)
+ !$acc end parallel
+
+ print *, z
+end program main
@@ -1,6 +1,8 @@
+! Test the bind clause. Note that bind is currently unimplemented in
+! the middle end.
! { dg-do run }
-! { dg-error "Invalid" "TODO" { xfail *-*-* } 51 }
+! { dg-xfail-if "TODO" { *-*-* } }
program main
integer, parameter :: n = 10