static match
match_ext_add_operand (gfc_expr **result)
{
gfc_expr *all, *e;
locus where;
match m;
int i;
where = gfc_current_locus;
i = match_add_op ();
if (i == 0)
return match_add_operand (result);
if (gfc_notification_std (GFC_STD_GNU) == ERROR)
{
gfc_error ("Extension: Unary operator following "
"arithmetic operator (use parentheses) at %C");
return MATCH_ERROR;
}
else
gfc_warning (0, "Extension: Unary operator following "
"arithmetic operator (use parentheses) at %C");
m = match_ext_add_operand (&e);
if (m != MATCH_YES)
return m;
if (i == -1)
all = gfc_uminus (e);
else
all = gfc_uplus (e);
if (all == NULL)
{
gfc_free_expr (e);
return MATCH_ERROR;
}
all->where = where;
*result = all;
return MATCH_YES;
}
static tree
build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
{
gfc_symbol *common_sym;
tree decl;
/* Create a namespace to store symbols for common blocks. */
if (gfc_common_ns == NULL)
gfc_common_ns = gfc_get_namespace (NULL, 0);
gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
decl = common_sym->backend_decl;
/* Update the size of this common block as needed. */
if (decl != NULL_TREE)
{
tree size = TYPE_SIZE_UNIT (union_type);
/* Named common blocks of the same name shall be of the same size
in all scoping units of a program in which they appear, but
blank common blocks may be of different sizes. */
if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size)
&& strcmp (com->name, BLANK_COMMON_NAME))
gfc_warning ("Named COMMON block '%s' at %L shall be of the "
"same size as elsewhere (%lu vs %lu bytes)", com->name,
&com->where,
(unsigned long) TREE_INT_CST_LOW (size),
(unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl)));
if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
{
DECL_SIZE (decl) = TYPE_SIZE (union_type);
DECL_SIZE_UNIT (decl) = size;
DECL_MODE (decl) = TYPE_MODE (union_type);
TREE_TYPE (decl) = union_type;
layout_decl (decl, 0);
}
}
/* If this common block has been declared in a previous program unit,
and either it is already initialized or there is no new initialization
for it, just return. */
if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
return decl;
/* If there is no backend_decl for the common block, build it. */
if (decl == NULL_TREE)
{
decl = build_decl (input_location,
VAR_DECL, get_identifier (com->name), union_type);
gfc_set_decl_assembler_name (decl, gfc_sym_mangled_common_id (com));
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
DECL_IGNORED_P (decl) = 1;
if (!com->is_bind_c)
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
else
{
/* Do not set the alignment for bind(c) common blocks to
BIGGEST_ALIGNMENT because that won't match what C does. Also,
for common blocks with one element, the alignment must be
that of the field within the common block in order to match
what C will do. */
tree field = NULL_TREE;
field = TYPE_FIELDS (TREE_TYPE (decl));
if (DECL_CHAIN (field) == NULL_TREE)
DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field));
}
DECL_USER_ALIGN (decl) = 0;
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
gfc_set_decl_location (decl, &com->where);
if (com->threadprivate)
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
/* Place the back end declaration for this common block in
GLOBAL_BINDING_LEVEL. */
common_sym->backend_decl = pushdecl_top_level (decl);
}
/* Has no initial values. */
if (!is_init)
{
DECL_INITIAL (decl) = NULL_TREE;
DECL_COMMON (decl) = 1;
DECL_DEFER_OUTPUT (decl) = 1;
}
else
{
DECL_INITIAL (decl) = error_mark_node;
DECL_COMMON (decl) = 0;
DECL_DEFER_OUTPUT (decl) = 0;
}
return decl;
}
static void
translate_common (gfc_common_head *common, gfc_symbol *var_list)
{
gfc_symbol *sym;
segment_info *s;
segment_info *common_segment;
HOST_WIDE_INT offset;
HOST_WIDE_INT current_offset;
unsigned HOST_WIDE_INT align;
bool saw_equiv;
common_segment = NULL;
offset = 0;
current_offset = 0;
align = 1;
saw_equiv = false;
/* Add symbols to the segment. */
for (sym = var_list; sym; sym = sym->common_next)
{
current_segment = common_segment;
s = find_segment_info (sym);
/* Symbol has already been added via an equivalence. Multiple
use associations of the same common block result in equiv_built
being set but no information about the symbol in the segment. */
if (s && sym->equiv_built)
{
/* Ensure the current location is properly aligned. */
align = TYPE_ALIGN_UNIT (s->field);
current_offset = (current_offset + align - 1) &~ (align - 1);
/* Verify that it ended up where we expect it. */
if (s->offset != current_offset)
{
gfc_error ("Equivalence for '%s' does not match ordering of "
"COMMON '%s' at %L", sym->name,
common->name, &common->where);
}
}
else
{
/* A symbol we haven't seen before. */
s = current_segment = get_segment_info (sym, current_offset);
/* Add all objects directly or indirectly equivalenced with this
symbol. */
add_equivalences (&saw_equiv);
if (current_segment->offset < 0)
gfc_error ("The equivalence set for '%s' cause an invalid "
"extension to COMMON '%s' at %L", sym->name,
common->name, &common->where);
if (gfc_option.flag_align_commons)
offset = align_segment (&align);
if (offset)
{
/* The required offset conflicts with previous alignment
requirements. Insert padding immediately before this
segment. */
if (gfc_option.warn_align_commons)
{
if (strcmp (common->name, BLANK_COMMON_NAME))
gfc_warning ("Padding of %d bytes required before '%s' in "
"COMMON '%s' at %L; reorder elements or use "
"-fno-align-commons", (int)offset,
s->sym->name, common->name, &common->where);
else
gfc_warning ("Padding of %d bytes required before '%s' in "
"COMMON at %L; reorder elements or use "
"-fno-align-commons", (int)offset,
s->sym->name, &common->where);
}
}
/* Apply the offset to the new segments. */
apply_segment_offset (current_segment, offset);
current_offset += offset;
/* Add the new segments to the common block. */
common_segment = add_segments (common_segment, current_segment);
}
/* The offset of the next common variable. */
current_offset += s->length;
}
if (common_segment == NULL)
{
gfc_error ("COMMON '%s' at %L does not exist",
common->name, &common->where);
return;
}
if (common_segment->offset != 0 && gfc_option.warn_align_commons)
{
if (strcmp (common->name, BLANK_COMMON_NAME))
gfc_warning ("COMMON '%s' at %L requires %d bytes of padding; "
"reorder elements or use -fno-align-commons",
common->name, &common->where, (int)common_segment->offset);
else
gfc_warning ("COMMON at %L requires %d bytes of padding; "
"reorder elements or use -fno-align-commons",
&common->where, (int)common_segment->offset);
}
create_common (common, common_segment, saw_equiv);
}
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 int
gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
gfc_expr *expr, gfc_dep_check elemental)
{
gfc_expr *arg;
gcc_assert (var->expr_type == EXPR_VARIABLE);
gcc_assert (var->rank > 0);
switch (expr->expr_type)
{
case EXPR_VARIABLE:
/* In case of elemental subroutines, there is no dependency
between two same-range array references. */
if (gfc_ref_needs_temporary_p (expr->ref)
|| gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
{
if (elemental == ELEM_DONT_CHECK_VARIABLE)
{
/* Too many false positive with pointers. */
if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
{
/* Elemental procedures forbid unspecified intents,
and we don't check dependencies for INTENT_IN args. */
gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
/* We are told not to check dependencies.
We do it, however, and issue a warning in case we find one.
If a dependency is found in the case
elemental == ELEM_CHECK_VARIABLE, we will generate
a temporary, so we don't need to bother the user. */
gfc_warning ("INTENT(%s) actual argument at %L might "
"interfere with actual argument at %L.",
intent == INTENT_OUT ? "OUT" : "INOUT",
&var->where, &expr->where);
}
return 0;
}
else
return 1;
}
return 0;
case EXPR_ARRAY:
return gfc_check_dependency (var, expr, 1);
case EXPR_FUNCTION:
if (intent != INTENT_IN && expr->inline_noncopying_intrinsic
&& (arg = gfc_get_noncopying_intrinsic_argument (expr))
&& gfc_check_argument_var_dependency (var, intent, arg, elemental))
return 1;
if (elemental)
{
if ((expr->value.function.esym
&& expr->value.function.esym->attr.elemental)
|| (expr->value.function.isym
&& expr->value.function.isym->elemental))
return gfc_check_fncall_dependency (var, intent, NULL,
expr->value.function.actual,
ELEM_CHECK_VARIABLE);
}
return 0;
case EXPR_OP:
/* In case of non-elemental procedures, there is no need to catch
dependencies, as we will make a temporary anyway. */
if (elemental)
{
/* If the actual arg EXPR is an expression, we need to catch
a dependency between variables in EXPR and VAR,
an intent((IN)OUT) variable. */
if (expr->value.op.op1
&& gfc_check_argument_var_dependency (var, intent,
expr->value.op.op1,
ELEM_CHECK_VARIABLE))
return 1;
else if (expr->value.op.op2
&& gfc_check_argument_var_dependency (var, intent,
expr->value.op.op2,
ELEM_CHECK_VARIABLE))
return 1;
}
return 0;
default:
return 0;
}
}
static tree
build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
{
gfc_symbol *common_sym;
tree decl;
/* Create a namespace to store symbols for common blocks. */
if (gfc_common_ns == NULL)
gfc_common_ns = gfc_get_namespace (NULL);
gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
decl = common_sym->backend_decl;
/* Update the size of this common block as needed. */
if (decl != NULL_TREE)
{
tree size = TYPE_SIZE_UNIT (union_type);
if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
{
/* Named common blocks of the same name shall be of the same size
in all scoping units of a program in which they appear, but
blank common blocks may be of different sizes. */
if (strcmp (com->name, BLANK_COMMON_NAME))
gfc_warning ("Named COMMON block '%s' at %L shall be of the "
"same size", com->name, &com->where);
DECL_SIZE_UNIT (decl) = size;
}
}
/* If this common block has been declared in a previous program unit,
and either it is already initialized or there is no new initialization
for it, just return. */
if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
return decl;
/* If there is no backend_decl for the common block, build it. */
if (decl == NULL_TREE)
{
decl = build_decl (VAR_DECL, get_identifier (com->name), union_type);
SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com->name));
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
DECL_USER_ALIGN (decl) = 0;
gfc_set_decl_location (decl, &com->where);
/* Place the back end declaration for this common block in
GLOBAL_BINDING_LEVEL. */
common_sym->backend_decl = pushdecl_top_level (decl);
}
/* Has no initial values. */
if (!is_init)
{
DECL_INITIAL (decl) = NULL_TREE;
DECL_COMMON (decl) = 1;
DECL_DEFER_OUTPUT (decl) = 1;
}
else
{
DECL_INITIAL (decl) = error_mark_node;
DECL_COMMON (decl) = 0;
DECL_DEFER_OUTPUT (decl) = 0;
}
return decl;
}
static void
translate_common (gfc_common_head *common, gfc_symbol *var_list)
{
gfc_symbol *sym;
segment_info *s;
segment_info *common_segment;
HOST_WIDE_INT offset;
HOST_WIDE_INT current_offset;
unsigned HOST_WIDE_INT align;
unsigned HOST_WIDE_INT max_align;
bool saw_equiv;
common_segment = NULL;
current_offset = 0;
max_align = 1;
saw_equiv = false;
/* Add symbols to the segment. */
for (sym = var_list; sym; sym = sym->common_next)
{
if (sym->equiv_built)
{
/* Symbol has already been added via an equivalence. */
current_segment = common_segment;
s = find_segment_info (sym);
/* Ensure the current location is properly aligned. */
align = TYPE_ALIGN_UNIT (s->field);
current_offset = (current_offset + align - 1) &~ (align - 1);
/* Verify that it ended up where we expect it. */
if (s->offset != current_offset)
{
gfc_error ("Equivalence for '%s' does not match ordering of "
"COMMON '%s' at %L", sym->name,
common->name, &common->where);
}
}
else
{
/* A symbol we haven't seen before. */
s = current_segment = get_segment_info (sym, current_offset);
/* Add all objects directly or indirectly equivalenced with this
symbol. */
add_equivalences (&saw_equiv);
if (current_segment->offset < 0)
gfc_error ("The equivalence set for '%s' cause an invalid "
"extension to COMMON '%s' at %L", sym->name,
common->name, &common->where);
offset = align_segment (&align);
if (offset & (max_align - 1))
{
/* The required offset conflicts with previous alignment
requirements. Insert padding immediately before this
segment. */
gfc_warning ("Padding of %d bytes required before '%s' in "
"COMMON '%s' at %L", offset, s->sym->name,
common->name, &common->where);
}
else
{
/* Offset the whole common block. */
apply_segment_offset (common_segment, offset);
}
/* Apply the offset to the new segments. */
apply_segment_offset (current_segment, offset);
current_offset += offset;
if (max_align < align)
max_align = align;
/* Add the new segments to the common block. */
common_segment = add_segments (common_segment, current_segment);
}
/* The offset of the next common variable. */
current_offset += s->length;
}
if (common_segment->offset != 0)
{
gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start",
common->name, &common->where, common_segment->offset);
}
create_common (common, common_segment, saw_equiv);
}
