tree
gfc_conv_constant_to_tree (gfc_expr * expr)
{
gcc_assert (expr->expr_type == EXPR_CONSTANT);
switch (expr->ts.type)
{
case BT_INTEGER:
return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
case BT_REAL:
return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
case BT_LOGICAL:
return build_int_cst (gfc_get_logical_type (expr->ts.kind),
expr->value.logical);
case BT_COMPLEX:
{
tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
expr->ts.kind);
tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
expr->ts.kind);
return build_complex (NULL_TREE, real, imag);
}
case BT_CHARACTER:
return gfc_build_string_const (expr->value.character.length,
expr->value.character.string);
default:
fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
gfc_typename (&expr->ts));
}
}
tree
gfc_conv_constant_to_tree (gfc_expr * expr)
{
tree res;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
/* If it is has a prescribed memory representation, we build a string
constant and VIEW_CONVERT to its type. */
switch (expr->ts.type)
{
case BT_INTEGER:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_int_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
else
return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
case BT_REAL:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_real_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
else
return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
case BT_LOGICAL:
if (expr->representation.string)
{
tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_int_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
if (!integer_zerop (tmp) && !integer_onep (tmp))
gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
" has undefined result at %L", &expr->where);
return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
}
else
return build_int_cst (gfc_get_logical_type (expr->ts.kind),
expr->value.logical);
case BT_COMPLEX:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_complex_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
else
{
tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),
expr->ts.kind, expr->is_snan);
tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),
expr->ts.kind, expr->is_snan);
return build_complex (gfc_typenode_for_spec (&expr->ts),
real, imag);
}
case BT_CHARACTER:
res = gfc_build_wide_string_const (expr->ts.kind,
expr->value.character.length,
expr->value.character.string);
return res;
case BT_HOLLERITH:
return gfc_build_string_const (expr->representation.length,
expr->representation.string);
default:
fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
gfc_typename (&expr->ts));
}
}
static void
resolve_omp_clauses (gfc_code *code)
{
gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
gfc_namelist *n;
int list;
static const char *clause_names[]
= { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
"COPYIN", "REDUCTION" };
if (omp_clauses == NULL)
return;
if (omp_clauses->if_expr)
{
gfc_expr *expr = omp_clauses->if_expr;
if (gfc_resolve_expr (expr) == FAILURE
|| expr->ts.type != BT_LOGICAL || expr->rank != 0)
gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
&expr->where);
}
if (omp_clauses->num_threads)
{
gfc_expr *expr = omp_clauses->num_threads;
if (gfc_resolve_expr (expr) == FAILURE
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
gfc_error ("NUM_THREADS clause at %L requires a scalar "
"INTEGER expression", &expr->where);
}
if (omp_clauses->chunk_size)
{
gfc_expr *expr = omp_clauses->chunk_size;
if (gfc_resolve_expr (expr) == FAILURE
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
gfc_error ("SCHEDULE clause's chunk_size at %L requires "
"a scalar INTEGER expression", &expr->where);
}
/* Check that no symbol appears on multiple clauses, except that
a symbol can appear on both firstprivate and lastprivate. */
for (list = 0; list < OMP_LIST_NUM; list++)
for (n = omp_clauses->lists[list]; n; n = n->next)
{
n->sym->mark = 0;
if (n->sym->attr.flavor == FL_VARIABLE)
continue;
if (n->sym->attr.flavor == FL_PROCEDURE
&& n->sym->result == n->sym
&& n->sym->attr.function)
{
if (gfc_current_ns->proc_name == n->sym
|| (gfc_current_ns->parent
&& gfc_current_ns->parent->proc_name == n->sym))
continue;
if (gfc_current_ns->proc_name->attr.entry_master)
{
gfc_entry_list *el = gfc_current_ns->entries;
for (; el; el = el->next)
if (el->sym == n->sym)
break;
if (el)
continue;
}
if (gfc_current_ns->parent
&& gfc_current_ns->parent->proc_name->attr.entry_master)
{
gfc_entry_list *el = gfc_current_ns->parent->entries;
for (; el; el = el->next)
if (el->sym == n->sym)
break;
if (el)
continue;
}
if (n->sym->attr.proc_pointer)
continue;
}
gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
&code->loc);
}
for (list = 0; list < OMP_LIST_NUM; list++)
if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
for (n = omp_clauses->lists[list]; n; n = n->next)
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
n->sym->name, &code->loc);
else
n->sym->mark = 1;
}
gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
for (n = omp_clauses->lists[list]; n; n = n->next)
if (n->sym->mark)
{
gfc_error ("Symbol '%s' present on multiple clauses at %L",
n->sym->name, &code->loc);
n->sym->mark = 0;
}
for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
n->sym->name, &code->loc);
else
n->sym->mark = 1;
}
for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
n->sym->mark = 0;
for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
n->sym->name, &code->loc);
else
n->sym->mark = 1;
}
for (list = 0; list < OMP_LIST_NUM; list++)
if ((n = omp_clauses->lists[list]) != NULL)
{
const char *name;
if (list < OMP_LIST_REDUCTION_FIRST)
name = clause_names[list];
else if (list <= OMP_LIST_REDUCTION_LAST)
name = clause_names[OMP_LIST_REDUCTION_FIRST];
else
gcc_unreachable ();
switch (list)
{
case OMP_LIST_COPYIN:
for (; n != NULL; n = n->next)
{
if (!n->sym->attr.threadprivate)
gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
" at %L", n->sym->name, &code->loc);
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
n->sym->name, &code->loc);
}
break;
case OMP_LIST_COPYPRIVATE:
for (; n != NULL; n = n->next)
{
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
"at %L", n->sym->name, &code->loc);
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
n->sym->name, &code->loc);
}
break;
case OMP_LIST_SHARED:
for (; n != NULL; n = n->next)
{
if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
"%L", n->sym->name, &code->loc);
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in SHARED clause at %L",
n->sym->name, &code->loc);
}
break;
default:
for (; n != NULL; n = n->next)
{
if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
n->sym->name, name, &code->loc);
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in %s clause at %L",
n->sym->name, name, &code->loc);
if (list != OMP_LIST_PRIVATE)
{
if (n->sym->attr.pointer)
gfc_error ("POINTER object '%s' in %s clause at %L",
n->sym->name, name, &code->loc);
/* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST) &&
n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
name, n->sym->name, &code->loc);
if (n->sym->attr.cray_pointer)
gfc_error ("Cray pointer '%s' in %s clause at %L",
n->sym->name, name, &code->loc);
}
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in %s clause at %L",
n->sym->name, name, &code->loc);
if (n->sym->attr.in_namelist
&& (list < OMP_LIST_REDUCTION_FIRST
|| list > OMP_LIST_REDUCTION_LAST))
gfc_error ("Variable '%s' in %s clause is used in "
"NAMELIST statement at %L",
n->sym->name, name, &code->loc);
switch (list)
{
case OMP_LIST_PLUS:
case OMP_LIST_MULT:
case OMP_LIST_SUB:
if (!gfc_numeric_ts (&n->sym->ts))
gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
list == OMP_LIST_PLUS ? '+'
: list == OMP_LIST_MULT ? '*' : '-',
n->sym->name, &code->loc,
gfc_typename (&n->sym->ts));
break;
case OMP_LIST_AND:
case OMP_LIST_OR:
case OMP_LIST_EQV:
case OMP_LIST_NEQV:
if (n->sym->ts.type != BT_LOGICAL)
gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
"at %L",
list == OMP_LIST_AND ? ".AND."
: list == OMP_LIST_OR ? ".OR."
: list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
n->sym->name, &code->loc);
break;
case OMP_LIST_MAX:
case OMP_LIST_MIN:
if (n->sym->ts.type != BT_INTEGER
&& n->sym->ts.type != BT_REAL)
gfc_error ("%s REDUCTION variable '%s' must be "
"INTEGER or REAL at %L",
list == OMP_LIST_MAX ? "MAX" : "MIN",
n->sym->name, &code->loc);
break;
case OMP_LIST_IAND:
case OMP_LIST_IOR:
case OMP_LIST_IEOR:
if (n->sym->ts.type != BT_INTEGER)
gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
"at %L",
list == OMP_LIST_IAND ? "IAND"
: list == OMP_LIST_MULT ? "IOR" : "IEOR",
n->sym->name, &code->loc);
break;
/* Workaround for PR middle-end/26316, nothing really needs
to be done here for OMP_LIST_PRIVATE. */
case OMP_LIST_PRIVATE:
gcc_assert (code->op != EXEC_NOP);
default:
break;
}
}
break;
}
}
}
