&& (set_by_optional || arg->expr->rank != rank)
&& !(isym && isym->id == GFC_ISYM_CONVERSION))
{
- gfc_warning (OPT_Wpedantic,
- "%qs at %L is an array and OPTIONAL; IF IT IS "
- "MISSING, it cannot be the actual argument of an "
- "ELEMENTAL procedure unless there is a non-optional "
- "argument with the same rank (12.4.1.5)",
- arg->expr->symtree->n.sym->name, &arg->expr->where);
+ bool t = false;
+ gfc_actual_arglist *a;
+
+ /* Scan the argument list for a non-optional argument with the
+ same rank as arg. */
+ for (a = arg0; a; a = a->next)
+ if (a != arg
+ && a->expr->rank == arg->expr->rank
+ && !a->expr->symtree->n.sym->attr.optional)
+ {
+ t = true;
+ break;
+ }
+
+ if (!t)
+ gfc_warning (OPT_Wpedantic,
+ "%qs at %L is an array and OPTIONAL; If it is not "
+ "present, then it cannot be the actual argument of "
+ "an ELEMENTAL procedure unless there is a non-optional"
+ " argument with the same rank "
+ "(Fortran 2018, 15.5.2.12)",
+ arg->expr->symtree->n.sym->name, &arg->expr->where);
}
}
/* Elemental procedure's array actual arguments must conform. */
if (e != NULL)
{
- if (!gfc_check_conformance (arg->expr, e, "elemental procedure"))
+ if (!gfc_check_conformance (arg->expr, e, _("elemental procedure")))
return false;
}
else
gfc_error ("Interface mismatch in global procedure %qs at %L: %s",
sym->name, &sym->declared_at, reason);
+ sym->error = 1;
gfc_errors_to_warnings (false);
goto done;
}
/* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */
if (op1->ts.type == BT_BOZ)
{
- if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
- "an operand of a relational operator",
- &op1->where))
+ if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear "
+ "as an operand of a relational operator"),
+ &op1->where))
return false;
if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind))
/* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */
if (op2->ts.type == BT_BOZ)
{
- if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as "
- "an operand of a relational operator",
+ if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear"
+ " as an operand of a relational operator"),
&op2->where))
return false;
const char *msg;
if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS)
- msg = "Equality comparison for %s at %L";
+ msg = G_("Equality comparison for %s at %L");
else
- msg = "Inequality comparison for %s at %L";
+ msg = G_("Inequality comparison for %s at %L");
gfc_warning (OPT_Wcompare_reals, msg,
gfc_typename (op1), &op1->where);
as = NULL;
sym->ts = *ts;
sym->ts.type = BT_CLASS;
- attr = CLASS_DATA (sym)->attr;
+ attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
attr.class_ok = 0;
attr.associate_var = 1;
attr.dimension = attr.codimension = 0;
{
if (code->expr1->symtree->n.sym->attr.untyped)
code->expr1->symtree->n.sym->ts = code->expr2->ts;
- selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
+ selector_type = CLASS_DATA (code->expr2)
+ ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived;
}
if (code->expr2->rank && CLASS_DATA (code->expr1)->as)
case EXEC_GOTO:
if (code->expr1 != NULL)
{
- if (code->expr1->ts.type != BT_INTEGER)
- gfc_error ("ASSIGNED GOTO statement at %L requires an "
- "INTEGER variable", &code->expr1->where);
- else if (code->expr1->symtree->n.sym->attr.assign != 1)
+ if (code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->ts.type != BT_INTEGER
+ || (code->expr1->ref
+ && code->expr1->ref->type == REF_ARRAY)
+ || code->expr1->symtree == NULL
+ || (code->expr1->symtree->n.sym
+ && (code->expr1->symtree->n.sym->attr.flavor
+ == FL_PARAMETER)))
+ gfc_error ("ASSIGNED GOTO statement at %L requires a "
+ "scalar INTEGER variable", &code->expr1->where);
+ else if (code->expr1->symtree->n.sym
+ && code->expr1->symtree->n.sym->attr.assign != 1)
gfc_error ("Variable %qs has not been assigned a target "
"label at %L", code->expr1->symtree->n.sym->name,
&code->expr1->where);
|| code->expr1->symtree->n.sym->ts.type != BT_INTEGER
|| code->expr1->symtree->n.sym->ts.kind
!= gfc_default_integer_kind
+ || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER
|| code->expr1->symtree->n.sym->as != NULL))
gfc_error ("ASSIGN statement at %L requires a scalar "
"default INTEGER variable", &code->expr1->where);
if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS
&& sym->ts.u.derived && CLASS_DATA (sym)
&& CLASS_DATA (sym)->attr.codimension
+ && CLASS_DATA (sym)->ts.u.derived
&& (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp
|| CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp))
{
if (formal)
{
sym->formal_ns = formal->sym->ns;
- if (sym->ns != formal->sym->ns)
+ if (sym->formal_ns && sym->ns != formal->sym->ns)
sym->formal_ns->refs++;
}
}