more accurate omp in fortran
Jakub Jelinek
jakub@redhat.com
Fri Oct 30 17:07:00 GMT 2015
Hi!
On Fri, Oct 30, 2015 at 10:03:23AM -0700, Cesar Philippidis wrote:
This looks good to me, iff you write ChangeLog entry for it.
> diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
> index 90f63cf..13e730f 100644
> --- a/gcc/fortran/gfortran.h
> +++ b/gcc/fortran/gfortran.h
> @@ -1123,6 +1123,7 @@ typedef struct gfc_omp_namelist
> } u;
> struct gfc_omp_namelist_udr *udr;
> struct gfc_omp_namelist *next;
> + locus where;
> }
> gfc_omp_namelist;
>
> diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
> index 6c78c97..197b6d6 100644
> --- a/gcc/fortran/openmp.c
> +++ b/gcc/fortran/openmp.c
> @@ -244,6 +244,7 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
> }
> tail->sym = sym;
> tail->expr = expr;
> + tail->where = cur_loc;
> goto next_item;
> case MATCH_NO:
> break;
> @@ -278,6 +279,7 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
> tail = tail->next;
> }
> tail->sym = sym;
> + tail->where = cur_loc;
> }
>
> next_item:
> @@ -2860,9 +2862,8 @@ oacc_compatible_clauses (gfc_omp_clauses *clauses, int list,
> /* OpenMP directive resolving routines. */
>
> static void
> -resolve_omp_clauses (gfc_code *code, locus *where,
> - gfc_omp_clauses *omp_clauses, gfc_namespace *ns,
> - bool openacc = false)
> +resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
> + gfc_namespace *ns, bool openacc = false)
> {
> gfc_omp_namelist *n;
> gfc_expr_list *el;
> @@ -2921,7 +2922,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> {
> if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
> gfc_error ("Variable %qs is not a dummy argument at %L",
> - n->sym->name, where);
> + n->sym->name, n->where);
> continue;
> }
> if (n->sym->attr.flavor == FL_PROCEDURE
> @@ -2953,7 +2954,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> }
> }
> gfc_error ("Object %qs is not a variable at %L", n->sym->name,
> - where);
> + &n->where);
> }
>
> for (list = 0; list < OMP_LIST_NUM; list++)
> @@ -2969,7 +2970,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> if (n->sym->mark && !oacc_compatible_clauses (omp_clauses, list,
> n->sym, openacc))
> gfc_error ("Symbol %qs present on multiple clauses at %L",
> - n->sym->name, where);
> + n->sym->name, n->where);
> else
> n->sym->mark = 1;
> }
> @@ -2980,7 +2981,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> if (n->sym->mark)
> {
> gfc_error ("Symbol %qs present on multiple clauses at %L",
> - n->sym->name, where);
> + n->sym->name, n->where);
> n->sym->mark = 0;
> }
>
> @@ -2988,7 +2989,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> {
> if (n->sym->mark)
> gfc_error ("Symbol %qs present on multiple clauses at %L",
> - n->sym->name, where);
> + n->sym->name, n->where);
> else
> n->sym->mark = 1;
> }
> @@ -2999,7 +3000,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> {
> if (n->sym->mark)
> gfc_error ("Symbol %qs present on multiple clauses at %L",
> - n->sym->name, where);
> + n->sym->name, n->where);
> else
> n->sym->mark = 1;
> }
> @@ -3011,7 +3012,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> {
> if (n->sym->mark)
> gfc_error ("Symbol %qs present on multiple clauses at %L",
> - n->sym->name, where);
> + n->sym->name, n->where);
> else
> n->sym->mark = 1;
> }
> @@ -3025,7 +3026,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> {
> if (n->expr == NULL && n->sym->mark)
> gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
> - n->sym->name, where);
> + n->sym->name, &n->where);
> else
> n->sym->mark = 1;
> }
> @@ -3047,7 +3048,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> {
> if (!n->sym->attr.threadprivate)
> gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
> - " at %L", n->sym->name, where);
> + " at %L", n->sym->name, &n->where);
> }
> break;
> case OMP_LIST_COPYPRIVATE:
> @@ -3055,10 +3056,10 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> {
> if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
> gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
> - "at %L", n->sym->name, where);
> + "at %L", n->sym->name, &n->where);
> if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
> gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
> - "at %L", n->sym->name, where);
> + "at %L", n->sym->name, &n->where);
> }
> break;
> case OMP_LIST_SHARED:
> @@ -3066,13 +3067,13 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> {
> if (n->sym->attr.threadprivate)
> gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
> - "%L", n->sym->name, where);
> + "%L", n->sym->name, &n->where);
> if (n->sym->attr.cray_pointee)
> gfc_error ("Cray pointee %qs in SHARED clause at %L",
> - n->sym->name, where);
> + n->sym->name, &n->where);
> if (n->sym->attr.associate_var)
> gfc_error ("ASSOCIATE name %qs in SHARED clause at %L",
> - n->sym->name, where);
> + n->sym->name, &n->where);
> }
> break;
> case OMP_LIST_ALIGNED:
> @@ -3088,7 +3089,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> != ISOCBINDING_PTR)))
> gfc_error ("%qs in ALIGNED clause must be POINTER, "
> "ALLOCATABLE, Cray pointer or C_PTR at %L",
> - n->sym->name, where);
> + n->sym->name, &n->where);
> else if (n->expr)
> {
> gfc_expr *expr = n->expr;
> @@ -3100,7 +3101,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> || alignment <= 0)
> gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
> "positive constant integer alignment "
> - "expression", n->sym->name, where);
> + "expression", n->sym->name, &n->where);
> }
> }
> break;
> @@ -3119,10 +3120,11 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> || n->expr->ref->next
> || n->expr->ref->type != REF_ARRAY)
> gfc_error ("%qs in %s clause at %L is not a proper "
> - "array section", n->sym->name, name, where);
> + "array section", n->sym->name, name,
> + &n->where);
> else if (n->expr->ref->u.ar.codimen)
> gfc_error ("Coarrays not supported in %s clause at %L",
> - name, where);
> + name, &n->where);
> else
> {
> int i;
> @@ -3132,7 +3134,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> {
> gfc_error ("Stride should not be specified for "
> "array section in %s clause at %L",
> - name, where);
> + name, &n->where);
> break;
> }
> else if (ar->dimen_type[i] != DIMEN_ELEMENT
> @@ -3140,7 +3142,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> {
> gfc_error ("%qs in %s clause at %L is not a "
> "proper array section",
> - n->sym->name, name, where);
> + n->sym->name, name, &n->where);
> break;
> }
> else if (list == OMP_LIST_DEPEND
> @@ -3153,7 +3155,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> {
> gfc_error ("%qs in DEPEND clause at %L is a "
> "zero size array section",
> - n->sym->name, where);
> + n->sym->name, &n->where);
> break;
> }
> }
> @@ -3162,9 +3164,9 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> {
> if (list == OMP_LIST_MAP
> && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR)
> - resolve_oacc_deviceptr_clause (n->sym, *where, name);
> + resolve_oacc_deviceptr_clause (n->sym, n->where, name);
> else
> - resolve_oacc_data_clauses (n->sym, *where, name);
> + resolve_oacc_data_clauses (n->sym, n->where, name);
> }
> }
>
> @@ -3174,10 +3176,10 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> n->sym->attr.referenced = 1;
> if (n->sym->attr.threadprivate)
> gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, &n->where);
> if (n->sym->attr.cray_pointee)
> gfc_error ("Cray pointee %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, &n->where);
> }
> break;
> default:
> @@ -3186,35 +3188,35 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> bool bad = false;
> if (n->sym->attr.threadprivate)
> gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, &n->where);
> if (n->sym->attr.cray_pointee)
> gfc_error ("Cray pointee %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, &n->where);
> if (n->sym->attr.associate_var)
> gfc_error ("ASSOCIATE name %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, &n->where);
> if (list != OMP_LIST_PRIVATE)
> {
> if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION)
> gfc_error ("Procedure pointer %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, &n->where);
> if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
> gfc_error ("POINTER object %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, &n->where);
> if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
> gfc_error ("Cray pointer %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, &n->where);
> }
> if (code
> && (oacc_is_loop (code) || code->op == EXEC_OACC_PARALLEL))
> - check_array_not_assumed (n->sym, *where, name);
> + check_array_not_assumed (n->sym, n->where, name);
> else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
> gfc_error ("Assumed size array %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, &n->where);
> if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
> gfc_error ("Variable %qs in %s clause is used in "
> "NAMELIST statement at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, &n->where);
> if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
> switch (list)
> {
> @@ -3223,7 +3225,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> case OMP_LIST_LINEAR:
> /* case OMP_LIST_REDUCTION: */
> gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, &n->where);
> break;
> default:
> break;
> @@ -3317,7 +3319,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> }
> gfc_error ("!$OMP DECLARE REDUCTION %s not found "
> "for type %s at %L", udr_name,
> - gfc_typename (&n->sym->ts), where);
> + gfc_typename (&n->sym->ts), &n->where);
> }
> else
> {
> @@ -3339,10 +3341,10 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> case OMP_LIST_LINEAR:
> if (n->sym->ts.type != BT_INTEGER)
> gfc_error ("LINEAR variable %qs must be INTEGER "
> - "at %L", n->sym->name, where);
> + "at %L", n->sym->name, &n->where);
> else if (!code && !n->sym->attr.value)
> gfc_error ("LINEAR dummy argument %qs must have VALUE "
> - "attribute at %L", n->sym->name, where);
> + "attribute at %L", n->sym->name, &n->where);
> else if (n->expr)
> {
> gfc_expr *expr = n->expr;
> @@ -3351,11 +3353,11 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> || expr->rank != 0)
> gfc_error ("%qs in LINEAR clause at %L requires "
> "a scalar integer linear-step expression",
> - n->sym->name, where);
> + n->sym->name, &n->where);
> else if (!code && expr->expr_type != EXPR_CONSTANT)
> gfc_error ("%qs in LINEAR clause at %L requires "
> "a constant integer linear-step expression",
> - n->sym->name, where);
> + n->sym->name, &n->where);
> }
> break;
> /* Workaround for PR middle-end/26316, nothing really needs
> @@ -3368,22 +3370,22 @@ resolve_omp_clauses (gfc_code *code, locus *where,
> || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
> && CLASS_DATA (n->sym)->attr.allocatable))
> gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, n->where);
> if (n->sym->attr.pointer
> || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
> && CLASS_DATA (n->sym)->attr.class_pointer))
> gfc_error ("POINTER object %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, n->where);
> if (n->sym->attr.cray_pointer)
> gfc_error ("Cray pointer object %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, n->where);
> if (n->sym->attr.cray_pointee)
> gfc_error ("Cray pointee object %qs in %s clause at %L",
> - n->sym->name, name, where);
> + n->sym->name, name, n->where);
> /* FALLTHRU */
> case OMP_LIST_DEVICE_RESIDENT:
> - check_symbol_not_pointer (n->sym, *where, name);
> - check_array_not_assumed (n->sym, *where, name);
> + check_symbol_not_pointer (n->sym, n->where, name);
> + check_array_not_assumed (n->sym, n->where, name);
> break;
> default:
> break;
> @@ -4149,7 +4151,7 @@ resolve_omp_do (gfc_code *code)
> }
>
> if (code->ext.omp_clauses)
> - resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL);
> + resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
>
> do_code = code->block->next;
> collapse = code->ext.omp_clauses->collapse;
> @@ -4587,7 +4589,7 @@ resolve_oacc_loop (gfc_code *code)
> int collapse;
>
> if (code->ext.omp_clauses)
> - resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL, true);
> + resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
>
> do_code = code->block->next;
> collapse = code->ext.omp_clauses->collapse;
> @@ -4652,8 +4654,7 @@ gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
> case EXEC_OACC_EXIT_DATA:
> case EXEC_OACC_WAIT:
> case EXEC_OACC_CACHE:
> - resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL,
> - true);
> + resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
> break;
> case EXEC_OACC_PARALLEL_LOOP:
> case EXEC_OACC_KERNELS_LOOP:
> @@ -4711,11 +4712,11 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
> case EXEC_OMP_TEAMS:
> case EXEC_OMP_WORKSHARE:
> if (code->ext.omp_clauses)
> - resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL);
> + resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
> break;
> case EXEC_OMP_TARGET_UPDATE:
> if (code->ext.omp_clauses)
> - resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL);
> + resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
> if (code->ext.omp_clauses == NULL
> || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
> && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
> @@ -4743,7 +4744,7 @@ gfc_resolve_omp_declare_simd (gfc_namespace *ns)
> gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
> "%qs at %L", ns->proc_name->name, &ods->where);
> if (ods->clauses)
> - resolve_omp_clauses (NULL, &ods->where, ods->clauses, ns);
> + resolve_omp_clauses (NULL, ods->clauses, ns);
> }
> }
>
> diff --git a/gcc/testsuite/gfortran.dg/gomp/intentin1.f90 b/gcc/testsuite/gfortran.dg/gomp/intentin1.f90
> index f2a2e98..8bd53aa 100644
> --- a/gcc/testsuite/gfortran.dg/gomp/intentin1.f90
> +++ b/gcc/testsuite/gfortran.dg/gomp/intentin1.f90
> @@ -11,6 +11,6 @@ subroutine foo (x)
> !$omp simd linear (x) ! { dg-error "INTENT.IN. POINTER" }
> do i = 1, 10
> end do
> -!$omp single ! { dg-error "INTENT.IN. POINTER" }
> -!$omp end single copyprivate (x)
> +!$omp single
> +!$omp end single copyprivate (x) ! { dg-error "INTENT.IN. POINTER" }
> end
Jakub
More information about the Fortran
mailing list