+2014-12-11 Manuel López-Ibáñez <manu@gcc.gnu.org>
+
+ PR fortran/44054
+ * diagnostic.c (diagnostic_action_after_output): Make it extern.
+ Take diagnostic_t argument instead of diagnostic_info. Count also
+ DK_WERROR towards max_errors.
+ (diagnostic_report_diagnostic): Update call according to the above.
+ (error_recursion): Likewise.
+ * diagnostic.h (diagnostic_action_after_output): Declare.
+ * pretty-print.c (pp_formatted_text_data): Delete.
+ (pp_append_r): Call output_buffer_append_r.
+ (pp_formatted_text): Call output_buffer_formatted_text.
+ (pp_last_position_in_text): Call output_buffer_last_position_in_text.
+ * pretty-print.h (output_buffer_formatted_text): New.
+ (output_buffer_append_r): New.
+ (output_buffer_last_position_in_text): New.
+
2014-12-11 Kyrylo Tkachov kyrylo.tkachov@arm.com
* config/aarch64/aarch64.c (aarch64_parse_extension): Update error
/* Prototypes. */
static void error_recursion (diagnostic_context *) ATTRIBUTE_NORETURN;
-static void diagnostic_action_after_output (diagnostic_context *,
- diagnostic_info *);
static void real_abort (void) ATTRIBUTE_NORETURN;
/* Name of program invoked, sans directories. */
/* Take any action which is expected to happen after the diagnostic
is written out. This function does not always return. */
-static void
+void
diagnostic_action_after_output (diagnostic_context *context,
- diagnostic_info *diagnostic)
+ diagnostic_t diag_kind)
{
- switch (diagnostic->kind)
+ switch (diag_kind)
{
case DK_DEBUG:
case DK_NOTE:
}
if (context->max_errors != 0
&& ((unsigned) (diagnostic_kind_count (context, DK_ERROR)
- + diagnostic_kind_count (context, DK_SORRY))
+ + diagnostic_kind_count (context, DK_SORRY)
+ + diagnostic_kind_count (context, DK_WERROR))
>= context->max_errors))
{
fnotice (stderr,
(*diagnostic_starter (context)) (context, diagnostic);
pp_output_formatted_text (context->printer);
(*diagnostic_finalizer (context)) (context, diagnostic);
- diagnostic_action_after_output (context, diagnostic);
+ diagnostic_action_after_output (context, diagnostic->kind);
diagnostic->message.format_spec = saved_format_spec;
diagnostic->x_data = NULL;
static void
error_recursion (diagnostic_context *context)
{
- diagnostic_info diagnostic;
-
if (context->lock < 3)
pp_newline_and_flush (context->printer);
"Internal compiler error: Error reporting routines re-entered.\n");
/* Call diagnostic_action_after_output to get the "please submit a bug
- report" message. It only looks at the kind field of diagnostic_info. */
- diagnostic.kind = DK_ICE;
- diagnostic_action_after_output (context, &diagnostic);
+ report" message. */
+ diagnostic_action_after_output (context, DK_ICE);
/* Do not use gcc_unreachable here; that goes through internal_error
and therefore would cause infinite recursion. */
void default_diagnostic_starter (diagnostic_context *, diagnostic_info *);
void default_diagnostic_finalizer (diagnostic_context *, diagnostic_info *);
void diagnostic_set_caret_max_width (diagnostic_context *context, int value);
+void diagnostic_action_after_output (diagnostic_context *, diagnostic_t);
void diagnostic_file_cache_fini (void);
+2014-12-11 Manuel López-Ibáñez <manu@gcc.gnu.org>
+
+ PR fortran/44054
+ * error.c (pp_error_buffer): New static variable.
+ (pp_warning_buffer): Make it a pointer.
+ (gfc_output_buffer_empty_p): New.
+ (gfc_error_init_1): Call gfc_buffer_error.
+ (gfc_buffer_error): Do not use pp_warning_buffer.flush_p as the
+ buffered_p flag.
+ (gfc_clear_warning): Likewise.
+ (gfc_warning_check): Call gfc_clear_warning. Only check the new
+ pp_warning_buffer if the old warning_buffer was empty. Call
+ diagnostic_action_after_output.
+ (gfc_error_1): Renamed from gfc_error.
+ (gfc_error): New.
+ (gfc_clear_error): Clear also pp_error_buffer.
+ (gfc_error_flag_test): Check also pp_error_buffer.
+ (gfc_error_check): Likewise. Only check the new pp_error_buffer
+ if the old error_buffer was empty.
+ (gfc_move_output_buffer_from_to): New.
+ (gfc_push_error): Use it here. Take also an output_buffer as argument.
+ (gfc_pop_error): Likewise.
+ (gfc_free_error): Likewise.
+ (gfc_diagnostics_init): Use XNEW and placement-new to init
+ pp_error_buffer and pp_warning_buffer. Set flush_p to false for
+ both pp_warning_buffer and pp_error_buffer.
+
+ * Update gfc_push_error, gfc_pop_error and gfc_free_error calls
+ according to the above changes.
+ * Use gfc_error_1 for all gfc_error calls that use multiple
+ locations.
+ * Use %qs instead of '%s' for many gfc_error calls.
+
2014-12-11 Tobias Burnus <burnus@net-b.de>
Manuel López-Ibáñez <manu@gcc.gnu.org>
break;
case ARITH_OVERFLOW:
gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
- "can be disabled with the option -fno-range-check",
+ "can be disabled with the option %<-fno-range-check%>",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_UNDERFLOW:
gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
- "can be disabled with the option -fno-range-check",
+ "can be disabled with the option %<-fno-range-check%>",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_NAN:
gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
- "can be disabled with the option -fno-range-check",
+ "can be disabled with the option %<-fno-range-check%>",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_DIV0:
if (star)
{
- gfc_error ("Unexpected '*' in coarray subscript at %C");
+ gfc_error ("Unexpected %<*%> in coarray subscript at %C");
return MATCH_ERROR;
}
if (gfc_match_char (',') != MATCH_YES)
{
if (gfc_match_char ('*') == MATCH_YES)
- gfc_error ("Unexpected '*' for codimension %d of %d at %C",
+ gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
ar->codimen + 1, corank);
else
gfc_error ("Invalid form of coarray reference at %C");
}
else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR)
{
- gfc_error ("Unexpected '*' for codimension %d of %d at %C",
+ gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
ar->codimen + 1, corank);
return MATCH_ERROR;
}
if (check_constant && !gfc_is_constant_expr (e))
{
if (e->expr_type == EXPR_VARIABLE)
- gfc_error ("Variable '%s' at %L in this context must be constant",
+ gfc_error ("Variable %qs at %L in this context must be constant",
e->symtree->n.sym->name, &e->where);
else
gfc_error ("Expression at %L in this context must be constant",
if ((sym->as->type == AS_ASSUMED_RANK && as->corank)
|| (as->type == AS_ASSUMED_RANK && sym->as->corank))
{
- gfc_error ("The assumed-rank array '%s' at %L shall not have a "
+ gfc_error ("The assumed-rank array %qs at %L shall not have a "
"codimension", sym->name, error_loc);
return false;
}
if (c->iterator->var->symtree->n.sym == master)
{
- gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
+ gfc_error ("DO-iterator %qs at %L is inside iterator of the "
"same name", master->name, &c->where);
return 1;
{
gfc_error ("The number of elements in the array constructor "
"at %L requires an increase of the allowed %d "
- "upper limit. See -fmax-array-constructor "
+ "upper limit. See %<-fmax-array-constructor%> "
"option", &e->where,
gfc_option.flag_max_array_constructor);
return false;
if (e->rank == 0)
return true;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
if (e->ts.type == type)
return true;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where, gfc_basic_typename (type));
return true;
}
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a numeric type",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
{
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or REAL", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
{
if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
"or COMPLEX", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
{
if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
if (!gfc_check_init_expr (k))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&k->where);
return false;
if (d->ts.kind != gfc_default_double_kind)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be double "
"precision", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &d->where);
return false;
if (!gfc_is_coarray (e))
{
- gfc_error ("Expected coarray variable as '%s' argument to the %s "
+ gfc_error ("Expected coarray variable as %qs argument to the %s "
"intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
{
if (array->ts.type != BT_LOGICAL || array->rank == 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
"array", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &array->where);
return false;
if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
return true;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
gfc_extract_int (expr, &i);
if (i < 0)
{
- gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
+ gfc_error ("%qs at %L must be nonnegative", arg, &expr->where);
return false;
}
}
if (i2 > gfc_integer_kinds[i3].bit_size)
{
gfc_error ("The absolute value of SHIFT at %L must be less "
- "than or equal to BIT_SIZE('%s')",
+ "than or equal to BIT_SIZE(%qs)",
&expr2->where, arg1);
return false;
}
{
if (i2 > gfc_integer_kinds[i3].bit_size)
{
- gfc_error ("'%s' at %L must be less than "
- "or equal to BIT_SIZE('%s')",
+ gfc_error ("%qs at %L must be less than "
+ "or equal to BIT_SIZE(%qs)",
arg2, &expr2->where, arg1);
return false;
}
{
if (i2 >= gfc_integer_kinds[i3].bit_size)
{
- gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
+ gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
arg2, &expr2->where, arg1);
return false;
}
if (val > gfc_integer_kinds[i].bit_size)
{
- gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
+ gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
"INTEGER(KIND=%d)", arg, &expr->where, k);
return false;
}
if (i2 > gfc_integer_kinds[i3].bit_size)
{
gfc_error ("'%s + %s' at %L must be less than or equal "
- "to BIT_SIZE('%s')",
+ "to BIT_SIZE(%qs)",
arg2, arg3, &expr2->where, arg1);
return false;
}
if (gfc_compare_types (&e->ts, &f->ts))
return true;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
- "and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
+ gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
+ "and kind as %qs", gfc_current_intrinsic_arg[m]->name,
gfc_current_intrinsic, &f->where,
gfc_current_intrinsic_arg[n]->name);
if (e->rank == rank)
return true;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where, rank);
{
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
+ gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
}
attr = gfc_variable_attr (e, NULL);
if (!attr.allocatable || attr.associate_var)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
return false;
if (e->ts.kind == k)
return true;
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where, k);
if (!ref)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
+ gfc_error ("%qs argument of %qs intrinsic at %L cannot be "
"INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
return true;
}
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
return false;
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, corank) > 0)
{
- gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
+ gfc_error ("'dim' argument of %qs intrinsic at %L is not a valid "
"codimension index", gfc_current_intrinsic, &dim->where);
return false;
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, rank) > 0)
{
- gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
+ gfc_error ("'dim' argument of %qs intrinsic at %L is not a valid "
"dimension index", gfc_current_intrinsic, &dim->where);
return false;
if (a->ts.type != p->ts.type)
{
- gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
+ gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
"have the same type", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&p->where);
if (!attr1.pointer && !attr1.proc_pointer)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&pointer->where);
return false;
/* F2008, C1242. */
if (attr1.pointer && gfc_is_coindexed (pointer))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"coindexed", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &pointer->where);
return false;
attr2 = gfc_expr_attr (target);
else
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
"or target VARIABLE or FUNCTION",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&target->where);
if (attr1.pointer && !attr2.pointer && !attr2.target)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
"or a TARGET", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &target->where);
return false;
/* F2008, C1242. */
if (attr1.pointer && gfc_is_coindexed (target))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"coindexed", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &target->where);
return false;
null_arg:
gfc_error ("NULL pointer at %L is not permitted as actual argument "
- "of '%s' intrinsic function", where, gfc_current_intrinsic);
+ "of %qs intrinsic function", where, gfc_current_intrinsic);
return false;
}
if (atom->ts.type != value->ts.type)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall have the same "
+ gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall have the same "
"type as '%s' at %L", gfc_current_intrinsic_arg[val_no]->name,
gfc_current_intrinsic, &value->where,
gfc_current_intrinsic_arg[atom_no]->name, &atom->where);
if (x->ts.type == BT_COMPLEX)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
+ gfc_error ("%qs argument of %qs intrinsic at %L must not be "
"present if 'x' is COMPLEX",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
if (y->ts.type == BT_COMPLEX)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
+ gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
"of either REAL or INTEGER",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
if (!gfc_compare_types (&a->ts, &sym->result->ts))
{
- gfc_error ("A argument at %L has type %s but the function passed as "
+ gfc_error_1 ("A argument at %L has type %s but the function passed as "
"OPERATOR at %L returns %s",
&a->where, gfc_typename (&a->ts), &op->where,
gfc_typename (&sym->result->ts));
&& ((formal_size1 && actual_size != formal_size1)
|| (formal_size2 && actual_size != formal_size2)))
{
- gfc_error ("The character length of the A argument at %L and of the "
- "arguments of the OPERATOR at %L shall be the same",
+ gfc_error_1 ("The character length of the A argument at %L and of the "
+ "arguments of the OPERATOR at %L shall be the same",
&a->where, &op->where);
return false;
}
if (actual_size && result_size && actual_size != result_size)
{
- gfc_error ("The character length of the A argument at %L and of the "
- "function result of the OPERATOR at %L shall be the same",
- &a->where, &op->where);
+ gfc_error_1 ("The character length of the A argument at %L and of the "
+ "function result of the OPERATOR at %L shall be the same",
+ &a->where, &op->where);
return false;
}
}
if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL
&& a->ts.type != BT_CHARACTER)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall be of type "
- "integer, real or character",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &a->where);
+ gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall be of type "
+ "integer, real or character",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &a->where);
return false;
}
return check_co_collective (a, result_image, stat, errmsg, false);
{
if (!identical_dimen_shape (array, i, shift, j))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid shape in dimension %d (%ld/%ld)",
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, i + 1,
}
else
{
- gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+ gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
"%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, array->rank - 1);
return false;
if (x->ts.type == BT_COMPLEX)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
+ gfc_error ("%qs argument of %qs intrinsic at %L must not be "
"present if 'x' is COMPLEX",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
if (y->ts.type == BT_COMPLEX)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
+ gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
"of either REAL or INTEGER",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
break;
default:
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &vector_a->where);
return false;
if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
{
- gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
+ gfc_error ("Different shape for arguments %qs and %qs at %L for "
"intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, &vector_a->where);
return false;
if (x->ts.kind != gfc_default_real_kind)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be default "
"real", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &x->where);
return false;
if (y->ts.kind != gfc_default_real_kind)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be default "
"real", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &y->where);
return false;
if (i->is_boz && j->is_boz)
{
- gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
- "constants", &i->where, &j->where);
+ gfc_error_1 ("'I' at %L and 'J' at %L cannot both be BOZ literal "
+ "constants", &i->where, &j->where);
return false;
}
{
if (!identical_dimen_shape (array, i, shift, j))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid shape in dimension %d (%ld/%ld)",
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, i + 1,
}
else
{
- gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+ gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
"%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, array->rank - 1);
return false;
}
else
{
- gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
+ gfc_error ("%qs argument of intrinsic %qs at %L of must have "
"rank %d or be a scalar",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&shift->where, array->rank - 1);
if (string->ts.kind != substring->ts.kind)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
- "kind as '%s'", gfc_current_intrinsic_arg[1]->name,
+ gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
+ "kind as %qs", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &substring->where,
gfc_current_intrinsic_arg[0]->name);
return false;
if (i2 > i3)
{
- gfc_error ("The absolute value of SHIFT at %L must be less "
- "than or equal to SIZE at %L", &shift->where,
- &size->where);
+ gfc_error_1 ("The absolute value of SHIFT at %L must be less "
+ "than or equal to SIZE at %L", &shift->where,
+ &size->where);
return false;
}
}
{
if (x->ts.type == BT_DERIVED)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a "
"non-derived type", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &x->where);
return false;
if (args == NULL || args->next == NULL)
{
- gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
+ gfc_error ("Intrinsic %qs at %L must have at least two arguments",
gfc_current_intrinsic, gfc_current_intrinsic_where);
return false;
}
if (!a1 || !a2)
{
- gfc_error ("Missing '%s' argument to the %s intrinsic at %L",
+ gfc_error ("Missing %qs argument to the %s intrinsic at %L",
!a1 ? "a1" : "a2", gfc_current_intrinsic,
gfc_current_intrinsic_where);
return false;
return true;
duplicate:
- gfc_error ("Duplicate argument '%s' at %L to intrinsic %s", arg->name,
+ gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name,
&arg->expr->where, gfc_current_intrinsic);
return false;
unknown:
- gfc_error ("Unknown argument '%s' at %L to intrinsic %s", arg->name,
+ gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name,
&arg->expr->where, gfc_current_intrinsic);
return false;
}
}
else
{
- gfc_error ("'a%d' argument of '%s' intrinsic at %L must be "
+ gfc_error ("'a%d' argument of %qs intrinsic at %L must be "
"%s(%d)", n, gfc_current_intrinsic, &x->where,
gfc_basic_typename (type), kind);
return false;
}
else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
{
- gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
+ gfc_error ("'a1' argument of %qs intrinsic at %L must be INTEGER, "
"REAL or CHARACTER", gfc_current_intrinsic, &x->where);
return false;
}
{
if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &matrix_a->where);
return false;
if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &matrix_b->where);
return false;
if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
|| (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
{
- gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
+ gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
gfc_current_intrinsic, &matrix_a->where,
gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
return false;
/* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
{
- gfc_error ("Different shape on dimension 1 for arguments '%s' "
- "and '%s' at %L for intrinsic matmul",
+ gfc_error ("Different shape on dimension 1 for arguments %qs "
+ "and %qs at %L for intrinsic matmul",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
return false;
- matrix_a has shape (n,m) and matrix_b has shape (m). */
if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
{
- gfc_error ("Different shape on dimension 2 for argument '%s' and "
- "dimension 1 for argument '%s' at %L for intrinsic "
+ gfc_error ("Different shape on dimension 2 for argument %qs and "
+ "dimension 1 for argument %qs at %L for intrinsic "
"matmul", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
return false;
break;
default:
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
"1 or 2", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &matrix_a->where);
return false;
{
if (ap->expr->ts.type != BT_INTEGER)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &ap->expr->where);
return false;
if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
"ALLOCATABLE or procedure pointer",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &mold->where);
/* F2008, C1242. */
if (gfc_is_coindexed (mold))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"coindexed", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &mold->where);
return false;
if (mpz_get_si (vector_size) < mask_true_values)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+ gfc_error ("%qs argument of %qs intrinsic at %L must "
"provide at least as many elements as there "
- "are .TRUE. values in '%s' (%ld/%d)",
+ "are .TRUE. values in %qs (%ld/%d)",
gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic, &vector->where,
gfc_current_intrinsic_arg[1]->name,
sym = a->symtree->n.sym;
if (!sym->attr.dummy)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
"dummy variable", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where);
return false;
if (!sym->attr.optional)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of "
"an OPTIONAL dummy variable",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
|| (a->ref->u.ar.type == AR_ELEMENT
&& a->ref->u.ar.as->rank == 0))))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
- "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
+ gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
+ "subobject of %qs", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where, sym->name);
return false;
}
if (shape_size <= 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
+ gfc_error ("%qs argument of %qs intrinsic at %L is empty",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&shape->where);
return false;
gfc_extract_int (e, &extent);
if (extent < 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ gfc_error ("%qs argument of %qs intrinsic at %L has "
"negative element (%d)",
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &e->where, extent);
if (order_size != shape_size)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ gfc_error ("%qs argument of %qs intrinsic at %L "
"has wrong number of elements (%d/%d)",
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &order->where,
if (dim < 1 || dim > order_size)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ gfc_error ("%qs argument of %qs intrinsic at %L "
"has out-of-range dimension (%d)",
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &e->where, dim);
if (perm[dim-1] != 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+ gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid permutation of dimensions (dimension "
"'%d' duplicated)",
gfc_current_intrinsic_arg[3]->name,
{
if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ gfc_error ("%qs argument of %qs intrinsic at %L "
"cannot be of type %s",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic,
if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ gfc_error ("%qs argument of %qs intrinsic at %L "
"must be of an extensible type",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ gfc_error ("%qs argument of %qs intrinsic at %L "
"cannot be of type %s",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic,
if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L "
+ gfc_error ("%qs argument of %qs intrinsic at %L "
"must be of an extensible type",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&b->where);
{
if (arg->ts.type == BT_PROCEDURE)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure",
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
return false;
&& arg->symtree->n.sym->as->type != AS_DEFERRED
&& arg->symtree->n.sym->as->type != AS_ASSUMED_RANK)))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
return false;
&& arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
&& arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
"assumed-size array", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &arg->where);
return false;
if (!is_c_interoperable (arg, &msg, false, false))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be an "
"interoperable data entity: %s",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where, msg);
if (arg->ts.type == BT_ASSUMED)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"TYPE(*)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
&& arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
&& arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
"assumed-size array", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &arg->where);
return false;
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (x->symtree->n.sym == ns->proc_name)
{
- gfc_error ("Function result '%s' at %L is invalid as X argument "
+ gfc_error ("Function result %qs at %L is invalid as X argument "
"to C_FUNLOC", x->symtree->n.sym->name, &x->where);
return false;
}
{
if (source->rank >= GFC_MAX_DIMENSIONS)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be less "
"than rank %d", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
&& (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
+ gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
"dimension index", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &dim->where);
return false;
if (mpz_get_si (vector_size) < mask_true_count)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+ gfc_error ("%qs argument of %qs intrinsic at %L must "
"provide at least as many elements as there "
- "are .TRUE. values in '%s' (%ld/%d)",
+ "are .TRUE. values in %qs (%ld/%d)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&vector->where, gfc_current_intrinsic_arg[1]->name,
mpz_get_si (vector_size), mask_true_count);
if (mask->rank != field->rank && field->rank != 0)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
- "the same rank as '%s' or be a scalar",
+ gfc_error ("%qs argument of %qs intrinsic at %L must have "
+ "the same rank as %qs or be a scalar",
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
&field->where, gfc_current_intrinsic_arg[1]->name);
return false;
for (i = 0; i < field->rank; i++)
if (! identical_dimen_shape (mask, i, field, i))
{
- gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
+ gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
"must have identical shape.",
gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
if (gfc_array_size (put, &put_size)
&& mpz_get_ui (put_size) < kiss_size)
- gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+ gfc_error ("Size of %qs argument of %qs intrinsic at %L "
"too small (%i/%i)",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
where, (int) mpz_get_ui (put_size), kiss_size);
if (gfc_array_size (get, &get_size)
&& mpz_get_ui (get_size) < kiss_size)
- gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+ gfc_error ("Size of %qs argument of %qs intrinsic at %L "
"too small (%i/%i)",
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
where, (int) mpz_get_ui (get_size), kiss_size);
if (pos->ts.kind > gfc_default_integer_kind)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
"not wider than the default kind (%d)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&pos->where, gfc_default_integer_kind);
{
if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &i->where);
return false;
if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+ gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or LOGICAL", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &j->where);
return false;
if (i->ts.type != j->ts.type)
{
- gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
+ gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
"have the same type", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&j->where);
{
if (a->ts.type == BT_ASSUMED)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
return false;
if (a->ts.type == BT_PROCEDURE)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a "
+ gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
"procedure", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where);
return false;
if (kind->expr_type != EXPR_CONSTANT)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
+ gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&kind->where);
return false;
up to 255 extension levels. */
if (ts->u.derived->attr.extension == 255)
{
- gfc_error ("Maximum extension level reached with type '%s' at %L",
+ gfc_error ("Maximum extension level reached with type %qs at %L",
ts->u.derived->name, &ts->u.derived->declared_at);
return false;
}
&& res->n.tb->access == ACCESS_PRIVATE)
{
if (where)
- gfc_error ("'%s' of '%s' is PRIVATE at %L",
+ gfc_error ("%qs of %qs is PRIVATE at %L",
name, derived->name, where);
if (t)
*t = false;
&& res->access == ACCESS_PRIVATE)
{
if (where)
- gfc_error ("'%s' of '%s' is PRIVATE at %L",
+ gfc_error ("%qs of %qs is PRIVATE at %L",
gfc_op2string (op), derived->name, where);
if (t)
*t = false;
if (init && expr->expr_type != EXPR_ARRAY)
{
- gfc_error ("'%s' at %L already is initialized at %L",
- lvalue->symtree->n.sym->name, &lvalue->where,
- &init->where);
+ gfc_error_1 ("'%s' at %L already is initialized at %L",
+ lvalue->symtree->n.sym->name, &lvalue->where,
+ &init->where);
goto abort;
}
if (!sym->attr.function && gfc_current_ns->parent
&& gfc_current_ns->parent == sym->ns)
{
- gfc_error ("Host associated variable '%s' may not be in the DATA "
+ gfc_error ("Host associated variable %qs may not be in the DATA "
"statement at %C", sym->name);
return MATCH_ERROR;
}
|| (sym->attr.flavor != FL_PARAMETER
&& (!dt_sym || dt_sym->attr.flavor != FL_DERIVED)))
{
- gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
+ gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
name);
return MATCH_ERROR;
}
{
/* Make personalized messages to give better feedback. */
if (sym->ts.type == BT_DERIVED)
- gfc_error ("Variable '%s' at %L is a dummy argument to the "
- "BIND(C) procedure '%s' but is not C interoperable "
- "because derived type '%s' is not C interoperable",
+ gfc_error ("Variable %qs at %L is a dummy argument to the "
+ "BIND(C) procedure %qs but is not C interoperable "
+ "because derived type %qs is not C interoperable",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name,
sym->ts.u.derived->name);
else if (sym->ts.type == BT_CLASS)
- gfc_error ("Variable '%s' at %L is a dummy argument to the "
- "BIND(C) procedure '%s' but is not C interoperable "
+ gfc_error ("Variable %qs at %L is a dummy argument to the "
+ "BIND(C) procedure %qs but is not C interoperable "
"because it is polymorphic",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (cl->length->value.integer, 1) != 0)
{
- gfc_error ("Character argument '%s' at %L "
+ gfc_error ("Character argument %qs at %L "
"must be length 1 because "
- "procedure '%s' is BIND(C)",
+ "procedure %qs is BIND(C)",
sym->name, &sym->declared_at,
sym->ns->proc_name->name);
retval = false;
if ((sym->attr.allocatable || sym->attr.pointer) && !sym->as)
{
- gfc_error ("Scalar variable '%s' at %L with POINTER or "
- "ALLOCATABLE in procedure '%s' with BIND(C) is not yet"
+ gfc_error ("Scalar variable %qs at %L with POINTER or "
+ "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
" supported", sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
retval = false;
if (sym->attr.optional == 1 && sym->attr.value)
{
- gfc_error ("Variable '%s' at %L cannot have both the OPTIONAL "
- "and the VALUE attribute because procedure '%s' "
+ gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
+ "and the VALUE attribute because procedure %qs "
"is BIND(C)", sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
retval = false;
&& sym->value != NULL
&& *initp != NULL)
{
- gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
+ gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
sym->name);
return false;
}
initializer. */
if (sym->attr.data)
{
- gfc_error ("Variable '%s' at %C with an initializer already "
+ gfc_error ("Variable %qs at %C with an initializer already "
"appears in a DATA statement", sym->name);
return false;
}
&& strcmp (block->result->name, "ppr@") != 0
&& strcmp (block->name, name) == 0)
{
- gfc_error ("Function name '%s' not allowed at %C", name);
+ gfc_error ("Function name %qs not allowed at %C", name);
return false;
}
}
if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
{
m = MATCH_ERROR;
- gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
+ gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
name, &var_locus);
goto cleanup;
}
gfc_get_ha_symbol (name, &sym);
if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
{
- gfc_error ("Type name '%s' at %C is ambiguous", name);
+ gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym->generic && !dt_sym)
gfc_find_symbol (name, NULL, iface, &sym);
if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
{
- gfc_error ("Type name '%s' at %C is ambiguous", name);
+ gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym && sym->generic && !dt_sym)
&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
|| sym->attr.subroutine)
{
- gfc_error ("Type name '%s' at %C conflicts with previously declared "
- "entity at %L, which has the same name", name,
- &sym->declared_at);
+ gfc_error_1 ("Type name '%s' at %C conflicts with previously declared "
+ "entity at %L, which has the same name", name,
+ &sym->declared_at);
return MATCH_ERROR;
}
if (gfc_current_ns->parent != NULL
&& gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
{
- gfc_error ("Type name '%s' at %C is ambiguous", name);
+ gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL
gfc_current_ns->proc_name->ns->parent,
1, &sym))
{
- gfc_error ("Type name '%s' at %C is ambiguous", name);
+ gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym == NULL)
{
- gfc_error ("Cannot IMPORT '%s' from host scoping unit "
+ gfc_error ("Cannot IMPORT %qs from host scoping unit "
"at %C - does not exist.", name);
return MATCH_ERROR;
}
else
{
if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
- gfc_error ("Type declaration '%s' at %L is not C "
+ gfc_error ("Type declaration %qs at %L is not C "
"interoperable but it is BIND(C)",
tmp_sym->name, &(tmp_sym->declared_at));
else if (warn_c_binding_type)
gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
"may not be a C interoperable "
- "kind but it is bind(c)",
+ "kind but it is BIND(C)",
tmp_sym->name, &(tmp_sym->declared_at));
}
}
semantically no reason for the attribute. */
if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
{
- gfc_error ("Variable '%s' in common block '%s' at "
+ gfc_error ("Variable %qs in common block %qs at "
"%L cannot be declared with BIND(C) "
"since it is not a global",
tmp_sym->name, com_block->name,
{
if (tmp_sym->attr.pointer == 1)
{
- gfc_error ("Variable '%s' at %L cannot have both the "
+ gfc_error ("Variable %qs at %L cannot have both the "
"POINTER and BIND(C) attributes",
tmp_sym->name, &(tmp_sym->declared_at));
retval = false;
if (tmp_sym->attr.allocatable == 1)
{
- gfc_error ("Variable '%s' at %L cannot have both the "
+ gfc_error ("Variable %qs at %L cannot have both the "
"ALLOCATABLE and BIND(C) attributes",
tmp_sym->name, &(tmp_sym->declared_at));
retval = false;
scalar value. The previous tests in this function made sure
the type is interoperable. */
if (bind_c_function && tmp_sym->as != NULL)
- gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
+ gfc_error ("Return type of BIND(C) function %qs at %L cannot "
"be an array", tmp_sym->name, &(tmp_sym->declared_at));
/* BIND(C) functions can not return a character string. */
if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
|| tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
- gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
+ gfc_error ("Return type of BIND(C) function %qs at %L cannot "
"be a character string", tmp_sym->name,
&(tmp_sym->declared_at));
}
if (gfc_new_block != NULL && sym != NULL
&& strcmp (sym->name, gfc_new_block->name) == 0)
{
- gfc_error ("Name '%s' at %C is the name of the procedure",
+ gfc_error ("Name %qs at %C is the name of the procedure",
sym->name);
m = MATCH_ERROR;
goto cleanup;
for (q = p->next; q; q = q->next)
if (p->sym == q->sym)
{
- gfc_error ("Duplicate symbol '%s' in formal argument list "
+ gfc_error ("Duplicate symbol %qs in formal argument list "
"at %C", p->sym->name);
m = MATCH_ERROR;
{
if (sym->ts.type != BT_UNKNOWN)
{
- gfc_error ("Procedure '%s' at %L already has basic type of %s",
+ gfc_error ("Procedure %qs at %L already has basic type of %s",
sym->name, &gfc_current_locus,
gfc_basic_typename (sym->ts.type));
return MATCH_ERROR;
if (!block_name)
return MATCH_YES;
- gfc_error ("Expected block name of '%s' in %s statement at %L",
+ gfc_error ("Expected block name of %qs in %s statement at %L",
block_name, gfc_ascii_statement (*st), &old_loc);
return MATCH_ERROR;
if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
{
- gfc_error ("Expected label '%s' for %s statement at %C", block_name,
+ gfc_error ("Expected label %qs for %s statement at %C", block_name,
gfc_ascii_statement (*st));
goto cleanup;
}
else if (strcmp (block_name, "ppr@") == 0
&& strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
{
- gfc_error ("Expected label '%s' for %s statement at %C",
+ gfc_error ("Expected label %qs for %s statement at %C",
gfc_current_block ()->ns->proc_name->name,
gfc_ascii_statement (*st));
goto cleanup;
for variable in a BLOCK which is defined outside of the BLOCK. */
if (sym->ns != gfc_current_ns && sym->attr.codimension)
{
- gfc_error ("Specifying VOLATILE for coarray variable '%s' at "
+ gfc_error ("Specifying VOLATILE for coarray variable %qs at "
"%C, which is use-/host-associated", sym->name);
return MATCH_ERROR;
}
/* F08:C428. */
if (!extended)
{
- gfc_error ("Symbol '%s' at %C has not been previously defined", name);
+ gfc_error ("Symbol %qs at %C has not been previously defined", name);
return NULL;
}
if (extended->attr.flavor != FL_DERIVED)
{
- gfc_error ("'%s' in EXTENDS expression at %C is not a "
+ gfc_error ("%qs in EXTENDS expression at %C is not a "
"derived type", name);
return NULL;
}
if (extended->attr.is_bind_c)
{
- gfc_error ("'%s' cannot be extended at %C because it "
+ gfc_error ("%qs cannot be extended at %C because it "
"is BIND(C)", extended->name);
return NULL;
}
if (extended->attr.sequence)
{
- gfc_error ("'%s' cannot be extended at %C because it "
+ gfc_error ("%qs cannot be extended at %C because it "
"is a SEQUENCE type", extended->name);
return NULL;
}
/* Make sure the name is not the name of an intrinsic type. */
if (gfc_is_intrinsic_typename (name))
{
- gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
+ gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
"type", name);
return MATCH_ERROR;
}
if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
{
- gfc_error ("Derived type name '%s' at %C already has a basic type "
+ gfc_error ("Derived type name %qs at %C already has a basic type "
"of %s", gensym->name, gfc_typename (&gensym->ts));
return MATCH_ERROR;
}
if (sym && (sym->components != NULL || sym->attr.zero_comp))
{
- gfc_error ("Derived type definition of '%s' at %C has already been "
+ gfc_error ("Derived type definition of %qs at %C has already been "
"defined", sym->name);
return MATCH_ERROR;
}
{
/* Since the extension field is 8 bit wide, we can only have
up to 255 extension levels. */
- gfc_error ("Maximum extension level reached with type '%s' at %L",
+ gfc_error ("Maximum extension level reached with type %qs at %L",
extended->name, &extended->declared_at);
return MATCH_ERROR;
}
/* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
if (tb.deferred && !block->attr.abstract)
{
- gfc_error ("Type '%s' containing DEFERRED binding at %C "
+ gfc_error ("Type %qs containing DEFERRED binding at %C "
"is not ABSTRACT", block->name);
return MATCH_ERROR;
}
stree = gfc_find_symtree (ns->tb_sym_root, name);
if (stree && stree->n.tb)
{
- gfc_error ("There is already a procedure with binding name '%s' for "
- "the derived type '%s' at %C", name, block->name);
+ gfc_error ("There is already a procedure with binding name %qs for "
+ "the derived type %qs at %C", name, block->name);
return MATCH_ERROR;
}
{
gcc_assert (op_type == INTERFACE_GENERIC);
gfc_error ("There's already a non-generic procedure with binding name"
- " '%s' for the derived type '%s' at %C",
+ " %qs for the derived type %qs at %C",
bind_name, block->name);
goto error;
}
if (tb->access != tbattr.access)
{
gfc_error ("Binding at %C must have the same access as already"
- " defined binding '%s'", bind_name);
+ " defined binding %qs", bind_name);
goto error;
}
}
for (target = tb->u.generic; target; target = target->next)
if (target_st == target->specific_st)
{
- gfc_error ("'%s' already defined as specific binding for the"
- " generic '%s' at %C", name, bind_name);
+ gfc_error ("%qs already defined as specific binding for the"
+ " generic %qs at %C", name, bind_name);
goto error;
}
if (gfc_get_symbol (name, module_ns, &sym))
{
- gfc_error ("Unknown procedure name \"%s\" at %C", name);
+ gfc_error ("Unknown procedure name %qs at %C", name);
return MATCH_ERROR;
}
for (f = block->f2k_derived->finalizers; f; f = f->next)
if (f->proc_sym == sym)
{
- gfc_error ("'%s' at %C is already defined as FINAL procedure!",
+ gfc_error ("%qs at %C is already defined as FINAL procedure!",
name);
return MATCH_ERROR;
}
#include "diagnostic-color.h"
#include "tree-diagnostic.h" /* tree_diagnostics_defaults */
+#include <new> /* For placement-new */
+
static int suppress_errors = 0;
static bool warnings_not_errors = false;
/* True if the error/warnings should be buffered. */
static bool buffered_p;
-
/* These are always buffered buffers (.flush_p == false) to be used by
the pretty-printer. */
-static output_buffer pp_warning_buffer;
+static output_buffer *pp_error_buffer, *pp_warning_buffer;
static int warningcount_buffered, werrorcount_buffered;
-#include <new> /* For placement-new */
+/* Return true if there output_buffer is empty. */
+
+static bool
+gfc_output_buffer_empty_p (const output_buffer * buf)
+{
+ return output_buffer_last_position_in_text (buf) == NULL;
+}
/* Go one level deeper suppressing errors. */
gfc_buffer_error (bool flag)
{
buffered_p = flag;
- pp_warning_buffer.flush_p = !flag;
}
pretty_printer *pp = global_dc->printer;
output_buffer *tmp_buffer = pp->buffer;
- gfc_clear_pp_buffer (&pp_warning_buffer);
+ gfc_clear_pp_buffer (pp_warning_buffer);
if (buffered_p)
{
- pp->buffer = &pp_warning_buffer;
+ pp->buffer = pp_warning_buffer;
global_dc->fatal_errors = false;
/* To prevent -fmax-errors= triggering. */
--werrorcount;
{
warning_buffer.flag = 0;
- gfc_clear_pp_buffer (&pp_warning_buffer);
+ gfc_clear_pp_buffer (pp_warning_buffer);
warningcount_buffered = 0;
werrorcount_buffered = 0;
- pp_warning_buffer.flush_p = false;
}
warnings++;
if (warning_buffer.message != NULL)
fputs (warning_buffer.message, stderr);
- warning_buffer.flag = 0;
+ gfc_clear_warning ();
}
-
/* This is for the new diagnostics machinery. */
- pretty_printer *pp = global_dc->printer;
- output_buffer *tmp_buffer = pp->buffer;
- pp->buffer = &pp_warning_buffer;
- if (pp_last_position_in_text (pp) != NULL)
+ else if (! gfc_output_buffer_empty_p (pp_warning_buffer))
{
+ pretty_printer *pp = global_dc->printer;
+ output_buffer *tmp_buffer = pp->buffer;
+ pp->buffer = pp_warning_buffer;
pp_really_flush (pp);
- pp_warning_buffer.flush_p = true;
warningcount += warningcount_buffered;
werrorcount += werrorcount_buffered;
+ gcc_assert (warningcount_buffered + werrorcount_buffered == 1);
+ diagnostic_action_after_output (global_dc,
+ warningcount_buffered
+ ? DK_WARNING : DK_ERROR);
+ pp->buffer = tmp_buffer;
}
-
- pp->buffer = tmp_buffer;
}
/* Issue an error. */
+/* Use gfc_error instead, unless two locations are used in the same
+ warning or for scanner.c, if the location is not properly set up. */
void
-gfc_error (const char *gmsgid, ...)
+gfc_error_1 (const char *gmsgid, ...)
{
va_list argp;
}
}
+/* Issue an error. */
+/* This function uses the common diagnostics, but does not support
+ two locations; when being used in scanner.c, ensure that the location
+ is properly setup. Otherwise, use gfc_error_1. */
+
+void
+gfc_error (const char *gmsgid, ...)
+{
+ va_list argp;
+ va_start (argp, gmsgid);
+
+ if (warnings_not_errors)
+ {
+ gfc_warning (/*opt=*/0, gmsgid, argp);
+ va_end (argp);
+ return;
+ }
+
+ if (suppress_errors)
+ {
+ va_end (argp);
+ return;
+ }
+
+ diagnostic_info diagnostic;
+ bool fatal_errors = global_dc->fatal_errors;
+ pretty_printer *pp = global_dc->printer;
+ output_buffer *tmp_buffer = pp->buffer;
+
+ gfc_clear_pp_buffer (pp_error_buffer);
+
+ if (buffered_p)
+ {
+ pp->buffer = pp_error_buffer;
+ global_dc->fatal_errors = false;
+ /* To prevent -fmax-errors= triggering, we decrease it before
+ report_diagnostic increases it. */
+ --errorcount;
+ }
+
+ diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION, DK_ERROR);
+ report_diagnostic (&diagnostic);
+
+ if (buffered_p)
+ {
+ pp->buffer = tmp_buffer;
+ global_dc->fatal_errors = fatal_errors;
+ }
+
+ va_end (argp);
+}
+
+
/* Immediate error. */
/* Use gfc_error_now instead, unless two locations are used in the same
{
error_buffer.flag = 0;
warnings_not_errors = false;
+ gfc_clear_pp_buffer (pp_error_buffer);
}
bool
gfc_error_flag_test (void)
{
- return error_buffer.flag;
+ return error_buffer.flag
+ || !gfc_output_buffer_empty_p (pp_error_buffer);
}
if (error_buffer.message != NULL)
fputs (error_buffer.message, stderr);
error_buffer.flag = 0;
+ gfc_clear_pp_buffer (pp_error_buffer);
gfc_increment_error_count();
if (flag_fatal_errors)
exit (FATAL_EXIT_CODE);
}
+ /* This is for the new diagnostics machinery. */
+ else if (! gfc_output_buffer_empty_p (pp_error_buffer))
+ {
+ error_raised = true;
+ pretty_printer *pp = global_dc->printer;
+ output_buffer *tmp_buffer = pp->buffer;
+ pp->buffer = pp_error_buffer;
+ pp_really_flush (pp);
+ ++errorcount;
+ gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer));
+ diagnostic_action_after_output (global_dc, DK_ERROR);
+ pp->buffer = tmp_buffer;
+ }
return error_raised;
}
+/* Move the text buffered from FROM to TO, then clear
+ FROM. Independently if there was text in FROM, TO is also
+ cleared. */
+
+static void
+gfc_move_output_buffer_from_to (output_buffer *from, output_buffer *to)
+{
+ gfc_clear_pp_buffer (to);
+ /* We make sure this is always buffered. */
+ to->flush_p = false;
+
+ if (! gfc_output_buffer_empty_p (from))
+ {
+ const char *str = output_buffer_formatted_text (from);
+ output_buffer_append_r (to, str, strlen (str));
+ gfc_clear_pp_buffer (from);
+ }
+}
/* Save the existing error state. */
void
-gfc_push_error (gfc_error_buf *err)
+gfc_push_error (output_buffer *buffer_err, gfc_error_buf *err)
{
err->flag = error_buffer.flag;
if (error_buffer.flag)
err->message = xstrdup (error_buffer.message);
error_buffer.flag = 0;
+
+ /* This part uses the common diagnostics. */
+ gfc_move_output_buffer_from_to (pp_error_buffer, buffer_err);
}
/* Restore a previous pushed error state. */
void
-gfc_pop_error (gfc_error_buf *err)
+gfc_pop_error (output_buffer *buffer_err, gfc_error_buf *err)
{
error_buffer.flag = err->flag;
if (error_buffer.flag)
memcpy (error_buffer.message, err->message, len);
free (err->message);
}
+ /* This part uses the common diagnostics. */
+ gfc_move_output_buffer_from_to (buffer_err, pp_error_buffer);
}
/* Free a pushed error state, but keep the current error state. */
void
-gfc_free_error (gfc_error_buf *err)
+gfc_free_error (output_buffer *buffer_err, gfc_error_buf *err)
{
if (err->flag)
free (err->message);
+
+ gfc_clear_pp_buffer (buffer_err);
}
diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
diagnostic_format_decoder (global_dc) = gfc_format_decoder;
global_dc->caret_char = '^';
- new (&pp_warning_buffer) output_buffer ();
+ pp_warning_buffer = new (XNEW (output_buffer)) output_buffer ();
+ pp_warning_buffer->flush_p = false;
+ pp_error_buffer = new (XNEW (output_buffer)) output_buffer ();
+ pp_error_buffer->flush_p = false;
}
void
if (comp->attr.allocatable
&& ctor->expr->expr_type != EXPR_NULL)
{
- gfc_error("Invalid initialization expression for ALLOCATABLE "
- "component '%s' in structure constructor at %L",
- comp->name, &ctor->expr->where);
+ gfc_error ("Invalid initialization expression for ALLOCATABLE "
+ "component %qs in structure constructor at %L",
+ comp->name, &ctor->expr->where);
return false;
}
}
&& (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
|| ap->expr->symtree->n.sym->ts.deferred))
{
- gfc_error ("Assumed or deferred character length variable '%s' "
+ gfc_error ("Assumed or deferred character length variable %qs "
" in constant expression at %L",
ap->expr->symtree->n.sym->name,
&ap->expr->where);
if (functions[i] == NULL)
{
- gfc_error("transformational intrinsic '%s' at %L is not permitted "
- "in an initialization expression", name, &e->where);
+ gfc_error ("transformational intrinsic %qs at %L is not permitted "
+ "in an initialization expression", name, &e->where);
return MATCH_ERROR;
}
if (!gfc_is_intrinsic (sym, 0, e->where)
|| (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
{
- gfc_error ("Function '%s' in initialization expression at %L "
+ gfc_error ("Function %qs in initialization expression at %L "
"must be an intrinsic function",
e->symtree->n.sym->name, &e->where);
break;
&& (m = check_transformational (e)) == MATCH_NO
&& (m = check_elemental (e)) == MATCH_NO)
{
- gfc_error ("Intrinsic function '%s' at %L is not permitted "
+ gfc_error ("Intrinsic function %qs at %L is not permitted "
"in an initialization expression",
e->symtree->n.sym->name, &e->where);
m = MATCH_ERROR;
is invalid. */
if (!e->symtree->n.sym->value)
{
- gfc_error("PARAMETER '%s' is used at %L before its definition "
- "is complete", e->symtree->n.sym->name, &e->where);
+ gfc_error ("PARAMETER %qs is used at %L before its definition "
+ "is complete", e->symtree->n.sym->name, &e->where);
t = false;
}
else
switch (e->symtree->n.sym->as->type)
{
case AS_ASSUMED_SIZE:
- gfc_error ("Assumed size array '%s' at %L is not permitted "
+ gfc_error ("Assumed size array %qs at %L is not permitted "
"in an initialization expression",
e->symtree->n.sym->name, &e->where);
break;
case AS_ASSUMED_SHAPE:
- gfc_error ("Assumed shape array '%s' at %L is not permitted "
+ gfc_error ("Assumed shape array %qs at %L is not permitted "
"in an initialization expression",
e->symtree->n.sym->name, &e->where);
break;
case AS_DEFERRED:
- gfc_error ("Deferred array '%s' at %L is not permitted "
+ gfc_error ("Deferred array %qs at %L is not permitted "
"in an initialization expression",
e->symtree->n.sym->name, &e->where);
break;
case AS_EXPLICIT:
- gfc_error ("Array '%s' at %L is a variable, which does "
+ gfc_error ("Array %qs at %L is a variable, which does "
"not reduce to a constant expression",
e->symtree->n.sym->name, &e->where);
break;
}
}
else
- gfc_error ("Parameter '%s' at %L has not been declared or is "
+ gfc_error ("Parameter %qs at %L has not been declared or is "
"a variable, which does not reduce to a constant "
"expression", e->symtree->n.sym->name, &e->where);
if (f->attr.proc == PROC_ST_FUNCTION)
{
- gfc_error ("Specification function '%s' at %L cannot be a statement "
+ gfc_error ("Specification function %qs at %L cannot be a statement "
"function", f->name, &e->where);
return false;
}
if (f->attr.proc == PROC_INTERNAL)
{
- gfc_error ("Specification function '%s' at %L cannot be an internal "
+ gfc_error ("Specification function %qs at %L cannot be an internal "
"function", f->name, &e->where);
return false;
}
if (!f->attr.pure && !f->attr.elemental)
{
- gfc_error ("Specification function '%s' at %L must be PURE", f->name,
+ gfc_error ("Specification function %qs at %L must be PURE", f->name,
&e->where);
return false;
}
if (f->attr.recursive)
{
- gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
+ gfc_error ("Specification function %qs at %L cannot be RECURSIVE",
f->name, &e->where);
return false;
}
if (sym->attr.dummy && sym->ns == gfc_current_ns
&& sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
{
- gfc_error ("Dummy argument '%s' not allowed in expression at %L",
+ gfc_error ("Dummy argument %qs not allowed in expression at %L",
sym->name, &e->where);
break;
}
if (sym->attr.optional)
{
- gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
+ gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
sym->name, &e->where);
break;
}
if (sym->attr.intent == INTENT_OUT)
{
- gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
+ gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
sym->name, &e->where);
break;
}
break;
}
- gfc_error ("Variable '%s' cannot appear in the expression at %L",
+ gfc_error ("Variable %qs cannot appear in the expression at %L",
sym->name, &e->where);
/* Prevent a repetition of the error. */
e->error = 1;
&& !gfc_pure (e->symtree->n.sym)
&& (!comp || !comp->attr.pure))
{
- gfc_error ("Function '%s' at %L must be PURE",
+ gfc_error ("Function %qs at %L must be PURE",
e->symtree->n.sym->name, &e->where);
/* Prevent repeat error messages. */
e->symtree->n.sym->attr.pure = 1;
if (bad_proc)
{
- gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
+ gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where);
return false;
}
}
if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc
&& !lhs_attr.proc_pointer)
{
- gfc_error ("'%s' in the pointer assignment at %L cannot be an "
+ gfc_error ("%qs in the pointer assignment at %L cannot be an "
"l-value since it is a procedure",
lvalue->symtree->n.sym->name, &lvalue->where);
return false;
if (ref->u.ar.type != AR_SECTION)
{
- gfc_error ("Expected bounds specification for '%s' at %L",
+ gfc_error ("Expected bounds specification for %qs at %L",
lvalue->symtree->n.sym->name, &lvalue->where);
return false;
}
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (sym == ns->proc_name)
{
- gfc_error ("Function result '%s' is invalid as proc-target "
+ gfc_error ("Function result %qs is invalid as proc-target "
"in procedure pointer assignment at %L",
sym->name, &rvalue->where);
return false;
}
if (attr.abstract)
{
- gfc_error ("Abstract interface '%s' is invalid "
+ gfc_error ("Abstract interface %qs is invalid "
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
return false;
{
if (attr.proc == PROC_ST_FUNCTION)
{
- gfc_error ("Statement function '%s' is invalid "
+ gfc_error ("Statement function %qs is invalid "
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
return false;
if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name,
attr.subroutine) == 0)
{
- gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer "
+ gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
"assignment", rvalue->symtree->name, &rvalue->where);
return false;
}
/* Check for F08:C730. */
if (attr.elemental && !attr.intrinsic)
{
- gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
+ gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
return false;
if (s1->attr.if_source == IFSRC_UNKNOWN
&& gfc_explicit_interface_required (s2, err, sizeof(err)))
{
- gfc_error ("Explicit interface required for '%s' at %L: %s",
+ gfc_error ("Explicit interface required for %qs at %L: %s",
s1->name, &lvalue->where, err);
return false;
}
if (s2->attr.if_source == IFSRC_UNKNOWN
&& gfc_explicit_interface_required (s1, err, sizeof(err)))
{
- gfc_error ("Explicit interface required for '%s' at %L: %s",
+ gfc_error ("Explicit interface required for %qs at %L: %s",
s2->name, &rvalue->where, err);
return false;
}
if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN
&& !s2->attr.external && !s2->attr.subroutine && !s2->attr.function)
{
- gfc_error ("Procedure pointer target '%s' at %L must be either an "
+ gfc_error ("Procedure pointer target %qs at %L must be either an "
"intrinsic, host or use associated, referenced or have "
"the EXTERNAL attribute", s2->name, &rvalue->where);
return false;
if (!pointer && sym->attr.flavor == FL_PARAMETER)
{
if (context)
- gfc_error ("Named constant '%s' in variable definition context (%s)"
+ gfc_error ("Named constant %qs in variable definition context (%s)"
" at %L", sym->name, context, &e->where);
return false;
}
&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
{
if (context)
- gfc_error ("'%s' in variable definition context (%s) at %L is not"
+ gfc_error ("%qs in variable definition context (%s) at %L is not"
" a variable", sym->name, context, &e->where);
return false;
}
if (pointer && is_pointer)
{
if (context)
- gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
+ gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
" association context (%s) at %L",
sym->name, context, &e->where);
return false;
if (!pointer && !is_pointer && !sym->attr.pointer)
{
if (context)
- gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
+ gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
" definition context (%s) at %L",
sym->name, context, &e->where);
return false;
if (pointer && is_pointer)
{
if (context)
- gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
+ gfc_error ("Variable %qs is PROTECTED and can not appear in a"
" pointer association context (%s) at %L",
sym->name, context, &e->where);
return false;
if (!pointer && !is_pointer)
{
if (context)
- gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
+ gfc_error ("Variable %qs is PROTECTED and can not appear in a"
" variable definition context (%s) at %L",
sym->name, context, &e->where);
return false;
if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym))
{
if (context)
- gfc_error ("Variable '%s' can not appear in a variable definition"
+ gfc_error ("Variable %qs can not appear in a variable definition"
" context (%s) at %L in PURE procedure",
sym->name, context, &e->where);
return false;
if (context)
{
if (assoc->target->expr_type == EXPR_VARIABLE)
- gfc_error ("'%s' at %L associated to vector-indexed target can"
+ gfc_error ("%qs at %L associated to vector-indexed target can"
" not be used in a variable definition context (%s)",
name, &e->where, context);
else
- gfc_error ("'%s' at %L associated to expression can"
+ gfc_error ("%qs at %L associated to expression can"
" not be used in a variable definition context (%s)",
name, &e->where, context);
}
if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))
{
if (context)
- gfc_error ("Associate-name '%s' can not appear in a variable"
+ gfc_error_1 ("Associate-name '%s' can not appear in a variable"
" definition context (%s) at %L because its target"
" at %L can not, either",
name, context, &e->where,
void gfc_clear_warning (void);
void gfc_warning_check (void);
+void gfc_error_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
void gfc_error (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
void gfc_error_now_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
void gfc_error_now (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
#define gfc_syntax_error(ST) \
gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST));
-void gfc_push_error (gfc_error_buf *);
-void gfc_pop_error (gfc_error_buf *);
-void gfc_free_error (gfc_error_buf *);
+#include "pretty-print.h" /* For output_buffer. */
+void gfc_push_error (output_buffer *, gfc_error_buf *);
+void gfc_pop_error (output_buffer *, gfc_error_buf *);
+void gfc_free_error (output_buffer *, gfc_error_buf *);
void gfc_get_errors (int *, int *);
void gfc_errors_to_warnings (bool);
if (sym->attr.dummy)
{
- gfc_error ("Dummy procedure '%s' at %C cannot have a "
+ gfc_error ("Dummy procedure %qs at %C cannot have a "
"generic interface", sym->name);
return MATCH_ERROR;
}
&& p->sym->attr.flavor != FL_DERIVED)
{
if (p->sym->attr.external)
- gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
+ gfc_error ("Procedure %qs in %s at %L has no explicit interface",
p->sym->name, interface_name, &p->sym->declared_at);
else
- gfc_error ("Procedure '%s' in %s at %L is neither function nor "
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
"subroutine", p->sym->name, interface_name,
&p->sym->declared_at);
return 1;
generic_flag, 0, NULL, 0, NULL, NULL))
{
if (referenced)
- gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
+ gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L",
p->sym->name, q->sym->name, interface_name,
&p->where);
else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
&& (p->sym->attr.if_source != IFSRC_DECL
|| p->sym->attr.procedure))
{
- gfc_error ("'%s' at %L is not a module procedure",
+ gfc_error ("%qs at %L is not a module procedure",
p->sym->name, &p->where);
return;
}
if (rank2 == -1)
{
gfc_error ("The assumed-rank array at %L requires that the dummy argument"
- " '%s' has assumed-rank", where, name);
+ " %qs has assumed-rank", where, name);
}
else if (rank1 == 0)
{
- gfc_error ("Rank mismatch in argument '%s' at %L "
+ gfc_error ("Rank mismatch in argument %qs at %L "
"(scalar and rank-%d)", name, where, rank2);
}
else if (rank2 == 0)
{
- gfc_error ("Rank mismatch in argument '%s' at %L "
+ gfc_error ("Rank mismatch in argument %qs at %L "
"(rank-%d and scalar)", name, where, rank1);
}
else
{
- gfc_error ("Rank mismatch in argument '%s' at %L "
+ gfc_error ("Rank mismatch in argument %qs at %L "
"(rank-%d and rank-%d)", name, where, rank1, rank2);
}
}
sizeof(err), NULL, NULL))
{
if (where)
- gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
+ gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
formal->name, &actual->where, err);
return 0;
}
&& !gfc_is_simply_contiguous (actual, true))
{
if (where)
- gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
+ gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
"must be simply contiguous", formal->name, &actual->where);
return 0;
}
CLASS_DATA (actual)->ts.u.derived)))
{
if (where)
- gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
+ gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
formal->name, &actual->where, gfc_typename (&actual->ts),
gfc_typename (&formal->ts));
return 0;
{
if (where)
gfc_error ("Assumed-type actual argument at %L requires that dummy "
- "argument '%s' is of assumed type", &actual->where,
+ "argument %qs is of assumed type", &actual->where,
formal->name);
return 0;
}
if (actual->ts.type != BT_CLASS)
{
if (where)
- gfc_error ("Actual argument to '%s' at %L must be polymorphic",
+ gfc_error ("Actual argument to %qs at %L must be polymorphic",
formal->name, &actual->where);
return 0;
}
CLASS_DATA (formal)->ts.u.derived))
{
if (where)
- gfc_error ("Actual argument to '%s' at %L must have the same "
+ gfc_error ("Actual argument to %qs at %L must have the same "
"declared type", formal->name, &actual->where);
return 0;
}
||CLASS_DATA (formal)->attr.class_pointer))
{
if (where)
- gfc_error ("Actual argument to '%s' at %L must be unlimited "
+ gfc_error ("Actual argument to %qs at %L must be unlimited "
"polymorphic since the formal argument is a "
"pointer or allocatable unlimited polymorphic "
"entity [F2008: 12.5.2.5]", formal->name,
if (formal->attr.codimension && !gfc_is_coarray (actual))
{
if (where)
- gfc_error ("Actual argument to '%s' at %L must be a coarray",
+ gfc_error ("Actual argument to %qs at %L must be a coarray",
formal->name, &actual->where);
return 0;
}
&& actual->symtree->n.sym->as->corank != formal->as->corank))
{
if (where)
- gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
+ gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
formal->name, &actual->where, formal->as->corank,
last ? last->u.c.component->as->corank
: actual->symtree->n.sym->as->corank);
&& !gfc_is_simply_contiguous (actual, true))
{
if (where)
- gfc_error ("Actual argument to '%s' at %L must be simply "
+ gfc_error ("Actual argument to %qs at %L must be simply "
"contiguous", formal->name, &actual->where);
return 0;
}
{
if (where)
- gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
+ gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
"which is LOCK_TYPE or has a LOCK_TYPE component",
formal->name, &actual->where);
return 0;
|| formal->attr.contiguous))
{
if (where)
- gfc_error ("Dummy argument '%s' has to be a pointer, assumed-shape or "
+ gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
"assumed-rank array without CONTIGUOUS attribute - as actual"
" argument at %L is not simply contiguous and both are "
"ASYNCHRONOUS or VOLATILE", formal->name, &actual->where);
{
if (where)
gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
- "INTENT(OUT) dummy argument '%s'", &actual->where,
+ "INTENT(OUT) dummy argument %qs", &actual->where,
formal->name);
return 0;
}
if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
{
if (where)
- gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
+ gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
"at %L", formal->name, &actual->where);
return 0;
}
{
if (where)
gfc_error ("Element of assumed-shaped or pointer "
- "array passed to array dummy argument '%s' at %L",
+ "array passed to array dummy argument %qs at %L",
formal->name, &actual->where);
return 0;
}
if (where)
gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
"CHARACTER actual argument with array dummy argument "
- "'%s' at %L", formal->name, &actual->where);
+ "%qs at %L", formal->name, &actual->where);
return 0;
}
if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
{
gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
- "array dummy argument '%s' at %L",
+ "array dummy argument %qs at %L",
formal->name, &actual->where);
return 0;
}
if (f == NULL)
{
if (where)
- gfc_error ("Keyword argument '%s' at %L is not in "
+ gfc_error ("Keyword argument %qs at %L is not in "
"the procedure", a->name, &a->expr->where);
return 0;
}
if (new_arg[i] != NULL)
{
if (where)
- gfc_error ("Keyword argument '%s' at %L is already associated "
+ gfc_error ("Keyword argument %qs at %L is already associated "
"with another actual argument", a->name,
&a->expr->where);
return 0;
|| (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
|| (f->sym->ts.type == BT_CLASS
&& CLASS_DATA (f->sym)->attr.allocatable)))
- gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
+ gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
where, f->sym->name);
else if (where)
gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
- "dummy '%s'", where, f->sym->name);
+ "dummy %qs", where, f->sym->name);
return 0;
}
{
if (where)
gfc_error ("Actual argument at %L to allocatable or "
- "pointer dummy argument '%s' must have a deferred "
+ "pointer dummy argument %qs must have a deferred "
"length type parameter if and only if the dummy has one",
&a->expr->where, f->sym->name);
return 0;
|| gfc_is_proc_ptr_comp (a->expr)))
{
if (where)
- gfc_error ("Expected a procedure pointer for argument '%s' at %L",
+ gfc_error ("Expected a procedure pointer for argument %qs at %L",
f->sym->name, &a->expr->where);
return 0;
}
&& gfc_expr_attr (a->expr).flavor != FL_PROCEDURE)
{
if (where)
- gfc_error ("Expected a procedure for argument '%s' at %L",
+ gfc_error ("Expected a procedure for argument %qs at %L",
f->sym->name, &a->expr->where);
return 0;
}
&& a->expr->ref->u.ar.type == AR_FULL)))
{
if (where)
- gfc_error ("Actual argument for '%s' cannot be an assumed-size"
+ gfc_error ("Actual argument for %qs cannot be an assumed-size"
" array at %L", f->sym->name, where);
return 0;
}
&& compare_pointer (f->sym, a->expr) == 0)
{
if (where)
- gfc_error ("Actual argument for '%s' must be a pointer at %L",
+ gfc_error ("Actual argument for %qs must be a pointer at %L",
f->sym->name, &a->expr->where);
return 0;
}
{
if (where)
gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
- "pointer dummy '%s'", &a->expr->where,f->sym->name);
+ "pointer dummy %qs", &a->expr->where,f->sym->name);
return 0;
}
{
if (where)
gfc_error ("Coindexed actual argument at %L to pointer "
- "dummy '%s'",
+ "dummy %qs",
&a->expr->where, f->sym->name);
return 0;
}
{
if (where)
gfc_error ("Coindexed actual argument at %L to allocatable "
- "dummy '%s' requires INTENT(IN)",
+ "dummy %qs requires INTENT(IN)",
&a->expr->where, f->sym->name);
return 0;
}
{
if (where)
gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
- "%L requires that dummy '%s' has neither "
+ "%L requires that dummy %qs has neither "
"ASYNCHRONOUS nor VOLATILE", &a->expr->where,
f->sym->name);
return 0;
{
if (where)
gfc_error ("Coindexed actual argument at %L with allocatable "
- "ultimate component to dummy '%s' requires either VALUE "
+ "ultimate component to dummy %qs requires either VALUE "
"or INTENT(IN)", &a->expr->where, f->sym->name);
return 0;
}
&& !full_array)
{
if (where)
- gfc_error ("Actual CLASS array argument for '%s' must be a full "
+ gfc_error ("Actual CLASS array argument for %qs must be a full "
"array at %L", f->sym->name, &a->expr->where);
return 0;
}
&& compare_allocatable (f->sym, a->expr) == 0)
{
if (where)
- gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
+ gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
f->sym->name, &a->expr->where);
return 0;
}
gfc_error ("Array-section actual argument with vector "
"subscripts at %L is incompatible with INTENT(OUT), "
"INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
- "of the dummy argument '%s'",
+ "of the dummy argument %qs",
&a->expr->where, f->sym->name);
return 0;
}
if (where)
gfc_error ("Assumed-shape actual argument at %L is "
"incompatible with the non-assumed-shape "
- "dummy argument '%s' due to VOLATILE attribute",
+ "dummy argument %qs due to VOLATILE attribute",
&a->expr->where,f->sym->name);
return 0;
}
if (where)
gfc_error ("Array-section actual argument at %L is "
"incompatible with the non-assumed-shape "
- "dummy argument '%s' due to VOLATILE attribute",
+ "dummy argument %qs due to VOLATILE attribute",
&a->expr->where,f->sym->name);
return 0;
}
if (where)
gfc_error ("Pointer-array actual argument at %L requires "
"an assumed-shape or pointer-array dummy "
- "argument '%s' due to VOLATILE attribute",
+ "argument %qs due to VOLATILE attribute",
&a->expr->where,f->sym->name);
return 0;
}
if (!f->sym->attr.optional)
{
if (where)
- gfc_error ("Missing actual argument for argument '%s' at %L",
+ gfc_error ("Missing actual argument for argument %qs at %L",
f->sym->name, where);
return 0;
}
&& gfc_is_coindexed (expr))
{
gfc_error ("Coindexed polymorphic actual argument at %L is passed "
- "polymorphic dummy argument '%s'",
+ "polymorphic dummy argument %qs",
&expr->where, f->sym->name);
return false;
}
{
if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
{
- gfc_error ("Procedure '%s' called at %L is not explicitly declared",
+ gfc_error ("Procedure %qs called at %L is not explicitly declared",
sym->name, where);
return false;
}
if (sym->attr.pointer)
{
- gfc_error("The pointer object '%s' at %L must have an explicit "
- "function interface or be declared as array",
- sym->name, where);
+ gfc_error ("The pointer object %qs at %L must have an explicit "
+ "function interface or be declared as array",
+ sym->name, where);
return false;
}
if (sym->attr.allocatable && !sym->attr.external)
{
- gfc_error("The allocatable object '%s' at %L must have an explicit "
- "function interface or be declared as array",
- sym->name, where);
+ gfc_error ("The allocatable object %qs at %L must have an explicit "
+ "function interface or be declared as array",
+ sym->name, where);
return false;
}
if (sym->attr.allocatable)
{
- gfc_error("Allocatable function '%s' at %L must have an explicit "
- "function interface", sym->name, where);
+ gfc_error ("Allocatable function %qs at %L must have an explicit "
+ "function interface", sym->name, where);
return false;
}
/* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
if (a->name != NULL && a->name[0] != '%')
{
- gfc_error("Keyword argument requires explicit interface "
- "for procedure '%s' at %L", sym->name, &a->expr->where);
+ gfc_error ("Keyword argument requires explicit interface "
+ "for procedure %qs at %L", sym->name, &a->expr->where);
break;
}
&& a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
|| gfc_expr_attr (a->expr).lock_comp))
{
- gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
- "component at %L requires an explicit interface for "
- "procedure '%s'", &a->expr->where, sym->name);
+ gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
+ "component at %L requires an explicit interface for "
+ "procedure %qs", &a->expr->where, sym->name);
break;
}
/* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
if (a->name != NULL && a->name[0] != '%')
{
- gfc_error("Keyword argument requires explicit interface "
- "for procedure pointer component '%s' at %L",
- comp->name, &a->expr->where);
+ gfc_error ("Keyword argument requires explicit interface "
+ "for procedure pointer component %qs at %L",
+ comp->name, &a->expr->where);
break;
}
}
{
if (ip->sym == new_sym)
{
- gfc_error ("Entity '%s' at %L is already present in the interface",
+ gfc_error ("Entity %qs at %L is already present in the interface",
new_sym->name, &loc);
return false;
}
/* If the overwritten procedure is GENERIC, this is an error. */
if (old->n.tb->is_generic)
{
- gfc_error ("Can't overwrite GENERIC '%s' at %L",
+ gfc_error ("Can't overwrite GENERIC %qs at %L",
old->name, &proc->n.tb->where);
return false;
}
/* Check that overridden binding is not NON_OVERRIDABLE. */
if (old->n.tb->non_overridable)
{
- gfc_error ("'%s' at %L overrides a procedure binding declared"
+ gfc_error ("%qs at %L overrides a procedure binding declared"
" NON_OVERRIDABLE", proc->name, &where);
return false;
}
/* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
if (!old->n.tb->deferred && proc->n.tb->deferred)
{
- gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
+ gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
" non-DEFERRED binding", proc->name, &where);
return false;
}
/* If the overridden binding is PURE, the overriding must be, too. */
if (old_target->attr.pure && !proc_target->attr.pure)
{
- gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
+ gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
proc->name, &where);
return false;
}
is not, the overriding must not be either. */
if (old_target->attr.elemental && !proc_target->attr.elemental)
{
- gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
+ gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
" ELEMENTAL", proc->name, &where);
return false;
}
if (!old_target->attr.elemental && proc_target->attr.elemental)
{
- gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
+ gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
" be ELEMENTAL, either", proc->name, &where);
return false;
}
SUBROUTINE. */
if (old_target->attr.subroutine && !proc_target->attr.subroutine)
{
- gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
+ gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
" SUBROUTINE", proc->name, &where);
return false;
}
{
if (!proc_target->attr.function)
{
- gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
+ gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
" FUNCTION", proc->name, &where);
return false;
}
sizeof(err)))
{
gfc_error ("Result mismatch for the overriding procedure "
- "'%s' at %L: %s", proc->name, &where, err);
+ "%qs at %L: %s", proc->name, &where, err);
return false;
}
}
if (old->n.tb->access == ACCESS_PUBLIC
&& proc->n.tb->access == ACCESS_PRIVATE)
{
- gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
+ gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
" PRIVATE", proc->name, &where);
return false;
}
/* Check that the names correspond. */
if (strcmp (proc_formal->sym->name, old_formal->sym->name))
{
- gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
+ gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
" to match the corresponding argument of the overridden"
" procedure", proc_formal->sym->name, proc->name, &where,
old_formal->sym->name);
check_type, err, sizeof(err)))
{
gfc_error ("Argument mismatch for the overriding procedure "
- "'%s' at %L: %s", proc->name, &where, err);
+ "%qs at %L: %s", proc->name, &where, err);
return false;
}
}
if (proc_formal || old_formal)
{
- gfc_error ("'%s' at %L must have the same number of formal arguments as"
+ gfc_error ("%qs at %L must have the same number of formal arguments as"
" the overridden procedure", proc->name, &where);
return false;
}
NOPASS. */
if (old->n.tb->nopass && !proc->n.tb->nopass)
{
- gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
+ gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
" NOPASS", proc->name, &where);
return false;
}
{
if (proc->n.tb->nopass)
{
- gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
+ gfc_error ("%qs at %L overrides a binding with PASS and must also be"
" PASS", proc->name, &where);
return false;
}
if (proc_pass_arg != old_pass_arg)
{
- gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
+ gfc_error ("Passed-object dummy argument of %qs at %L must be at"
" the same position as the passed-object dummy argument of"
" the overridden procedure", proc->name, &where);
return false;
if (a == NULL)
goto do_sort;
- gfc_error ("Too many arguments in call to '%s' at %L", name, where);
+ gfc_error ("Too many arguments in call to %qs at %L", name, where);
return false;
keywords:
gfc_error ("The argument list functions %%VAL, %%LOC or %%REF "
"are not allowed in this context at %L", where);
else
- gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
+ gfc_error ("Can't find keyword named %qs in call to %qs at %L",
a->name, name, where);
return false;
}
if (f->actual != NULL)
{
- gfc_error ("Argument '%s' appears twice in call to '%s' at %L",
+ gfc_error ("Argument %qs appears twice in call to %qs at %L",
f->name, name, where);
return false;
}
{
if (f->actual == NULL && f->optional == 0)
{
- gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
+ gfc_error ("Missing actual argument %qs in call to %qs at %L",
f->name, name, where);
return false;
}
if (!gfc_compare_types (&ts, &actual->expr->ts))
{
if (error_flag)
- gfc_error ("Type of argument '%s' in call to '%s' at %L should "
+ gfc_error ("Type of argument %qs in call to %qs at %L should "
"be %s, not %s", gfc_current_intrinsic_arg[i]->name,
gfc_current_intrinsic, &actual->expr->where,
gfc_typename (&formal->ts),
if (gfc_do_concurrent_flag && !isym->pure)
{
- gfc_error ("Subroutine call to intrinsic '%s' in DO CONCURRENT "
+ gfc_error ("Subroutine call to intrinsic %qs in DO CONCURRENT "
"block at %L is not PURE", name, &c->loc);
return MATCH_ERROR;
}
if (!isym->pure && gfc_pure (NULL))
{
- gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
+ gfc_error ("Subroutine call to intrinsic %qs at %L is not PURE", name,
&c->loc);
return MATCH_ERROR;
}
/* The next 2 conditionals check C631. */
if (ts.type != BT_UNKNOWN)
{
- gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
+ gfc_error_1 ("SOURCE tag at %L conflicts with the typespec at %L",
&tmp->where, &old_locus);
goto cleanup;
}
/* Check F08:C637. */
if (ts.type != BT_UNKNOWN)
{
- gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
+ gfc_error_1 ("MOLD tag at %L conflicts with the typespec at %L",
&tmp->where, &old_locus);
goto cleanup;
}
/* Check F08:C637. */
if (source && mold)
{
- gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
+ gfc_error_1 ("MOLD tag at %L conflicts with SOURCE tag at %L",
&mold->where, &source->where);
goto cleanup;
}
if (sym->attr.in_common)
{
- gfc_error ("Symbol '%s' at %C is already in a COMMON block",
+ gfc_error ("Symbol %qs at %C is already in a COMMON block",
sym->name);
goto cleanup;
}
match
gfc_match_st_function (void)
{
- gfc_error_buf old_error;
+ gfc_error_buf old_error_1;
+ output_buffer old_error;
+
gfc_symbol *sym;
gfc_expr *expr;
match m;
if (m != MATCH_YES)
return m;
- gfc_push_error (&old_error);
+ gfc_push_error (&old_error, &old_error_1);
if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
goto undo_error;
if (m == MATCH_NO)
goto undo_error;
- gfc_free_error (&old_error);
+ gfc_free_error (&old_error, &old_error_1);
+
if (m == MATCH_ERROR)
return m;
return MATCH_YES;
undo_error:
- gfc_pop_error (&old_error);
+ gfc_pop_error (&old_error, &old_error_1);
return MATCH_NO;
}
{
bool bad = false;
if (n->sym->attr.threadprivate)
- gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
+ gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.cray_pointee)
- gfc_error ("Cray pointee '%s' in %s clause at %L",
+ gfc_error ("Cray pointee %qs in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.associate_var)
- gfc_error ("ASSOCIATE name '%s' in %s clause at %L",
+ gfc_error ("ASSOCIATE name %qs in %s clause at %L",
n->sym->name, name, where);
if (list != OMP_LIST_PRIVATE)
{
if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION)
- gfc_error ("Procedure pointer '%s' in %s clause at %L",
+ gfc_error ("Procedure pointer %qs in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
- gfc_error ("POINTER object '%s' in %s clause at %L",
+ gfc_error ("POINTER object %qs in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
- gfc_error ("Cray pointer '%s' in %s clause at %L",
+ gfc_error ("Cray pointer %qs in %s clause at %L",
n->sym->name, name, where);
}
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
- gfc_error ("Assumed size array '%s' in %s clause at %L",
+ gfc_error ("Assumed size array %qs in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
- gfc_error ("Variable '%s' in %s clause is used in "
+ gfc_error ("Variable %qs in %s clause is used in "
"NAMELIST statement at %L",
n->sym->name, name, where);
if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
case OMP_LIST_LASTPRIVATE:
case OMP_LIST_LINEAR:
/* case OMP_LIST_REDUCTION: */
- gfc_error ("INTENT(IN) POINTER '%s' in %s clause at %L",
+ gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
n->sym->name, name, where);
break;
default:
break;
case OMP_LIST_LINEAR:
if (n->sym->ts.type != BT_INTEGER)
- gfc_error ("LINEAR variable '%s' must be INTEGER "
+ gfc_error ("LINEAR variable %qs must be INTEGER "
"at %L", n->sym->name, where);
else if (!code && !n->sym->attr.value)
- gfc_error ("LINEAR dummy argument '%s' must have VALUE "
+ gfc_error ("LINEAR dummy argument %qs must have VALUE "
"attribute at %L", n->sym->name, where);
else if (n->expr)
{
if (!gfc_resolve_expr (expr)
|| expr->ts.type != BT_INTEGER
|| expr->rank != 0)
- gfc_error ("'%s' in LINEAR clause at %L requires "
+ gfc_error ("%qs in LINEAR clause at %L requires "
"a scalar integer linear-step expression",
n->sym->name, where);
else if (!code && expr->expr_type != EXPR_CONSTANT)
- gfc_error ("'%s' in LINEAR clause at %L requires "
+ gfc_error ("%qs in LINEAR clause at %L requires "
"a constant integer linear-step expression",
n->sym->name, where);
}
else if (expr_references_sym (arg->expr, var, NULL))
{
gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
- "not reference '%s' at %L",
+ "not reference %qs at %L",
var->name, &arg->expr->where);
return;
}
if (var_arg == NULL)
{
gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
- "be '%s' at %L", var->name, &expr2->where);
+ "be %qs at %L", var->name, &expr2->where);
return;
}
{
if (ods->proc_name != ns->proc_name)
gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
- "'%s' at %L", ns->proc_name->name, &ods->where);
+ "%qs at %L", ns->proc_name->name, &ods->where);
if (ods->clauses)
resolve_omp_clauses (NULL, &ods->where, ods->clauses, ns);
}
static void
use_modules (void)
{
- gfc_error_buf old_error;
+ gfc_error_buf old_error_1;
+ output_buffer old_error;
- gfc_push_error (&old_error);
+ gfc_push_error (&old_error, &old_error_1);
gfc_buffer_error (false);
gfc_use_modules ();
gfc_buffer_error (true);
- gfc_pop_error (&old_error);
+ gfc_pop_error (&old_error, &old_error_1);
gfc_commit_symbols ();
gfc_warning_check ();
gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
order:
if (!silent)
- gfc_error ("%s statement at %C cannot follow %s statement at %L",
+ gfc_error_1 ("%s statement at %C cannot follow %s statement at %L",
gfc_ascii_statement (st),
gfc_ascii_statement (p->last_statement), &p->where);
"subcomponent exists)", c->name, &c->loc, sym->name);
if (sym->attr.lock_comp && coarray && !lock_type)
- gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
+ gfc_error_1 ("Noncoarray component %s at %L of type LOCK_TYPE or with "
"subcomponent of type LOCK_TYPE must have a codimension or "
"be a subcomponent of a coarray. (Variables of type %s may "
"not have a codimension as %s at %L has a codimension or a "
case ST_ELSEIF:
if (seen_else)
{
- gfc_error ("ELSE IF statement at %C cannot follow ELSE "
+ gfc_error_1 ("ELSE IF statement at %C cannot follow ELSE "
"statement at %L", &else_locus);
reject_statement ();
}
if (sym->binding_label)
- gfc_error ("Global binding name '%s' at %L is already being used as a %s "
+ gfc_error_1 ("Global binding name '%s' at %L is already being used as a %s "
"at %L", sym->binding_label, where, name, &sym->where);
else
- gfc_error ("Global name '%s' at %L is already being used as a %s at %L",
+ gfc_error_1 ("Global name '%s' at %L is already being used as a %s at %L",
sym->name, where, name, &sym->where);
}
match_complex_constant (gfc_expr **result)
{
gfc_expr *e, *real, *imag;
- gfc_error_buf old_error;
+ gfc_error_buf old_error_1;
+ output_buffer old_error;
gfc_typespec target;
locus old_loc;
int kind;
if (m != MATCH_YES)
return m;
- gfc_push_error (&old_error);
+ gfc_push_error (&old_error, &old_error_1);
m = match_complex_part (&real);
if (m == MATCH_NO)
{
- gfc_free_error (&old_error);
+ gfc_free_error (&old_error, &old_error_1);
goto cleanup;
}
if (gfc_match_char (',') == MATCH_NO)
{
- gfc_pop_error (&old_error);
+ gfc_pop_error (&old_error, &old_error_1);
m = MATCH_NO;
goto cleanup;
}
if (m == MATCH_ERROR)
{
- gfc_free_error (&old_error);
+ gfc_free_error (&old_error, &old_error_1);
goto cleanup;
}
- gfc_pop_error (&old_error);
+ gfc_pop_error (&old_error, &old_error_1);
m = match_complex_part (&imag);
if (m == MATCH_NO)
gcc_assert (comp_iter);
if (!strcmp (comp_iter->name, comp_tail->name))
{
- gfc_error ("Component '%s' is initialized twice in the structure"
+ gfc_error ("Component %qs is initialized twice in the structure"
" constructor at %L!", comp_tail->name,
comp_tail->val ? &comp_tail->where
: &gfc_current_locus);
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
&& CLASS_DATA (sym)->attr.class_pointer))
{
- gfc_error ("Argument '%s' of elemental procedure at %L cannot "
+ gfc_error ("Argument %qs of elemental procedure at %L cannot "
"have the POINTER attribute", sym->name,
&sym->declared_at);
continue;
if (sym->attr.flavor == FL_PROCEDURE)
{
- gfc_error ("Dummy procedure '%s' not allowed in elemental "
- "procedure '%s' at %L", sym->name, proc->name,
+ gfc_error ("Dummy procedure %qs not allowed in elemental "
+ "procedure %qs at %L", sym->name, proc->name,
&sym->declared_at);
continue;
}
/* Fortran 2008 Corrigendum 1, C1290a. */
if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
{
- gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
+ gfc_error ("Argument %qs of elemental procedure %qs at %L must "
"have its INTENT specified or have the VALUE "
"attribute", sym->name, proc->name,
&sym->declared_at);
{
if (sym->as != NULL)
{
- gfc_error ("Argument '%s' of statement function at %L must "
+ gfc_error ("Argument %qs of statement function at %L must "
"be scalar", sym->name, &sym->declared_at);
continue;
}
gfc_charlen *cl = sym->ts.u.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
{
- gfc_error ("Character-valued argument '%s' of statement "
+ gfc_error ("Character-valued argument %qs of statement "
"function at %L must have constant length",
sym->name, &sym->declared_at);
continue;
if (!t && !sym->result->attr.untyped)
{
if (sym->result == sym)
- gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
+ gfc_error ("Contained function %qs at %L has no IMPLICIT type",
sym->name, &sym->declared_at);
else if (!sym->result->attr.proc_pointer)
- gfc_error ("Result '%s' of contained function '%s' at %L has "
+ gfc_error ("Result %qs of contained function %qs at %L has "
"no IMPLICIT type", sym->result->name, sym->name,
&sym->result->declared_at);
sym->result->attr.untyped = 1;
gcc_assert (ns->parent && ns->parent->proc_name);
module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
- gfc_error ("Character-valued %s '%s' at %L must not be"
+ gfc_error ("Character-valued %s %qs at %L must not be"
" assumed length",
module_proc ? _("module procedure")
: _("internal function"),
|| (!common_root->n.common->binding_label
&& gsym->binding_label)))
{
- gfc_error ("In Fortran 2003 COMMON '%s' block at %L is a global "
+ gfc_error_1 ("In Fortran 2003 COMMON '%s' block at %L is a global "
"identifier and must thus have the same binding name "
"as the same-named COMMON block at %L: %s vs %s",
common_root->n.common->name, &common_root->n.common->where,
if (gsym && gsym->type != GSYM_COMMON
&& !common_root->n.common->binding_label)
{
- gfc_error ("COMMON block '%s' at %L uses the same global identifier "
+ gfc_error_1 ("COMMON block '%s' at %L uses the same global identifier "
"as entity at %L",
common_root->n.common->name, &common_root->n.common->where,
&gsym->where);
}
if (gsym && gsym->type != GSYM_COMMON)
{
- gfc_error ("Fortran 2008: COMMON block '%s' with binding label at "
+ gfc_error_1 ("Fortran 2008: COMMON block '%s' with binding label at "
"%L sharing the identifier with global non-COMMON-block "
"entity at %L", common_root->n.common->name,
&common_root->n.common->where, &gsym->where);
common_root->n.common->binding_label);
if (gsym && gsym->type != GSYM_COMMON)
{
- gfc_error ("COMMON block at %L with binding label %s uses the same "
+ gfc_error_1 ("COMMON block at %L with binding label %s uses the same "
"global identifier as entity at %L",
&common_root->n.common->where,
common_root->n.common->binding_label, &gsym->where);
return;
if (sym->attr.flavor == FL_PARAMETER)
- gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
+ gfc_error_1 ("COMMON block '%s' at %L is used as PARAMETER at %L",
sym->name, &common_root->n.common->where, &sym->declared_at);
if (sym->attr.external)
- gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
+ gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
sym->name, &common_root->n.common->where);
if (sym->attr.intrinsic)
- gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
+ gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
sym->name, &common_root->n.common->where);
else if (sym->attr.result
|| gfc_is_function_return_value (sym, gfc_current_ns))
else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
{
gfc_error ("The element in the structure constructor at %L, "
- "for pointer component '%s', is %s but should be %s",
+ "for pointer component %qs, is %s but should be %s",
&cons->expr->where, comp->name,
gfc_basic_typename (cons->expr->ts.type),
gfc_basic_typename (comp->ts.type));
{
t = false;
gfc_error ("The NULL in the structure constructor at %L is "
- "being applied to component '%s', which is neither "
+ "being applied to component %qs, which is neither "
"a POINTER nor ALLOCATABLE", &cons->expr->where,
comp->name);
}
err, sizeof (err), NULL, NULL))
{
gfc_error ("Interface mismatch for procedure-pointer component "
- "'%s' in structure constructor at %L: %s",
+ "%qs in structure constructor at %L: %s",
comp->name, &cons->expr->where, err);
return false;
}
{
t = false;
gfc_error ("The element in the structure constructor at %L, "
- "for pointer component '%s' should be a POINTER or "
+ "for pointer component %qs should be a POINTER or "
"a TARGET", &cons->expr->where, comp->name);
}
{
t = false;
gfc_error ("Invalid expression in the structure constructor for "
- "pointer component '%s' at %L in PURE procedure",
+ "pointer component %qs at %L in PURE procedure",
comp->name, &cons->expr->where);
}
{
gfc_error ("The upper bound in the last dimension must "
"appear in the reference to the assumed size "
- "array '%s' at %L", sym->name, &e->where);
+ "array %qs at %L", sym->name, &e->where);
return true;
}
return false;
}
if (n > 1)
- gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
+ gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
&e->where);
if (n == 0)
- gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
+ gfc_error ("GENERIC procedure %qs is not allowed as an actual "
"argument at %L", sym->name, &e->where);
return n;
{
if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
{
- gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
+ gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
" specifier", sym->name, &sym->declared_at);
return false;
}
}
else
{
- gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
+ gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
&sym->declared_at);
return false;
}
/* Check it is actually available in the standard settings. */
if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
{
- gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
+ gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not"
" available in the current standard settings but %s. Use"
" an appropriate -std=* option or enable -fall-intrinsics"
" in order to use it.",
if (sym->attr.proc == PROC_ST_FUNCTION)
{
- gfc_error ("Statement function '%s' at %L is not allowed as an "
+ gfc_error ("Statement function %qs at %L is not allowed as an "
"actual argument", sym->name, &e->where);
}
sym->attr.subroutine);
if (sym->attr.intrinsic && actual_ok == 0)
{
- gfc_error ("Intrinsic '%s' at %L is not allowed as an "
+ gfc_error ("Intrinsic %qs at %L is not allowed as an "
"actual argument", sym->name, &e->where);
}
if (sym->attr.elemental && !sym->attr.intrinsic)
{
- gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
+ gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
"allowed as an actual argument at %L", sym->name,
&e->where);
}
if (isym == NULL || !isym->specific)
{
gfc_error ("Unable to find a specific INTRINSIC procedure "
- "for the reference '%s' at %L", sym->name,
+ "for the reference %qs at %L", sym->name,
&e->where);
goto cleanup;
}
if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
{
- gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
+ gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
goto cleanup;
}
|| eformal->sym->attr.intent == INTENT_INOUT)
&& arg->expr && arg->expr->rank == 0)
{
- gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
- "ELEMENTAL subroutine '%s' is a scalar, but another "
+ gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
+ "ELEMENTAL subroutine %qs is a scalar, but another "
"actual argument is an array", &arg->expr->where,
(eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
: "INOUT", eformal->sym->name, esym->name);
if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
{
- gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
+ gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
sym->name, &sym->declared_at, gfc_typename (&sym->ts),
gfc_typename (&def_sym->ts));
goto done;
if (sym->attr.if_source == IFSRC_UNKNOWN
&& gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
{
- gfc_error ("Explicit interface required for '%s' at %L: %s",
+ gfc_error ("Explicit interface required for %qs at %L: %s",
sym->name, &sym->declared_at, reason);
goto done;
}
if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
reason, sizeof(reason), NULL, NULL))
{
- gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ",
+ gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
sym->name, &sym->declared_at, reason);
goto done;
}
that possesses a matching interface. 14.1.2.4 */
if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
{
- gfc_error ("There is no specific function for the generic '%s' "
+ gfc_error ("There is no specific function for the generic %qs "
"at %L", expr->symtree->n.sym->name, &expr->where);
return false;
}
return true;
if (m == MATCH_NO)
- gfc_error ("Generic function '%s' at %L is not consistent with a "
+ gfc_error ("Generic function %qs at %L is not consistent with a "
"specific intrinsic interface", expr->symtree->n.sym->name,
&expr->where);
if (m == MATCH_YES)
return MATCH_YES;
if (m == MATCH_NO)
- gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
+ gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
"with an intrinsic", sym->name, &expr->where);
return MATCH_ERROR;
break;
}
- gfc_error ("Unable to resolve the specific function '%s' at %L",
+ gfc_error ("Unable to resolve the specific function %qs at %L",
expr->symtree->n.sym->name, &expr->where);
return true;
if (ts->type == BT_UNKNOWN)
{
- gfc_error ("Function '%s' at %L has no IMPLICIT type",
+ gfc_error ("Function %qs at %L has no IMPLICIT type",
sym->name, &expr->where);
return false;
}
if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
{
- gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
+ gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
return false;
}
of course be referenced), expr->value.function.esym will be set. */
if (sym && sym->attr.abstract && !expr->value.function.esym)
{
- gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
+ gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
sym->name, &expr->where);
return false;
}
&& !sym->attr.contained)
{
/* Internal procedures are taken care of in resolve_contained_fntype. */
- gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
+ gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
"be used at %L since it is not a dummy argument",
sym->name, &expr->where);
return false;
&& expr->value.function.esym
&& ! gfc_elemental (expr->value.function.esym))
{
- gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
+ gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
"in WORKSHARE construct", expr->value.function.esym->name,
&expr->where);
t = false;
{
if (forall_flag)
{
- gfc_error ("Reference to non-PURE function '%s' at %L inside a "
+ gfc_error ("Reference to non-PURE function %qs at %L inside a "
"FORALL %s", name, &expr->where,
forall_flag == 2 ? "mask" : "block");
t = false;
}
else if (gfc_do_concurrent_flag)
{
- gfc_error ("Reference to non-PURE function '%s' at %L inside a "
+ gfc_error ("Reference to non-PURE function %qs at %L inside a "
"DO CONCURRENT %s", name, &expr->where,
gfc_do_concurrent_flag == 2 ? "mask" : "block");
t = false;
}
else if (gfc_pure (NULL))
{
- gfc_error ("Function reference to '%s' at %L is to a non-PURE "
+ gfc_error ("Function reference to %qs at %L is to a non-PURE "
"procedure within a PURE procedure", name, &expr->where);
t = false;
}
if (is_illegal_recursion (esym, gfc_current_ns))
{
if (esym->attr.entry && esym->ns->entries)
- gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
- " function '%s' is not RECURSIVE",
+ gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
+ " function %qs is not RECURSIVE",
esym->name, &expr->where, esym->ns->entries->sym->name);
else
- gfc_error ("Function '%s' at %L cannot be called recursively, as it"
+ gfc_error ("Function %qs at %L cannot be called recursively, as it"
" is not RECURSIVE", esym->name, &expr->where);
t = false;
return;
if (forall_flag)
- gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
+ gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
sym->name, &c->loc);
else if (gfc_do_concurrent_flag)
- gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
+ gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
"PURE", sym->name, &c->loc);
else if (gfc_pure (NULL))
- gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
+ gfc_error ("Subroutine call to %qs at %L is not PURE", sym->name,
&c->loc);
gfc_unset_implicit_pure (NULL);
if (!gfc_is_intrinsic (sym, 1, c->loc))
{
- gfc_error ("There is no specific subroutine for the generic '%s' at %L",
+ gfc_error ("There is no specific subroutine for the generic %qs at %L",
sym->name, &c->loc);
return false;
}
if (m == MATCH_YES)
return true;
if (m == MATCH_NO)
- gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
+ gfc_error ("Generic subroutine %qs at %L is not consistent with an "
"intrinsic subroutine interface", sym->name, &c->loc);
return false;
if (m == MATCH_YES)
return MATCH_YES;
if (m == MATCH_NO)
- gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
+ gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
"with an intrinsic", sym->name, &c->loc);
return MATCH_ERROR;
}
sym = c->symtree->n.sym;
- gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
+ gfc_error ("Unable to resolve the specific subroutine %qs at %L",
sym->name, &c->loc);
return false;
if (csym && csym->ts.type != BT_UNKNOWN)
{
- gfc_error ("'%s' at %L has a type, which is not consistent with "
+ gfc_error_1 ("'%s' at %L has a type, which is not consistent with "
"the CALL at %L", csym->name, &csym->declared_at, &c->loc);
return false;
}
{
if (csym->attr.abstract)
{
- gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
+ gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
csym->name, &c->loc);
return false;
}
if (is_illegal_recursion (csym, gfc_current_ns))
{
if (csym->attr.entry && csym->ns->entries)
- gfc_error ("ENTRY '%s' at %L cannot be called recursively, "
- "as subroutine '%s' is not RECURSIVE",
+ gfc_error ("ENTRY %qs at %L cannot be called recursively, "
+ "as subroutine %qs is not RECURSIVE",
csym->name, &c->loc, csym->ns->entries->sym->name);
else
- gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, "
+ gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
"as it is not RECURSIVE", csym->name, &c->loc);
t = false;
{
if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
{
- gfc_error ("Shapes for operands at %L and %L are not conformable",
+ gfc_error_1 ("Shapes for operands at %L and %L are not conformable",
&op1->where, &op2->where);
t = false;
break;
if (mpz_cmp (e1->shape[i], s) != 0)
{
- gfc_error ("Source-expr at %L and allocate-object at %L must "
+ gfc_error_1 ("Source-expr at %L and allocate-object at %L must "
"have the same shape", &e1->where, &e2->where);
mpz_clear (s);
return false;
/* Check F03:C631. */
if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
{
- gfc_error ("Type of entity at %L is type incompatible with "
- "source-expr at %L", &e->where, &code->expr3->where);
+ gfc_error_1 ("Type of entity at %L is type incompatible with "
+ "source-expr at %L", &e->where, &code->expr3->where);
goto failure;
}
/* Check F03:C633. */
if (code->expr3->ts.kind != e->ts.kind && !unlimited)
{
- gfc_error ("The allocate-object at %L and the source-expr at %L "
+ gfc_error_1 ("The allocate-object at %L and the source-expr at %L "
"shall have the same kind type parameter",
&e->where, &code->expr3->where);
goto failure;
&& code->expr3->ts.u.derived->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE)))
{
- gfc_error ("The source-expr at %L shall neither be of type "
+ gfc_error_1 ("The source-expr at %L shall neither be of type "
"LOCK_TYPE nor have a LOCK_TYPE component if "
"allocate-object at %L is a coarray",
&code->expr3->where, &e->where);
{
if (pr == NULL && qr == NULL)
{
- gfc_error ("Allocate-object at %L also appears at %L",
- &pe->where, &qe->where);
+ gfc_error_1 ("Allocate-object at %L also appears at %L",
+ &pe->where, &qe->where);
break;
}
else if (pr != NULL && qr == NULL)
{
- gfc_error ("Allocate-object at %L is subobject of"
- " object at %L", &pe->where, &qe->where);
+ gfc_error_1 ("Allocate-object at %L is subobject of"
+ " object at %L", &pe->where, &qe->where);
break;
}
else if (pr == NULL && qr != NULL)
{
- gfc_error ("Allocate-object at %L is subobject of"
- " object at %L", &qe->where, &pe->where);
+ gfc_error_1 ("Allocate-object at %L is subobject of"
+ " object at %L", &qe->where, &pe->where);
break;
}
/* Here, pr != NULL && qr != NULL */
element in the list. Either way, we must
issue an error and get the next case from P. */
/* FIXME: Sort P and Q by line number. */
- gfc_error ("CASE label at %L overlaps with CASE "
+ gfc_error_1 ("CASE label at %L overlaps with CASE "
"label at %L", &p->where, &q->where);
overlap_seen = 1;
e = p;
{
if (default_case != NULL)
{
- gfc_error ("The DEFAULT CASE at %L cannot be followed "
+ gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
"by a second DEFAULT CASE at %L",
&default_case->where, &cp->where);
t = false;
/* Check F03:C818. */
if (default_case)
{
- gfc_error ("The DEFAULT CASE at %L cannot be followed "
+ gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
"by a second DEFAULT CASE at %L",
&default_case->ext.block.case_list->where, &c->where);
error++;
if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
{
- gfc_error ("Statement at %L is not a valid branch target statement "
+ gfc_error_1 ("Statement at %L is not a valid branch target statement "
"for the branch statement at %L", &label->where, &code->loc);
return;
}
{
if (stack->current->op == EXEC_CRITICAL
&& bitmap_bit_p (stack->reachable_labels, label->value))
- gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
+ gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for "
"label at %L", &code->loc, &label->where);
else if (stack->current->op == EXEC_DO_CONCURRENT
&& bitmap_bit_p (stack->reachable_labels, label->value))
- gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
+ gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct "
"for label at %L", &code->loc, &label->where);
}
{
/* Note: A label at END CRITICAL does not leave the CRITICAL
construct as END CRITICAL is still part of it. */
- gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
+ gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for label"
" at %L", &code->loc, &label->where);
return;
}
else if (stack->current->op == EXEC_DO_CONCURRENT)
{
- gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
+ gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct for "
"label at %L", &code->loc, &label->where);
return;
}
gfc_error ("ASSIGNED GOTO statement at %L requires an "
"INTEGER variable", &code->expr1->where);
else if (code->expr1->symtree->n.sym->attr.assign != 1)
- gfc_error ("Variable '%s' has not been assigned a target "
+ gfc_error ("Variable %qs has not been assigned a target "
"label at %L", code->expr1->symtree->n.sym->name,
&code->expr1->where);
}
if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
{
- gfc_error ("Variable %s with binding label %s at %L uses the same global "
+ gfc_error_1 ("Variable %s with binding label %s at %L uses the same global "
"identifier as entity at %L", sym->name,
sym->binding_label, &sym->declared_at, &gsym->where);
/* Clear the binding label to prevent checking multiple times. */
{
/* This can only happen if the variable is defined in a module - if it
isn't the same module, reject it. */
- gfc_error ("Variable %s from module %s with binding label %s at %L uses "
- "the same global identifier as entity at %L from module %s",
+ gfc_error_1 ("Variable %s from module %s with binding label %s at %L uses "
+ "the same global identifier as entity at %L from module %s",
sym->name, module, sym->binding_label,
&sym->declared_at, &gsym->where, gsym->mod_name);
sym->binding_label = NULL;
/* Print an error if the procedure is defined multiple times; we have to
exclude references to the same procedure via module association or
multiple checks for the same procedure. */
- gfc_error ("Procedure %s with binding label %s at %L uses the same "
+ gfc_error_1 ("Procedure %s with binding label %s at %L uses the same "
"global identifier as entity at %L", sym->name,
sym->binding_label, &sym->declared_at, &gsym->where);
sym->binding_label = NULL;
s = gfc_find_dt_in_generic (s);
if (s && s->attr.flavor != FL_DERIVED)
{
- gfc_error ("The type '%s' cannot be host associated at %L "
+ gfc_error_1 ("The type '%s' cannot be host associated at %L "
"because it is blocked by an incompatible object "
"of the same name declared at %L",
sym->ts.u.derived->name, &sym->declared_at,
&& c->attr.codimension
&& (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
{
- gfc_error ("Coarray component '%s' at %L must be allocatable with "
+ gfc_error ("Coarray component %qs at %L must be allocatable with "
"deferred shape", c->name, &c->loc);
return false;
}
if (c->attr.codimension && c->ts.type == BT_DERIVED
&& c->ts.u.derived->ts.is_iso_c)
{
- gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+ gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
"shall not be a coarray", c->name, &c->loc);
return false;
}
&& (c->attr.codimension || c->attr.pointer || c->attr.dimension
|| c->attr.allocatable))
{
- gfc_error ("Component '%s' at %L with coarray component "
+ gfc_error ("Component %qs at %L with coarray component "
"shall be a nonpointer, nonallocatable scalar",
c->name, &c->loc);
return false;
/* F2008, C448. */
if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
{
- gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
+ gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
"is not an array pointer", c->name, &c->loc);
return false;
}
if (!me_arg)
{
- gfc_error ("Procedure pointer component '%s' with PASS(%s) "
- "at %L has no argument '%s'", c->name,
+ gfc_error ("Procedure pointer component %qs with PASS(%s) "
+ "at %L has no argument %qs", c->name,
c->tb->pass_arg, &c->loc, c->tb->pass_arg);
c->tb->error = 1;
return false;
c->tb->pass_arg_num = 1;
if (!c->ts.interface->formal)
{
- gfc_error ("Procedure pointer component '%s' with PASS at %L "
+ gfc_error ("Procedure pointer component %qs with PASS at %L "
"must have at least one argument",
c->name, &c->loc);
c->tb->error = 1;
|| (me_arg->ts.type == BT_CLASS
&& CLASS_DATA (me_arg)->ts.u.derived != sym))
{
- gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
- " the derived type '%s'", me_arg->name, c->name,
+ gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
+ " the derived type %qs", me_arg->name, c->name,
me_arg->name, &c->loc, sym->name);
c->tb->error = 1;
return false;
/* Check for C453. */
if (me_arg->attr.dimension)
{
- gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
+ gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
"must be scalar", me_arg->name, c->name, me_arg->name,
&c->loc);
c->tb->error = 1;
if (me_arg->attr.pointer)
{
- gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
+ gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
"may not have the POINTER attribute", me_arg->name,
c->name, me_arg->name, &c->loc);
c->tb->error = 1;
if (me_arg->attr.allocatable)
{
- gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
+ gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
"may not be ALLOCATABLE", me_arg->name, c->name,
me_arg->name, &c->loc);
c->tb->error = 1;
}
if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
- gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
+ gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
" at %L", c->name, &c->loc);
}
if (super_type && !sym->attr.is_class
&& gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
{
- gfc_error ("Component '%s' of '%s' at %L has the same name as an"
+ gfc_error ("Component %qs of %qs at %L has the same name as an"
" inherited type-bound procedure",
c->name, sym->name, &c->loc);
return false;
|| (!resolve_charlen(c->ts.u.cl))
|| !gfc_is_constant_expr (c->ts.u.cl->length))
{
- gfc_error ("Character length of component '%s' needs to "
+ gfc_error ("Character length of component %qs needs to "
"be a constant specification expression at %L",
c->name,
c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
if (c->ts.type == BT_CHARACTER && c->ts.deferred
&& !c->attr.pointer && !c->attr.allocatable)
{
- gfc_error ("Character component '%s' of '%s' at %L with deferred "
+ gfc_error ("Character component %qs of %qs at %L with deferred "
"length must be a POINTER or ALLOCATABLE",
c->name, sym->name, &c->loc);
return false;
&& c->attr.pointer && c->ts.u.derived->components == NULL
&& !c->ts.u.derived->attr.zero_comp)
{
- gfc_error ("The pointer component '%s' of '%s' at %L is a type "
+ gfc_error ("The pointer component %qs of %qs at %L is a type "
"that has not been declared", c->name, sym->name,
&c->loc);
return false;
&& !CLASS_DATA (c)->ts.u.derived->attr.zero_comp
&& !UNLIMITED_POLY (c))
{
- gfc_error ("The pointer component '%s' of '%s' at %L is a type "
+ gfc_error ("The pointer component %qs of %qs at %L is a type "
"that has not been declared", c->name, sym->name,
&c->loc);
return false;
|| !(CLASS_DATA (c)->attr.class_pointer
|| CLASS_DATA (c)->attr.allocatable)))
{
- gfc_error ("Component '%s' with CLASS at %L must be allocatable "
+ gfc_error ("Component %qs with CLASS at %L must be allocatable "
"or pointer", c->name, &c->loc);
/* Prevent a recurrence of the error. */
c->ts.type = BT_UNKNOWN;
if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
sym->attr.in_common == 0)
{
- gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
+ gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
"is neither a COMMON block nor declared at the "
"module level scope", sym->name, &(sym->declared_at));
t = false;
b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size
+ (len + 1) * sizeof (gfc_char_t));
+
b->location
= linemap_line_start (line_table, current_file->line++, len);
/* ??? We add the location for the maximum column possible here,
if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
{
if (sym->attr.use_assoc)
- gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
+ gfc_error_1 ("Symbol '%s' at %L conflicts with symbol from module '%s', "
"use-associated at %L", sym->name, where, sym->module,
&sym->declared_at);
else
- gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
+ gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name,
where, gfc_basic_typename (type));
return false;
}
if (sym->attr.procedure && sym->ts.interface)
{
- gfc_error ("Procedure '%s' at %L may not have basic type of %s",
+ gfc_error ("Procedure %qs at %L may not have basic type of %s",
sym->name, where, gfc_basic_typename (ts->type));
return false;
}
{
if (strcmp (p->name, name) == 0)
{
- gfc_error ("Component '%s' at %C already declared at %L",
+ gfc_error_1 ("Component '%s' at %C already declared at %L",
name, &p->loc);
return false;
}
if (sym->attr.extension
&& gfc_find_component (sym->components->ts.u.derived, name, true, true))
{
- gfc_error ("Component '%s' at %C already in the parent type "
+ gfc_error_1 ("Component '%s' at %C already in the parent type "
"at %L", name, &sym->components->ts.u.derived->declared_at);
return false;
}
&& !is_parent_comp))
{
if (!silent)
- gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
+ gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
name, sym->name);
return NULL;
}
}
if (p == NULL && !silent)
- gfc_error ("'%s' at %C is not a member of the '%s' structure",
+ gfc_error ("%qs at %C is not a member of the %qs structure",
name, sym->name);
return p;
labelno = lp->value;
if (lp->defined != ST_LABEL_UNKNOWN)
- gfc_error ("Duplicate statement label %d at %L and %L", labelno,
+ gfc_error_1 ("Duplicate statement label %d at %L and %L", labelno,
&lp->where, label_locus);
else
{
{
if (st->n.sym->module)
- gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
- "from module '%s'", name, st->n.sym->name, st->n.sym->module);
+ gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
+ "from module %qs", name, st->n.sym->name, st->n.sym->module);
else
- gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
+ gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
"from current program unit", name, st->n.sym->name);
}
&& (ns->has_import_set || p->attr.imported)))
{
/* Symbol is from another namespace. */
- gfc_error ("Symbol '%s' at %C has already been host associated",
+ gfc_error ("Symbol %qs at %C has already been host associated",
name);
return 2;
}
J3/04-007, Section 15.2.3, C1505. */
if (curr_comp->attr.pointer != 0)
{
- gfc_error ("Component '%s' at %L cannot have the "
+ gfc_error_1 ("Component '%s' at %L cannot have the "
"POINTER attribute because it is a member "
"of the BIND(C) derived type '%s' at %L",
curr_comp->name, &(curr_comp->loc),
if (curr_comp->attr.proc_pointer != 0)
{
- gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
+ gfc_error_1 ("Procedure pointer component '%s' at %L cannot be a member"
" of the BIND(C) derived type '%s' at %L", curr_comp->name,
&curr_comp->loc, derived_sym->name,
&derived_sym->declared_at);
J3/04-007, Section 15.2.3, C1505. */
if (curr_comp->attr.allocatable != 0)
{
- gfc_error ("Component '%s' at %L cannot have the "
+ gfc_error_1 ("Component '%s' at %L cannot have the "
"ALLOCATABLE attribute because it is a member "
"of the BIND(C) derived type '%s' at %L",
curr_comp->name, &(curr_comp->loc),
offset2 = calculate_offset (eq2->expr);
if (s1->offset + offset1 != s2->offset + offset2)
- gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
+ gfc_error_1 ("Inconsistent equivalence rules involving '%s' at %L and "
"'%s' at %L", s1->sym->name, &s1->sym->declared_at,
s2->sym->name, &s2->sym->declared_at);
}
obstack_free (&formatted_obstack, NULL);
}
-/* A pointer to the formatted diagnostic message. */
-#define pp_formatted_text_data(PP) \
- ((const char *) obstack_base (pp_buffer (PP)->obstack))
/* Format an integer given by va_arg (ARG, type-specifier T) where
type-specifier is a precision modifier as indicated by PREC. F is
static inline void
pp_append_r (pretty_printer *pp, const char *start, int length)
{
- obstack_grow (pp_buffer (pp)->obstack, start, length);
- pp_buffer (pp)->line_length += length;
+ output_buffer_append_r (pp_buffer (pp), start, length);
}
/* Insert enough spaces into the output area of PRETTY-PRINTER to bring
const char *
pp_formatted_text (pretty_printer *pp)
{
- obstack_1grow (pp_buffer (pp)->obstack, '\0');
- return pp_formatted_text_data (pp);
+ return output_buffer_formatted_text (pp_buffer (pp));
}
/* Return a pointer to the last character emitted in PRETTY-PRINTER's
const char *
pp_last_position_in_text (const pretty_printer *pp)
{
- const char *p = NULL;
- struct obstack *text = pp_buffer (pp)->obstack;
-
- if (obstack_base (text) != obstack_next_free (text))
- p = ((const char *) obstack_next_free (text)) - 1;
- return p;
+ return output_buffer_last_position_in_text (pp_buffer (pp));
}
/* Return the amount of characters PRETTY-PRINTER can accept to
bool flush_p;
};
+/* Finishes constructing a NULL-terminated character string representing
+ the buffered text. */
+static inline const char *
+output_buffer_formatted_text (output_buffer *buff)
+{
+ obstack_1grow (buff->obstack, '\0');
+ return (const char *) obstack_base (buff->obstack);
+}
+
+/* Append to the output buffer a string specified by its
+ STARTing character and LENGTH. */
+static inline void
+output_buffer_append_r (output_buffer *buff, const char *start, int length)
+{
+ obstack_grow (buff->obstack, start, length);
+ buff->line_length += length;
+}
+
+/* Return a pointer to the last character emitted in the
+ output_buffer. A NULL pointer means no character available. */
+static inline const char *
+output_buffer_last_position_in_text (const output_buffer *buff)
+{
+ const char *p = NULL;
+ struct obstack *text = buff->obstack;
+
+ if (obstack_base (text) != obstack_next_free (text))
+ p = ((const char *) obstack_next_free (text)) - 1;
+ return p;
+}
+
+
/* The type of pretty-printer flags passed to clients. */
typedef unsigned int pp_flags;
+2014-12-11 Manuel López-Ibáñez <manu@gcc.gnu.org>
+
+ * gfortran.dg/do_iterator.f90: Remove bogus dg-warning.
+
2014-12-11 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
* config/arm/arm_neon.h (vrndqn_f32): Rename to...
projects / gcc.git / commitdiff