Hi!
The Fortran FE has huge amounts of -Wformat-security warnings everywhere,
but in the end they are only a result of a few commonly used things:
1) gfc_get_string uses a printf-like format string, so calling it with
a variable is something -Wformat-security warns about (and would be a bad bug
if the string passed to it could ever contain any % characters);
fixed by using gfc_get_string ("%s", x) instead and optimizing that
as a common case so that it doesn't go through a temporary buffer in that
case
2) gfc_extract_int used to return a _("...") string including formatting
characters that didn't consume any va_arg and callers optionally passed
that to gfc_error{,_now}. This e.g. means a second attempt to translate the
string (something that could be easily fixed just by using N_("...")
instead), but is really -Wformat-security unfriendly; fixed by moving
that gfc_error{,_now} into gfc_extract_int and just pass it an extra
argument whether error should be reported (and which) or not; the return
value is then just a bool whether it failed
3) pp_verbatim is yet another function with formatting string, had to use
"%s", ...
4) expression_syntax variable wasn't const (even when it isn't actually
modified), so -Wformat-security couldn't verify it
Bootstrapped/regtested on x86_64-linux and i686-linux, ok for trunk?
2017-01-20 Jakub Jelinek <ja...@redhat.com>
* gfortran.h (gfc_extract_int): Change return type to bool. Add
int argument with = 0.
* decl.c (gfc_match_kind_spec): Adjust gfc_extract_int caller, pass
1 as new last argument to it, don't emit gfc_error.
(match_char_kind): Likewise.
(gfc_match_decl_type_spec): Use gfc_get_string ("%s", x) instead of
gfc_get_string (x).
(gfc_match_derived_decl, match_binding_attributes): Likewise.
(gfc_match_structure_decl): Don't sprintf back to name, call
get_struct_decl directly with gfc_dt_upper_string (name) result.
* trans-stmt.c (gfc_trans_allocate): Use gfc_get_string ("%s", x)
instead of gfc_get_string (x).
* module.c (gfc_dt_lower_string, gfc_dt_upper_string,
gfc_match_use, gfc_match_submodule, find_true_name, mio_pool_string,
mio_symtree_ref, mio_expr, mio_omp_udr_expr, load_generic_interfaces,
load_omp_udrs, load_needed, read_module, dump_module,
create_intrinsic_function, import_iso_c_binding_module,
create_int_parameter, create_int_parameter_array, create_derived_type,
use_iso_fortran_env_module): Likewise.
* error.c (gfc_diagnostic_starter, gfc_diagnostic_start_span): Use
pp_verbatim (context->printer, "%s", x) instead of
pp_verbatim (context->printer, x).
* match.c (gfc_match_small_int): Adjust gfc_extract_int caller, pass
1 as new last argument to it, don't emit gfc_error.
(gfc_match_small_int_expr): Likewise.
* iresolve.c (gfc_get_string): Optimize format "%s" case.
(resolve_bound): Use gfc_get_string ("%s", x) instead of
gfc_get_string (x).
(resolve_transformational): Formatting fix.
(gfc_resolve_char_achar): Change name argument to bool is_achar,
use a single format string and if is_achar add "a" before "char".
(gfc_resolve_achar, gfc_resolve_char): Adjust callers.
* expr.c (gfc_extract_int): Change return type to bool, return true
if some error occurred. Add REPORT_ERROR argument, if non-zero
call either gfc_error or gfc_error_now depending on its sign.
* arith.c (arith_power): Adjust gfc_extract_int caller.
* symbol.c (gfc_add_component): Use gfc_get_string ("%s", x) instead
of gfc_get_string (x).
(gfc_new_symtree, gfc_delete_symtree, gfc_get_uop, gfc_new_symbol,
gfc_get_gsymbol, generate_isocbinding_symbol): Likewise.
* openmp.c (gfc_match_omp_clauses): Adjust gfc_extract_int caller, pass
-1 as new last argument to it, don't emit gfc_error_now.
(gfc_match_omp_declare_reduction): Use gfc_get_string ("%s", x)
instead of gfc_get_string (x).
* check.c (kind_check): Adjust gfc_extract_int caller.
* intrinsic.c (add_sym, find_sym, make_alias): Use
gfc_get_string ("%s", x) instead of gfc_get_string (x).
* simplify.c (get_kind, gfc_simplify_btest, gfc_simplify_maskr,
gfc_simplify_maskl, gfc_simplify_poppar, gfc_simplify_repeat,
gfc_simplify_selected_int_kind, gfc_simplify_selected_real_kind):
Adjust gfc_extract_int callers.
* trans-decl.c (gfc_find_module): Use gfc_get_string ("%s", x)
instead of gfc_get_string (x).
* matchexp.c (expression_syntax): Add const.
* primary.c (match_kind_param, match_hollerith_constant,
match_string_constant): Adjust gfc_extract_int callers.
(match_keyword_arg): Use gfc_get_string ("%s", x) instead of
gfc_get_string (x).
* frontend-passes.c (optimize_minmaxloc): Likewise.
--- gcc/fortran/gfortran.h.jj 2017-01-16 12:28:34.000000000 +0100
+++ gcc/fortran/gfortran.h 2017-01-20 13:50:58.889709470 +0100
@@ -3080,7 +3080,7 @@ void gfc_resolve_oacc_blocks (gfc_code *
/* expr.c */
void gfc_free_actual_arglist (gfc_actual_arglist *);
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
-const char *gfc_extract_int (gfc_expr *, int *);
+bool gfc_extract_int (gfc_expr *, int *, int = 0);
bool is_subref_array (gfc_expr *);
bool gfc_is_simply_contiguous (gfc_expr *, bool, bool);
bool gfc_check_init_expr (gfc_expr *);
--- gcc/fortran/decl.c.jj 2017-01-09 22:46:03.000000000 +0100
+++ gcc/fortran/decl.c 2017-01-20 14:04:11.043623360 +0100
@@ -2540,7 +2540,6 @@ gfc_match_kind_spec (gfc_typespec *ts, b
gfc_expr *e;
match m, n;
char c;
- const char *msg;
m = MATCH_NO;
n = MATCH_YES;
@@ -2598,11 +2597,8 @@ kind_expr:
goto no_match;
}
- msg = gfc_extract_int (e, &ts->kind);
-
- if (msg != NULL)
+ if (gfc_extract_int (e, &ts->kind, 1))
{
- gfc_error (msg);
m = MATCH_ERROR;
goto no_match;
}
@@ -2700,7 +2696,7 @@ match_char_kind (int * kind, int * is_is
locus where;
gfc_expr *e;
match m, n;
- const char *msg;
+ bool fail;
m = MATCH_NO;
e = NULL;
@@ -2730,11 +2726,10 @@ match_char_kind (int * kind, int * is_is
goto no_match;
}
- msg = gfc_extract_int (e, kind);
+ fail = gfc_extract_int (e, kind, 1);
*is_iso_c = e->ts.is_iso_c;
- if (msg != NULL)
+ if (fail)
{
- gfc_error (msg);
m = MATCH_ERROR;
goto no_match;
}
@@ -3302,7 +3297,7 @@ gfc_match_decl_type_spec (gfc_typespec *
/* Use upper case to save the actual derived-type symbol. */
gfc_get_symbol (dt_name, NULL, &dt_sym);
- dt_sym->name = gfc_get_string (sym->name);
+ dt_sym->name = gfc_get_string ("%s", sym->name);
head = sym->generic;
intr = gfc_get_interface ();
intr->sym = dt_sym;
@@ -8743,8 +8738,7 @@ gfc_match_structure_decl (void)
/* Store the actual type symbol for the structure with an upper-case first
letter (an invalid Fortran identifier). */
- sprintf (name, gfc_dt_upper_string (name));
- if (!get_struct_decl (name, FL_STRUCT, &where, &sym))
+ if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
return MATCH_ERROR;
gfc_new_block = sym;
@@ -8937,7 +8931,7 @@ gfc_match_derived_decl (void)
{
/* Use upper case to save the actual derived-type symbol. */
gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
- sym->name = gfc_get_string (gensym->name);
+ sym->name = gfc_get_string ("%s", gensym->name);
head = gensym->generic;
intr = gfc_get_interface ();
intr->sym = sym;
@@ -9357,7 +9351,7 @@ match_binding_attributes (gfc_typebound_
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
- ba->pass_arg = gfc_get_string (arg);
+ ba->pass_arg = gfc_get_string ("%s", arg);
gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
found_passing = true;
--- gcc/fortran/trans-stmt.c.jj 2017-01-19 16:58:24.000000000 +0100
+++ gcc/fortran/trans-stmt.c 2017-01-20 13:46:42.466980848 +0100
@@ -5883,8 +5883,8 @@ gfc_trans_allocate (gfc_code * code)
newsym = XCNEW (gfc_symtree);
/* The name of the symtree should be unique, because gfc_create_var ()
took care about generating the identifier. */
- newsym->name = gfc_get_string (IDENTIFIER_POINTER (
- DECL_NAME (expr3)));
+ newsym->name
+ = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3)));
newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
/* The backend_decl is known. It is expr3, which is inserted
here. */
--- gcc/fortran/module.c.jj 2017-01-16 12:28:34.000000000 +0100
+++ gcc/fortran/module.c 2017-01-20 13:40:32.368702470 +0100
@@ -428,7 +428,7 @@ gfc_dt_lower_string (const char *name)
if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
&name[1]);
- return gfc_get_string (name);
+ return gfc_get_string ("%s", name);
}
@@ -443,7 +443,7 @@ gfc_dt_upper_string (const char *name)
if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
&name[1]);
- return gfc_get_string (name);
+ return gfc_get_string ("%s", name);
}
/* Call here during module reading when we know what pointer to
@@ -594,7 +594,7 @@ gfc_match_use (void)
return m;
}
- use_list->module_name = gfc_get_string (name);
+ use_list->module_name = gfc_get_string ("%s", name);
if (gfc_match_eos () == MATCH_YES)
goto done;
@@ -774,7 +774,7 @@ gfc_match_submodule (void)
else
{
module_list = use_list;
- use_list->module_name = gfc_get_string (name);
+ use_list->module_name = gfc_get_string ("%s", name);
use_list->submodule_name = use_list->module_name;
}
@@ -963,9 +963,9 @@ find_true_name (const char *name, const
gfc_symbol sym;
int c;
- t.name = gfc_get_string (name);
+ t.name = gfc_get_string ("%s", name);
if (module != NULL)
- sym.module = gfc_get_string (module);
+ sym.module = gfc_get_string ("%s", module);
else
sym.module = NULL;
t.sym = &sym;
@@ -1955,7 +1955,8 @@ mio_pool_string (const char **stringp)
else
{
require_atom (ATOM_STRING);
- *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
+ *stringp = (atom_string[0] == '\0'
+ ? NULL : gfc_get_string ("%s", atom_string));
free (atom_string);
}
}
@@ -2967,7 +2968,7 @@ mio_symtree_ref (gfc_symtree **stp)
{
p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
gfc_current_ns);
- p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
+ p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module);
}
p->u.rsym.symtree->n.sym = p->u.rsym.sym;
@@ -3531,7 +3532,7 @@ mio_expr (gfc_expr **ep)
if (atom_string[0] == '\0')
e->value.function.name = NULL;
else
- e->value.function.name = gfc_get_string (atom_string);
+ e->value.function.name = gfc_get_string ("%s", atom_string);
free (atom_string);
mio_integer (&flag);
@@ -4166,13 +4167,13 @@ mio_omp_udr_expr (gfc_omp_udr *udr, gfc_
q->u.pointer = (void *) ns;
sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
sym->ts = udr->ts;
- sym->module = gfc_get_string (p1->u.rsym.module);
+ sym->module = gfc_get_string ("%s", p1->u.rsym.module);
associate_integer_pointer (p1, sym);
sym->attr.omp_udr_artificial_var = 1;
gcc_assert (p2->u.rsym.sym == NULL);
sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
sym->ts = udr->ts;
- sym->module = gfc_get_string (p2->u.rsym.module);
+ sym->module = gfc_get_string ("%s", p2->u.rsym.module);
associate_integer_pointer (p2, sym);
sym->attr.omp_udr_artificial_var = 1;
if (mio_name (0, omp_declare_reduction_stmt) == 0)
@@ -4514,7 +4515,7 @@ load_generic_interfaces (void)
if (!sym)
{
gfc_get_symbol (p, NULL, &sym);
- sym->name = gfc_get_string (name);
+ sym->name = gfc_get_string ("%s", name);
sym->module = module_name;
sym->attr.flavor = FL_PROCEDURE;
sym->attr.generic = 1;
@@ -4757,7 +4758,7 @@ load_omp_udrs (void)
memcpy (altname + 1, newname, len);
altname[len + 1] = '.';
altname[len + 2] = '\0';
- name = gfc_get_string (altname);
+ name = gfc_get_string ("%s", altname);
}
st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
@@ -4859,7 +4860,7 @@ load_needed (pointer_info *p)
sym = gfc_new_symbol (p->u.rsym.true_name, ns);
sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
- sym->module = gfc_get_string (p->u.rsym.module);
+ sym->module = gfc_get_string ("%s", p->u.rsym.module);
if (p->u.rsym.binding_label)
sym->binding_label = IDENTIFIER_POINTER (get_identifier
(p->u.rsym.binding_label));
@@ -5234,12 +5235,13 @@ read_module (void)
gfc_current_ns);
info->u.rsym.sym->name = gfc_dt_lower_string
(info->u.rsym.true_name);
sym = info->u.rsym.sym;
- sym->module = gfc_get_string (info->u.rsym.module);
+ sym->module = gfc_get_string ("%s", info->u.rsym.module);
if (info->u.rsym.binding_label)
- sym->binding_label =
- IDENTIFIER_POINTER (get_identifier
- (info->u.rsym.binding_label));
+ {
+ tree id = get_identifier (info->u.rsym.binding_label);
+ sym->binding_label = IDENTIFIER_POINTER (id);
+ }
}
st->n.sym = sym;
@@ -6045,7 +6047,7 @@ dump_module (const char *name, int dump_
char *filename, *filename_tmp;
uLong crc, crc_old;
- module_name = gfc_get_string (name);
+ module_name = gfc_get_string ("%s", name);
if (dump_smod)
{
@@ -6210,7 +6212,7 @@ create_intrinsic_function (const char *n
sym->attr.flavor = FL_PROCEDURE;
sym->attr.intrinsic = 1;
- sym->module = gfc_get_string (modname);
+ sym->module = gfc_get_string ("%s", modname);
sym->attr.use_assoc = 1;
sym->from_intmod = module;
sym->intmod_sym_id = id;
@@ -6250,7 +6252,7 @@ import_iso_c_binding_module (void)
mod_sym->attr.flavor = FL_MODULE;
mod_sym->attr.intrinsic = 1;
- mod_sym->module = gfc_get_string (iso_c_module_name);
+ mod_sym->module = gfc_get_string ("%s", iso_c_module_name);
mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
}
@@ -6508,7 +6510,7 @@ create_int_parameter (const char *name,
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
sym = tmp_symtree->n.sym;
- sym->module = gfc_get_string (modname);
+ sym->module = gfc_get_string ("%s", modname);
sym->attr.flavor = FL_PARAMETER;
sym->ts.type = BT_INTEGER;
sym->ts.kind = gfc_default_integer_kind;
@@ -6541,7 +6543,7 @@ create_int_parameter_array (const char *
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
sym = tmp_symtree->n.sym;
- sym->module = gfc_get_string (modname);
+ sym->module = gfc_get_string ("%s", modname);
sym->attr.flavor = FL_PARAMETER;
sym->ts.type = BT_INTEGER;
sym->ts.kind = gfc_default_integer_kind;
@@ -6582,7 +6584,7 @@ create_derived_type (const char *name, c
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
sym = tmp_symtree->n.sym;
- sym->module = gfc_get_string (modname);
+ sym->module = gfc_get_string ("%s", modname);
sym->from_intmod = module;
sym->intmod_sym_id = id;
sym->attr.flavor = FL_PROCEDURE;
@@ -6592,12 +6594,12 @@ create_derived_type (const char *name, c
gfc_get_sym_tree (gfc_dt_upper_string (sym->name),
gfc_current_ns, &tmp_symtree, false);
dt_sym = tmp_symtree->n.sym;
- dt_sym->name = gfc_get_string (sym->name);
+ dt_sym->name = gfc_get_string ("%s", sym->name);
dt_sym->attr.flavor = FL_DERIVED;
dt_sym->attr.private_comp = 1;
dt_sym->attr.zero_comp = 1;
dt_sym->attr.use_assoc = 1;
- dt_sym->module = gfc_get_string (modname);
+ dt_sym->module = gfc_get_string ("%s", modname);
dt_sym->from_intmod = module;
dt_sym->intmod_sym_id = id;
@@ -6677,7 +6679,7 @@ use_iso_fortran_env_module (void)
mod_sym->attr.flavor = FL_MODULE;
mod_sym->attr.intrinsic = 1;
- mod_sym->module = gfc_get_string (mod);
+ mod_sym->module = gfc_get_string ("%s", mod);
mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
}
else
--- gcc/fortran/error.c.jj 2017-01-01 12:45:47.000000000 +0100
+++ gcc/fortran/error.c 2017-01-20 13:01:43.909496065 +0100
@@ -1089,7 +1089,7 @@ gfc_diagnostic_starter (diagnostic_conte
}
else
{
- pp_verbatim (context->printer, locus_prefix);
+ pp_verbatim (context->printer, "%s", locus_prefix);
free (locus_prefix);
/* Fortran uses an empty line between locus and caret line. */
pp_newline (context->printer);
@@ -1106,7 +1106,7 @@ gfc_diagnostic_start_span (diagnostic_co
{
char *locus_prefix;
locus_prefix = gfc_diagnostic_build_locus_prefix (context, exploc);
- pp_verbatim (context->printer, locus_prefix);
+ pp_verbatim (context->printer, "%s", locus_prefix);
free (locus_prefix);
pp_newline (context->printer);
/* Fortran uses an empty line between locus and caret line. */
--- gcc/fortran/match.c.jj 2017-01-16 12:28:34.000000000 +0100
+++ gcc/fortran/match.c 2017-01-20 13:57:58.399363629 +0100
@@ -514,7 +514,6 @@ match
gfc_match_small_int (int *value)
{
gfc_expr *expr;
- const char *p;
match m;
int i;
@@ -522,15 +521,10 @@ gfc_match_small_int (int *value)
if (m != MATCH_YES)
return m;
- p = gfc_extract_int (expr, &i);
+ if (gfc_extract_int (expr, &i, 1))
+ m = MATCH_ERROR;
gfc_free_expr (expr);
- if (p != NULL)
- {
- gfc_error (p);
- m = MATCH_ERROR;
- }
-
*value = i;
return m;
}
@@ -547,7 +541,6 @@ gfc_match_small_int (int *value)
match
gfc_match_small_int_expr (int *value, gfc_expr **expr)
{
- const char *p;
match m;
int i;
@@ -555,13 +548,8 @@ gfc_match_small_int_expr (int *value, gf
if (m != MATCH_YES)
return m;
- p = gfc_extract_int (*expr, &i);
-
- if (p != NULL)
- {
- gfc_error (p);
- m = MATCH_ERROR;
- }
+ if (gfc_extract_int (*expr, &i, 1))
+ m = MATCH_ERROR;
*value = i;
return m;
--- gcc/fortran/iresolve.c.jj 2017-01-16 12:28:34.000000000 +0100
+++ gcc/fortran/iresolve.c 2017-01-20 14:09:12.479788903 +0100
@@ -47,15 +47,27 @@ const char *
gfc_get_string (const char *format, ...)
{
char temp_name[128];
+ const char *str;
va_list ap;
tree ident;
- va_start (ap, format);
- vsnprintf (temp_name, sizeof (temp_name), format, ap);
- va_end (ap);
- temp_name[sizeof (temp_name) - 1] = 0;
+ /* Handle common case without vsnprintf and temporary buffer. */
+ if (format[0] == '%' && format[1] == 's' && format[2] == '\0')
+ {
+ va_start (ap, format);
+ str = va_arg (ap, const char *);
+ va_end (ap);
+ }
+ else
+ {
+ va_start (ap, format);
+ vsnprintf (temp_name, sizeof (temp_name), format, ap);
+ va_end (ap);
+ temp_name[sizeof (temp_name) - 1] = 0;
+ str = temp_name;
+ }
- ident = get_identifier (temp_name);
+ ident = get_identifier (str);
return IDENTIFIER_POINTER (ident);
}
@@ -141,7 +153,7 @@ resolve_bound (gfc_expr *f, gfc_expr *ar
}
}
- f->value.function.name = gfc_get_string (name);
+ f->value.function.name = gfc_get_string ("%s", name);
}
@@ -174,7 +186,7 @@ resolve_transformational (const char *na
f->value.function.name
= gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
- gfc_type_letter (array->ts.type), array->ts.kind);
+ gfc_type_letter (array->ts.type), array->ts.kind);
}
@@ -229,7 +241,7 @@ gfc_resolve_adjustr (gfc_expr *f, gfc_ex
static void
gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
- const char *name)
+ bool is_achar)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = (kind == NULL)
@@ -237,16 +249,16 @@ gfc_resolve_char_achar (gfc_expr *f, gfc
f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
- f->value.function.name = gfc_get_string (name, f->ts.kind,
- gfc_type_letter (x->ts.type),
- x->ts.kind);
+ f->value.function.name
+ = gfc_get_string ("__%schar_%d_%c%d", is_achar ? "a" : "", f->ts.kind,
+ gfc_type_letter (x->ts.type), x->ts.kind);
}
void
gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
{
- gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
+ gfc_resolve_char_achar (f, x, kind, true);
}
@@ -536,7 +548,7 @@ gfc_resolve_ceiling (gfc_expr *f, gfc_ex
void
gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
- gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
+ gfc_resolve_char_achar (f, a, kind, false);
}
--- gcc/fortran/expr.c.jj 2017-01-16 12:28:34.000000000 +0100
+++ gcc/fortran/expr.c 2017-01-20 13:52:36.381465694 +0100
@@ -611,28 +611,44 @@ gfc_replace_expr (gfc_expr *dest, gfc_ex
/* Try to extract an integer constant from the passed expression node.
- Returns an error message or NULL if the result is set. It is
- tempting to generate an error and return true or false, but
- failure is OK for some callers. */
+ Return true if some error occurred, false on success. If REPORT_ERROR
+ is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
+ for negative using gfc_error_now. */
-const char *
-gfc_extract_int (gfc_expr *expr, int *result)
+bool
+gfc_extract_int (gfc_expr *expr, int *result, int report_error)
{
if (expr->expr_type != EXPR_CONSTANT)
- return _("Constant expression required at %C");
+ {
+ if (report_error > 0)
+ gfc_error ("Constant expression required at %C");
+ else if (report_error < 0)
+ gfc_error_now ("Constant expression required at %C");
+ return true;
+ }
if (expr->ts.type != BT_INTEGER)
- return _("Integer expression required at %C");
+ {
+ if (report_error > 0)
+ gfc_error ("Integer expression required at %C");
+ else if (report_error < 0)
+ gfc_error_now ("Integer expression required at %C");
+ return true;
+ }
if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
|| (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
{
- return _("Integer value too large in expression at %C");
+ if (report_error > 0)
+ gfc_error ("Integer value too large in expression at %C");
+ else if (report_error < 0)
+ gfc_error_now ("Integer value too large in expression at %C");
+ return true;
}
*result = (int) mpz_get_si (expr->value.integer);
- return NULL;
+ return false;
}
--- gcc/fortran/arith.c.jj 2017-01-01 12:45:47.000000000 +0100
+++ gcc/fortran/arith.c 2017-01-20 13:53:34.535723777 +0100
@@ -875,7 +875,7 @@ arith_power (gfc_expr *op1, gfc_expr *op
/* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */
mpz_set_si (result->value.integer, 0);
}
- else if (gfc_extract_int (op2, &power) != NULL)
+ else if (gfc_extract_int (op2, &power))
{
/* If op2 doesn't fit in an int, the exponentiation will
overflow, because op2 > 0 and abs(op1) > 1. */
--- gcc/fortran/symbol.c.jj 2017-01-01 12:45:47.000000000 +0100
+++ gcc/fortran/symbol.c 2017-01-20 13:45:21.312016203 +0100
@@ -2149,7 +2149,7 @@ gfc_add_component (gfc_symbol *sym, cons
else
tail->next = p;
- p->name = gfc_get_string (name);
+ p->name = gfc_get_string ("%s", name);
p->loc = gfc_current_locus;
p->ts.type = BT_UNKNOWN;
@@ -2756,7 +2756,7 @@ gfc_new_symtree (gfc_symtree **root, con
gfc_symtree *st;
st = XCNEW (gfc_symtree);
- st->name = gfc_get_string (name);
+ st->name = gfc_get_string ("%s", name);
gfc_insert_bbt (root, st, compare_symtree);
return st;
@@ -2772,7 +2772,7 @@ gfc_delete_symtree (gfc_symtree **root,
st0 = gfc_find_symtree (*root, name);
- st.name = gfc_get_string (name);
+ st.name = gfc_get_string ("%s", name);
gfc_delete_bbt (root, &st, compare_symtree);
free (st0);
@@ -2834,7 +2834,7 @@ gfc_get_uop (const char *name)
st = gfc_new_symtree (&ns->uop_root, name);
uop = st->n.uop = XCNEW (gfc_user_op);
- uop->name = gfc_get_string (name);
+ uop->name = gfc_get_string ("%s", name);
uop->access = ACCESS_UNKNOWN;
uop->ns = ns;
@@ -2955,7 +2955,7 @@ gfc_new_symbol (const char *name, gfc_na
if (strlen (name) > GFC_MAX_SYMBOL_LEN)
gfc_internal_error ("new_symbol(): Symbol name too long");
- p->name = gfc_get_string (name);
+ p->name = gfc_get_string ("%s", name);
/* Make sure flags for symbol being C bound are clear initially. */
p->attr.is_bind_c = 0;
@@ -4146,7 +4146,7 @@ gfc_get_gsymbol (const char *name)
s = XCNEW (gfc_gsymbol);
s->type = GSYM_UNKNOWN;
- s->name = gfc_get_string (name);
+ s->name = gfc_get_string ("%s", name);
gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
@@ -4609,7 +4609,7 @@ generate_isocbinding_symbol (const char
}
/* Say what module this symbol belongs to. */
- tmp_sym->module = gfc_get_string (mod_name);
+ tmp_sym->module = gfc_get_string ("%s", mod_name);
tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
tmp_sym->intmod_sym_id = s;
tmp_sym->attr.is_iso_c = 1;
@@ -4706,7 +4706,7 @@ generate_isocbinding_symbol (const char
gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree,
false);
dt_sym = tmp_symtree->n.sym;
dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
- ? "c_ptr" : "c_funptr");
+ ? "c_ptr" : "c_funptr");
/* Generate an artificial generic function. */
head = tmp_sym->generic;
@@ -4726,7 +4726,7 @@ generate_isocbinding_symbol (const char
}
/* Say what module this symbol belongs to. */
- dt_sym->module = gfc_get_string (mod_name);
+ dt_sym->module = gfc_get_string ("%s", mod_name);
dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
dt_sym->intmod_sym_id = s;
dt_sym->attr.use_assoc = 1;
--- gcc/fortran/openmp.c.jj 2017-01-09 22:46:03.000000000 +0100
+++ gcc/fortran/openmp.c 2017-01-20 13:59:05.058515683 +0100
@@ -1025,12 +1025,8 @@ gfc_match_omp_clauses (gfc_omp_clauses *
if (m == MATCH_YES)
{
int collapse;
- const char *p = gfc_extract_int (cexpr, &collapse);
- if (p)
- {
- gfc_error_now (p);
- collapse = 1;
- }
+ if (gfc_extract_int (cexpr, &collapse, -1))
+ collapse = 1;
else if (collapse <= 0)
{
gfc_error_now ("COLLAPSE clause argument not"
@@ -1485,12 +1481,8 @@ gfc_match_omp_clauses (gfc_omp_clauses *
if (m == MATCH_YES)
{
int ordered = 0;
- const char *p = gfc_extract_int (cexpr, &ordered);
- if (p)
- {
- gfc_error_now (p);
- ordered = 0;
- }
+ if (gfc_extract_int (cexpr, &ordered, -1))
+ ordered = 0;
else if (ordered <= 0)
{
gfc_error_now ("ORDERED clause argument not"
@@ -2866,7 +2858,7 @@ gfc_match_omp_declare_reduction (void)
const char *predef_name = NULL;
omp_udr = gfc_get_omp_udr ();
- omp_udr->name = gfc_get_string (name);
+ omp_udr->name = gfc_get_string ("%s", name);
omp_udr->rop = rop;
omp_udr->ts = tss[i];
omp_udr->where = where;
--- gcc/fortran/check.c.jj 2017-01-01 12:45:47.000000000 +0100
+++ gcc/fortran/check.c 2017-01-20 13:54:31.850992563 +0100
@@ -177,7 +177,7 @@ kind_check (gfc_expr *k, int n, bt type)
return false;
}
- if (gfc_extract_int (k, &kind) != NULL
+ if (gfc_extract_int (k, &kind)
|| gfc_validate_kind (type, kind, true) < 0)
{
gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
--- gcc/fortran/intrinsic.c.jj 2017-01-01 12:45:47.000000000 +0100
+++ gcc/fortran/intrinsic.c 2017-01-20 13:06:46.612609303 +0100
@@ -333,11 +333,11 @@ add_sym (const char *name, gfc_isym_id i
break;
case SZ_NOTHING:
- next_sym->name = gfc_get_string (name);
+ next_sym->name = gfc_get_string ("%s", name);
strcpy (buf, "_gfortran_");
strcat (buf, name);
- next_sym->lib_name = gfc_get_string (buf);
+ next_sym->lib_name = gfc_get_string ("%s", buf);
next_sym->pure = (cl != CLASS_IMPURE);
next_sym->elemental = (cl == CLASS_ELEMENTAL);
@@ -884,7 +884,7 @@ find_sym (gfc_intrinsic_sym *start, int
/* name may be a user-supplied string, so we must first make sure
that we're comparing against a pointer into the global string
table. */
- const char *p = gfc_get_string (name);
+ const char *p = gfc_get_string ("%s", name);
while (n > 0)
{
@@ -1153,7 +1153,7 @@ make_alias (const char *name, int standa
case SZ_NOTHING:
next_sym[0] = next_sym[-1];
- next_sym->name = gfc_get_string (name);
+ next_sym->name = gfc_get_string ("%s", name);
next_sym->standard = standard;
next_sym++;
break;
--- gcc/fortran/simplify.c.jj 2017-01-16 12:28:34.000000000 +0100
+++ gcc/fortran/simplify.c 2017-01-20 14:02:37.140817863 +0100
@@ -127,7 +127,7 @@ get_kind (bt type, gfc_expr *k, const ch
return -1;
}
- if (gfc_extract_int (k, &kind) != NULL
+ if (gfc_extract_int (k, &kind)
|| gfc_validate_kind (type, kind, true) < 0)
{
gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
@@ -1499,7 +1499,7 @@ gfc_simplify_btest (gfc_expr *e, gfc_exp
if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (bit, &b) != NULL || b < 0)
+ if (gfc_extract_int (bit, &b) || b < 0)
return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
@@ -4234,7 +4234,6 @@ gfc_simplify_maskr (gfc_expr *i, gfc_exp
{
gfc_expr *result;
int kind, arg, k;
- const char *s;
if (i->expr_type != EXPR_CONSTANT)
return NULL;
@@ -4244,8 +4243,8 @@ gfc_simplify_maskr (gfc_expr *i, gfc_exp
return &gfc_bad_expr;
k = gfc_validate_kind (BT_INTEGER, kind, false);
- s = gfc_extract_int (i, &arg);
- gcc_assert (!s);
+ bool fail = gfc_extract_int (i, &arg);
+ gcc_assert (!fail);
result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
@@ -4265,7 +4264,6 @@ gfc_simplify_maskl (gfc_expr *i, gfc_exp
{
gfc_expr *result;
int kind, arg, k;
- const char *s;
mpz_t z;
if (i->expr_type != EXPR_CONSTANT)
@@ -4276,8 +4274,8 @@ gfc_simplify_maskl (gfc_expr *i, gfc_exp
return &gfc_bad_expr;
k = gfc_validate_kind (BT_INTEGER, kind, false);
- s = gfc_extract_int (i, &arg);
- gcc_assert (!s);
+ bool fail = gfc_extract_int (i, &arg);
+ gcc_assert (!fail);
result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
@@ -5060,7 +5058,6 @@ gfc_expr *
gfc_simplify_poppar (gfc_expr *e)
{
gfc_expr *popcnt;
- const char *s;
int i;
if (e->expr_type != EXPR_CONSTANT)
@@ -5069,8 +5066,8 @@ gfc_simplify_poppar (gfc_expr *e)
popcnt = gfc_simplify_popcnt (e);
gcc_assert (popcnt);
- s = gfc_extract_int (popcnt, &i);
- gcc_assert (!s);
+ bool fail = gfc_extract_int (popcnt, &i);
+ gcc_assert (!fail);
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
}
@@ -5282,8 +5279,8 @@ gfc_simplify_repeat (gfc_expr *e, gfc_ex
(e->ts.u.cl->length &&
mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
{
- const char *res = gfc_extract_int (n, &ncop);
- gcc_assert (res == NULL);
+ bool fail = gfc_extract_int (n, &ncop);
+ gcc_assert (!fail);
}
else
ncop = 0;
@@ -5693,7 +5690,7 @@ gfc_simplify_selected_int_kind (gfc_expr
{
int i, kind, range;
- if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
+ if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
return NULL;
kind = INT_MAX;
@@ -5722,7 +5719,7 @@ gfc_simplify_selected_real_kind (gfc_exp
else
{
if (p->expr_type != EXPR_CONSTANT
- || gfc_extract_int (p, &precision) != NULL)
+ || gfc_extract_int (p, &precision))
return NULL;
loc = &p->where;
}
@@ -5732,7 +5729,7 @@ gfc_simplify_selected_real_kind (gfc_exp
else
{
if (q->expr_type != EXPR_CONSTANT
- || gfc_extract_int (q, &range) != NULL)
+ || gfc_extract_int (q, &range))
return NULL;
if (!loc)
@@ -5744,7 +5741,7 @@ gfc_simplify_selected_real_kind (gfc_exp
else
{
if (rdx->expr_type != EXPR_CONSTANT
- || gfc_extract_int (rdx, &radix) != NULL)
+ || gfc_extract_int (rdx, &radix))
return NULL;
if (!loc)
--- gcc/fortran/trans-decl.c.jj 2017-01-19 16:58:24.000000000 +0100
+++ gcc/fortran/trans-decl.c 2017-01-20 13:45:50.289646513 +0100
@@ -4649,7 +4649,7 @@ gfc_find_module (const char *name)
{
module_htab_entry *entry = ggc_cleared_alloc<module_htab_entry> ();
- entry->name = gfc_get_string (name);
+ entry->name = gfc_get_string ("%s", name);
entry->decls = hash_table<module_decl_hasher>::create_ggc (10);
*slot = entry;
}
--- gcc/fortran/matchexp.c.jj 2017-01-01 12:45:47.000000000 +0100
+++ gcc/fortran/matchexp.c 2017-01-20 13:26:47.594231806 +0100
@@ -25,7 +25,7 @@ along with GCC; see the file COPYING3.
#include "arith.h"
#include "match.h"
-static char expression_syntax[] = N_("Syntax error in expression at %C");
+static const char expression_syntax[] = N_("Syntax error in expression at %C");
/* Match a user-defined operator name. This is a normal name with a
--- gcc/fortran/primary.c.jj 2017-01-19 16:58:24.000000000 +0100
+++ gcc/fortran/primary.c 2017-01-20 14:00:04.305762021 +0100
@@ -41,7 +41,6 @@ match_kind_param (int *kind, int *is_iso
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
- const char *p;
match m;
*is_iso_c = 0;
@@ -68,8 +67,7 @@ match_kind_param (int *kind, int *is_iso
if (sym->value == NULL)
return MATCH_NO;
- p = gfc_extract_int (sym->value, kind);
- if (p != NULL)
+ if (gfc_extract_int (sym->value, kind))
return MATCH_NO;
gfc_set_sym_referenced (sym);
@@ -257,7 +255,6 @@ match_hollerith_constant (gfc_expr **res
{
locus old_loc;
gfc_expr *e = NULL;
- const char *msg;
int num, pad;
int i;
@@ -270,12 +267,8 @@ match_hollerith_constant (gfc_expr **res
if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C"))
goto cleanup;
- msg = gfc_extract_int (e, &num);
- if (msg != NULL)
- {
- gfc_error (msg);
- goto cleanup;
- }
+ if (gfc_extract_int (e, &num, 1))
+ goto cleanup;
if (num == 0)
{
gfc_error ("Invalid Hollerith constant: %L must contain at least "
@@ -1017,7 +1010,6 @@ match_string_constant (gfc_expr **result
locus old_locus, start_locus;
gfc_symbol *sym;
gfc_expr *e;
- const char *q;
match m;
gfc_char_t c, delimiter, *p;
@@ -1082,12 +1074,8 @@ match_string_constant (gfc_expr **result
if (kind == -1)
{
- q = gfc_extract_int (sym->value, &kind);
- if (q != NULL)
- {
- gfc_error (q);
- return MATCH_ERROR;
- }
+ if (gfc_extract_int (sym->value, &kind, 1))
+ return MATCH_ERROR;
gfc_set_sym_referenced (sym);
}
@@ -1659,7 +1647,7 @@ match_keyword_arg (gfc_actual_arglist *a
}
}
- actual->name = gfc_get_string (name);
+ actual->name = gfc_get_string ("%s", name);
return MATCH_YES;
cleanup:
--- gcc/fortran/frontend-passes.c.jj 2017-01-01 12:45:47.000000000 +0100
+++ gcc/fortran/frontend-passes.c 2017-01-20 13:15:00.119282521 +0100
@@ -1911,7 +1911,7 @@ optimize_minmaxloc (gfc_expr **e)
strcpy (name, fn->value.function.name);
p = strstr (name, "loc0");
p[3] = '1';
- fn->value.function.name = gfc_get_string (name);
+ fn->value.function.name = gfc_get_string ("%s", name);
if (fn->value.function.actual->next)
{
a = fn->value.function.actual->next;
Jakub
