aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/expr.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/expr.c')
-rw-r--r--gcc/fortran/expr.c76
1 files changed, 47 insertions, 29 deletions
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index b535e8a..5c9ce11 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -729,10 +729,10 @@ gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
mpz_t *new_shape, *s;
int i, n;
- if (shape == NULL
+ if (shape == NULL
|| rank <= 1
|| dim == NULL
- || dim->expr_type != EXPR_CONSTANT
+ || dim->expr_type != EXPR_CONSTANT
|| dim->ts.type != BT_INTEGER)
return NULL;
@@ -1389,7 +1389,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
gcc_assert (begin->rank == 1);
/* Zero-sized arrays have no shape and no elements, stop early. */
- if (!begin->shape)
+ if (!begin->shape)
{
mpz_init_set_ui (nelts, 0);
break;
@@ -1473,7 +1473,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
/* An element reference reduces the rank of the expression; don't
add anything to the shape array. */
- if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
+ if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
mpz_set (expr->shape[shape_i++], tmp_mpz);
}
@@ -1520,7 +1520,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
}
else
{
- mpz_add (ctr[d], ctr[d], stride[d]);
+ mpz_add (ctr[d], ctr[d], stride[d]);
if (mpz_cmp_ui (stride[d], 0) > 0
? mpz_cmp (ctr[d], end[d]) > 0
@@ -1952,7 +1952,7 @@ scalarize_intrinsic_call (gfc_expr *e)
gfc_constructor *ci, *new_ctor;
gfc_expr *expr, *old;
int n, i, rank[5], array_arg;
-
+
/* Find which, if any, arguments are arrays. Assume that the old
expression carries the type information and that the first arg
that is an array expression carries all the shape information.*/
@@ -2105,7 +2105,7 @@ check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
case INTRINSIC_LE_OS:
if ((*check_function) (op2) == FAILURE)
return FAILURE;
-
+
if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
&& !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
{
@@ -2271,7 +2271,7 @@ check_inquiry (gfc_expr *e, int not_restricted)
name = e->symtree->n.sym->name;
- functions = (gfc_option.warn_std & GFC_STD_F2003)
+ functions = (gfc_option.warn_std & GFC_STD_F2003)
? inquiry_func_f2003 : inquiry_func_f95;
for (i = 0; functions[i]; i++)
@@ -2360,7 +2360,7 @@ check_transformational (gfc_expr *e)
name = e->symtree->n.sym->name;
- functions = (gfc_option.allow_std & GFC_STD_F2003)
+ functions = (gfc_option.allow_std & GFC_STD_F2003)
? trans_func_f2003 : trans_func_f95;
/* NULL() is dealt with below. */
@@ -3097,7 +3097,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
|| gfc_current_ns->parent->proc_name->attr.subroutine)
|| gfc_current_ns->parent->proc_name->attr.is_main_program))
{
- /* ... that is not a function... */
+ /* ... that is not a function... */
if (!gfc_current_ns->proc_name->attr.function)
bad_proc = true;
@@ -3137,7 +3137,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
}
if (rvalue->expr_type == EXPR_NULL)
- {
+ {
if (has_pointer && (ref == NULL || ref->next == NULL)
&& lvalue->symtree->n.sym->attr.data)
return SUCCESS;
@@ -3150,7 +3150,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
}
/* This is possibly a typo: x = f() instead of x => f(). */
- if (gfc_option.warn_surprising
+ if (gfc_option.warn_surprising
&& rvalue->expr_type == EXPR_FUNCTION
&& rvalue->symtree->n.sym->attr.pointer)
gfc_warning ("POINTER valued function appears on right-hand side of "
@@ -3222,15 +3222,15 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
mpfr_init (rv);
gfc_set_model_kind (rvalue->ts.kind);
mpfr_init (diff);
-
+
mpfr_set (rv, rvalue->value.real, GFC_RND_MODE);
mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE);
-
+
if (!mpfr_zero_p (diff))
gfc_warning ("Change of value in conversion from "
" %s to %s at %L", gfc_typename (&rvalue->ts),
gfc_typename (&lvalue->ts), &rvalue->where);
-
+
mpfr_clear (rv);
mpfr_clear (diff);
}
@@ -3550,9 +3550,22 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
- gfc_error ("Different types in pointer assignment at %L; attempted "
- "assignment of %s to %s", &lvalue->where,
- gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
+ /* Check for F03:C717. */
+ if (UNLIMITED_POLY (rvalue)
+ && !(UNLIMITED_POLY (lvalue)
+ || (lvalue->ts.type == BT_DERIVED
+ && (lvalue->ts.u.derived->attr.is_bind_c
+ || lvalue->ts.u.derived->attr.sequence))))
+ gfc_error ("Data-pointer-object &L must be unlimited "
+ "polymorphic, a sequence derived type or of a "
+ "type with the BIND attribute assignment at %L "
+ "to be compatible with an unlimited polymorphic "
+ "target", &lvalue->where);
+ else
+ gfc_error ("Different types in pointer assignment at %L; "
+ "attempted assignment of %s to %s", &lvalue->where,
+ gfc_typename (&rvalue->ts),
+ gfc_typename (&lvalue->ts));
return FAILURE;
}
@@ -3569,9 +3582,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return FAILURE;
}
- if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
/* Make sure the vtab is present. */
+ if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
gfc_find_derived_vtab (rvalue->ts.u.derived);
+ else if (UNLIMITED_POLY (lvalue) && !UNLIMITED_POLY (rvalue))
+ gfc_find_intrinsic_vtab (&rvalue->ts);
/* Check rank remapping. */
if (rank_remap)
@@ -3647,7 +3662,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
+
if (gfc_has_vector_index (rvalue))
{
@@ -3747,7 +3762,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
if (r == FAILURE)
return r;
-
+
if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
{
/* F08:C461. Additional checks for pointer initialization. */
@@ -3772,7 +3787,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
return FAILURE;
}
}
-
+
if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL)
{
/* F08:C1220. Additional checks for procedure pointer initialization. */
@@ -4251,7 +4266,7 @@ gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
static bool
replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
{
- if ((expr->expr_type == EXPR_VARIABLE
+ if ((expr->expr_type == EXPR_VARIABLE
|| (expr->expr_type == EXPR_FUNCTION
&& !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
&& expr->symtree->n.sym->ns == sym->ts.interface->formal_ns
@@ -4285,7 +4300,7 @@ replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
{
gfc_component *comp;
comp = (gfc_component *)sym;
- if ((expr->expr_type == EXPR_VARIABLE
+ if ((expr->expr_type == EXPR_VARIABLE
|| (expr->expr_type == EXPR_FUNCTION
&& !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
&& expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
@@ -4421,7 +4436,7 @@ gfc_get_corank (gfc_expr *e)
if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
corank = e->ts.u.derived->components->as
? e->ts.u.derived->components->as->corank : 0;
- else
+ else
corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
for (ref = e->ref; ref; ref = ref->next)
@@ -4478,7 +4493,7 @@ gfc_has_ultimate_pointer (gfc_expr *e)
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
last = ref;
-
+
if (last && last->u.c.component->ts.type == BT_CLASS)
return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
else if (last && last->u.c.component->ts.type == BT_DERIVED)
@@ -4598,7 +4613,7 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
ar->as->upper[i]->value.integer) != 0))
colon = false;
}
-
+
return true;
}
@@ -4618,7 +4633,7 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
isym = gfc_find_function (name);
gcc_assert (isym);
-
+
result = gfc_get_expr ();
result->expr_type = EXPR_FUNCTION;
result->ts = isym->ts;
@@ -4669,6 +4684,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
bool is_pointer;
bool check_intentin;
bool ptr_component;
+ bool unlimited;
symbol_attribute attr;
gfc_ref* ref;
@@ -4683,6 +4699,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
}
+ unlimited = e->ts.type == BT_CLASS && UNLIMITED_POLY (sym);
+
attr = gfc_expr_attr (e);
if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer)
{
@@ -4722,7 +4740,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
/* Find out whether the expr is a pointer; this also means following
component references to the last one. */
is_pointer = (attr.pointer || attr.proc_pointer);
- if (pointer && !is_pointer)
+ if (pointer && !is_pointer && !unlimited)
{
if (context)
gfc_error ("Non-POINTER in pointer association context (%s)"
generated by cgit v1.1 at 2025-05-30 10:51:03 +0000