OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Replace enum gfc_try with bool type. 

2013-04-11  Janne Blomqvist  <jb@gcc.gnu.org>

        * gfortran.h: Remove enum gfc_try, replace gfc_try with bool type.
        * arith.c: Replace gfc_try with bool type.
        * array.c: Likewise.
        * check.c: Likewise.
        * class.c: Likewise.
        * cpp.c: Likewise.
        * cpp.h: Likewise.
        * data.c: Likewise.
        * data.h: Likewise.
        * decl.c: Likewise.
        * error.c: Likewise.
        * expr.c: Likewise.
        * f95-lang.c: Likewise.
        * interface.c: Likewise.
        * intrinsic.c: Likewise.
        * intrinsic.h: Likewise.
        * io.c: Likewise.
        * match.c: Likewise.
        * match.h: Likewise.
        * module.c: Likewise.
        * openmp.c: Likewise.
        * parse.c: Likewise.
        * parse.h: Likewise.
        * primary.c: Likewise.
        * resolve.c: Likewise.
        * scanner.c: Likewise.
        * simplify.c: Likewise.
        * symbol.c: Likewise.
        * trans-intrinsic.c: Likewise.
        * trans-openmp.c: Likewise.
        * trans-stmt.c: Likewise.
        * trans-types.c: Likewise.

From-SVN: r197682
This commit is contained in:
Janne Blomqvist 2013-04-11 00:36:58 +03:00
parent 0ea8a6f9c7
commit 524af0d6c7
36 changed files with 4846 additions and 4986 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
gcc/fortran/ChangeLog
View File

@ -1,3 +1,38 @@
2013-04-11 Janne Blomqvist <jb@gcc.gnu.org>
* gfortran.h: Remove enum gfc_try, replace gfc_try with bool type.
* arith.c: Replace gfc_try with bool type.
* array.c: Likewise.
* check.c: Likewise.
* class.c: Likewise.
* cpp.c: Likewise.
* cpp.h: Likewise.
* data.c: Likewise.
* data.h: Likewise.
* decl.c: Likewise.
* error.c: Likewise.
* expr.c: Likewise.
* f95-lang.c: Likewise.
* interface.c: Likewise.
* intrinsic.c: Likewise.
* intrinsic.h: Likewise.
* io.c: Likewise.
* match.c: Likewise.
* match.h: Likewise.
* module.c: Likewise.
* openmp.c: Likewise.
* parse.c: Likewise.
* parse.h: Likewise.
* primary.c: Likewise.
* resolve.c: Likewise.
* scanner.c: Likewise.
* simplify.c: Likewise.
* symbol.c: Likewise.
* trans-intrinsic.c: Likewise.
* trans-openmp.c: Likewise.
* trans-stmt.c: Likewise.
* trans-types.c: Likewise.
2013-04-09 Tobias Burnus <burnus@net-b.de>
* gfortran.texi (KIND Type Parameters,

15
gcc/fortran/arith.c
View File

@ -901,9 +901,9 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
if (gfc_init_expr_flag)
{
if (gfc_notify_std (GFC_STD_F2003, "Noninteger "
"exponent in an initialization "
"expression at %L", &op2->where) == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
"exponent in an initialization "
"expression at %L", &op2->where))
{
gfc_free_expr (result);
return ARITH_PROHIBIT;
@ -926,9 +926,9 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
{
if (gfc_init_expr_flag)
{
if (gfc_notify_std (GFC_STD_F2003, "Noninteger "
"exponent in an initialization "
"expression at %L", &op2->where) == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
"exponent in an initialization "
"expression at %L", &op2->where))
{
gfc_free_expr (result);
return ARITH_PROHIBIT;
@ -1347,8 +1347,7 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *r;
arith rc = ARITH_OK;
if (gfc_check_conformance (op1, op2,
"elemental binary operation") != SUCCESS)
if (!gfc_check_conformance (op1, op2, "elemental binary operation"))
return ARITH_INCOMMENSURATE;
head = gfc_constructor_copy (op1->value.constructor);

355
gcc/fortran/array.c
View File

File diff suppressed because it is too large Load Diff

3751
gcc/fortran/check.c
View File

File diff suppressed because it is too large Load Diff

92
gcc/fortran/class.c
View File

@ -543,7 +543,7 @@ gfc_intrinsic_hash_value (gfc_typespec *ts)
which contains the declared type as '_data' component, plus a pointer
component '_vptr' which determines the dynamic type. */
gfc_try
bool
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_array_spec **as, bool delayed_vtab)
{
@ -560,19 +560,19 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
{
gfc_error ("Assumed size polymorphic objects or components, such "
"as that at %C, have not yet been implemented");
return FAILURE;
return false;
}
if (attr->class_ok)
/* Class container has already been built. */
return SUCCESS;
return true;
attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
|| attr->select_type_temporary || attr->associate_var;
if (!attr->class_ok)
/* We can not build the class container yet. */
return SUCCESS;
return true;
/* Determine the name of the encapsulating type. */
rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
@ -614,13 +614,13 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
if (!ts->u.derived->attr.unlimited_polymorphic)
fclass->attr.abstract = ts->u.derived->attr.abstract;
fclass->f2k_derived = gfc_get_namespace (NULL, 0);
if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
return FAILURE;
if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL,
&gfc_current_locus))
return false;
/* Add component '_data'. */
if (gfc_add_component (fclass, "_data", &c) == FAILURE)
return FAILURE;
if (!gfc_add_component (fclass, "_data", &c))
return false;
c->ts = *ts;
c->ts.type = BT_DERIVED;
c->attr.access = ACCESS_PRIVATE;
@ -636,8 +636,8 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
c->initializer = NULL;
/* Add component '_vptr'. */
if (gfc_add_component (fclass, "_vptr", &c) == FAILURE)
return FAILURE;
if (!gfc_add_component (fclass, "_vptr", &c))
return false;
c->ts.type = BT_DERIVED;
if (delayed_vtab
|| (ts->u.derived->f2k_derived
@ -661,7 +661,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
{
gfc_error ("Maximum extension level reached with type '%s' at %L",
ts->u.derived->name, &ts->u.derived->declared_at);
return FAILURE;
return false;
}
fclass->attr.extension = ts->u.derived->attr.extension + 1;
@ -672,7 +672,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
(*as) = NULL;
return SUCCESS;
return true;
}
@ -692,7 +692,7 @@ add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
if (c == NULL)
{
/* Add procedure component. */
if (gfc_add_component (vtype, name, &c) == FAILURE)
if (!gfc_add_component (vtype, name, &c))
return;
if (!c->tb)
@ -1724,7 +1724,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
DO idx = 1, rank
strides(idx) = _F._stride (array, dim=idx)
sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
if (strides(idx) /= sizes(i-1)) is_contiguous = .false.
if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
END DO. */
/* Create loop. */
@ -1811,7 +1811,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind;
block->expr2->ts = idx->ts;
/* if (strides(idx) /= sizes(idx-1)) is_contiguous = .false. */
/* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
block->next = XCNEW (gfc_code);
block = block->next;
block->loc = gfc_current_locus;
@ -2202,8 +2202,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
{
gfc_get_symbol (name, ns, &vtab);
vtab->ts.type = BT_DERIVED;
if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
&gfc_current_locus) == FAILURE)
if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
&gfc_current_locus))
goto cleanup;
vtab->attr.target = 1;
vtab->attr.save = SAVE_IMPLICIT;
@ -2219,15 +2219,15 @@ gfc_find_derived_vtab (gfc_symbol *derived)
gfc_symbol *parent = NULL, *parent_vtab = NULL;
gfc_get_symbol (name, ns, &vtype);
if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
&gfc_current_locus))
goto cleanup;
vtype->attr.access = ACCESS_PUBLIC;
vtype->attr.vtype = 1;
gfc_set_sym_referenced (vtype);
/* Add component '_hash'. */
if (gfc_add_component (vtype, "_hash", &c) == FAILURE)
if (!gfc_add_component (vtype, "_hash", &c))
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
@ -2236,7 +2236,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
NULL, derived->hash_value);
/* Add component '_size'. */
if (gfc_add_component (vtype, "_size", &c) == FAILURE)
if (!gfc_add_component (vtype, "_size", &c))
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
@ -2249,7 +2249,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
NULL, 0);
/* Add component _extends. */
if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
if (!gfc_add_component (vtype, "_extends", &c))
goto cleanup;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
@ -2286,7 +2286,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
}
/* Add component _def_init. */
if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
if (!gfc_add_component (vtype, "_def_init", &c))
goto cleanup;
c->attr.pointer = 1;
c->attr.artificial = 1;
@ -2315,7 +2315,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
}
/* Add component _copy. */
if (gfc_add_component (vtype, "_copy", &c) == FAILURE)
if (!gfc_add_component (vtype, "_copy", &c))
goto cleanup;
c->attr.proc_pointer = 1;
c->attr.access = ACCESS_PRIVATE;
@ -2385,7 +2385,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
/* FIXME: Enable ABI-breaking "_final" generation. */
if (0)
{
if (gfc_add_component (vtype, "_final", &c) == FAILURE)
if (!gfc_add_component (vtype, "_final", &c))
goto cleanup;
c->attr.proc_pointer = 1;
c->attr.access = ACCESS_PRIVATE;
@ -2528,8 +2528,8 @@ gfc_find_intrinsic_vtab (gfc_typespec *ts)
{
gfc_get_symbol (name, ns, &vtab);
vtab->ts.type = BT_DERIVED;
if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
&gfc_current_locus) == FAILURE)
if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
&gfc_current_locus))
goto cleanup;
vtab->attr.target = 1;
vtab->attr.save = SAVE_IMPLICIT;
@ -2547,15 +2547,15 @@ gfc_find_intrinsic_vtab (gfc_typespec *ts)
gfc_namespace *contained;
gfc_get_symbol (name, ns, &vtype);
if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
NULL, &gfc_current_locus) == FAILURE)
if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
&gfc_current_locus))
goto cleanup;
vtype->attr.access = ACCESS_PUBLIC;
vtype->attr.vtype = 1;
gfc_set_sym_referenced (vtype);
/* Add component '_hash'. */
if (gfc_add_component (vtype, "_hash", &c) == FAILURE)
if (!gfc_add_component (vtype, "_hash", &c))
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
@ -2565,7 +2565,7 @@ gfc_find_intrinsic_vtab (gfc_typespec *ts)
NULL, hash);
/* Add component '_size'. */
if (gfc_add_component (vtype, "_size", &c) == FAILURE)
if (!gfc_add_component (vtype, "_size", &c))
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
@ -2578,7 +2578,7 @@ gfc_find_intrinsic_vtab (gfc_typespec *ts)
NULL, ts->kind);
/* Add component _extends. */
if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
if (!gfc_add_component (vtype, "_extends", &c))
goto cleanup;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
@ -2586,7 +2586,7 @@ gfc_find_intrinsic_vtab (gfc_typespec *ts)
c->initializer = gfc_get_null_expr (NULL);
/* Add component _def_init. */
if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
if (!gfc_add_component (vtype, "_def_init", &c))
goto cleanup;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
@ -2594,7 +2594,7 @@ gfc_find_intrinsic_vtab (gfc_typespec *ts)
c->initializer = gfc_get_null_expr (NULL);
/* Add component _copy. */
if (gfc_add_component (vtype, "_copy", &c) == FAILURE)
if (!gfc_add_component (vtype, "_copy", &c))
goto cleanup;
c->attr.proc_pointer = 1;
c->attr.access = ACCESS_PRIVATE;
@ -2666,7 +2666,7 @@ gfc_find_intrinsic_vtab (gfc_typespec *ts)
c->ts.interface = copy;
/* Add component _final. */
if (gfc_add_component (vtype, "_final", &c) == FAILURE)
if (!gfc_add_component (vtype, "_final", &c))
goto cleanup;
c->attr.proc_pointer = 1;
c->attr.access = ACCESS_PRIVATE;
@ -2709,7 +2709,7 @@ cleanup:
type-bound user operator. */
static gfc_symtree*
find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
find_typebound_proc_uop (gfc_symbol* derived, bool* t,
const char* name, bool noaccess, bool uop,
locus* where)
{
@ -2718,7 +2718,7 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
/* Set default to failure. */
if (t)
*t = FAILURE;
*t = false;
if (derived->f2k_derived)
/* Set correct symbol-root. */
@ -2733,7 +2733,7 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
{
/* We found one. */
if (t)
*t = SUCCESS;
*t = true;
if (!noaccess && derived->attr.use_assoc
&& res->n.tb->access == ACCESS_PRIVATE)
@ -2742,7 +2742,7 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
gfc_error ("'%s' of '%s' is PRIVATE at %L",
name, derived->name, where);
if (t)
*t = FAILURE;
*t = false;
}
return res;
@ -2768,14 +2768,14 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
(looking recursively through the super-types). */
gfc_symtree*
gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
gfc_find_typebound_proc (gfc_symbol* derived, bool* t,
const char* name, bool noaccess, locus* where)
{
return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
}
gfc_symtree*
gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
gfc_find_typebound_user_op (gfc_symbol* derived, bool* t,
const char* name, bool noaccess, locus* where)
{
return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
@ -2786,7 +2786,7 @@ gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
super-type hierarchy. */
gfc_typebound_proc*
gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t,
gfc_intrinsic_op op, bool noaccess,
locus* where)
{
@ -2794,7 +2794,7 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
/* Set default to failure. */
if (t)
*t = FAILURE;
*t = false;
/* Try to find it in the current type's namespace. */
if (derived->f2k_derived)
@ -2807,7 +2807,7 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
{
/* We found one. */
if (t)
*t = SUCCESS;
*t = true;
if (!noaccess && derived->attr.use_assoc
&& res->access == ACCESS_PRIVATE)
@ -2816,7 +2816,7 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
gfc_error ("'%s' of '%s' is PRIVATE at %L",
gfc_op2string (op), derived->name, where);
if (t)
*t = FAILURE;
*t = false;
}
return res;

6
gcc/fortran/cpp.c
View File

@ -609,11 +609,11 @@ gfc_cpp_init (void)
pp_dir_change (cpp_in, get_src_pwd ());
}
gfc_try
bool
gfc_cpp_preprocess (const char *source_file)
{
if (!gfc_cpp_enabled ())
return FAILURE;
return false;
cpp_change_file (cpp_in, LC_RENAME, source_file);
@ -636,7 +636,7 @@ gfc_cpp_preprocess (const char *source_file)
|| (gfc_cpp_preprocess_only () && gfc_cpp_option.output_filename))
fclose (print.outf);
return SUCCESS;
return true;
}
void

2
gcc/fortran/cpp.h
View File

@ -43,7 +43,7 @@ int gfc_cpp_handle_option(size_t scode, const char *arg, int value);
void gfc_cpp_post_options (void);
gfc_try gfc_cpp_preprocess (const char *source_file);
bool gfc_cpp_preprocess (const char *source_file);
void gfc_cpp_done (void);

24
gcc/fortran/data.c
View File

@ -129,8 +129,8 @@ create_character_initializer (gfc_expr *init, gfc_typespec *ts,
start_expr = gfc_copy_expr (ref->u.ss.start);
end_expr = gfc_copy_expr (ref->u.ss.end);
if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
|| (gfc_simplify_expr (end_expr, 1)) == FAILURE)
if ((!gfc_simplify_expr(start_expr, 1))
|| !(gfc_simplify_expr(end_expr, 1)))
{
gfc_error ("failure to simplify substring reference in DATA "
"statement at %L", &ref->u.ss.start->where);
@ -196,7 +196,7 @@ create_character_initializer (gfc_expr *init, gfc_typespec *ts,
consecutive values in LVALUE the same value in RVALUE. In that case,
LVALUE must refer to a full array, not an array section. */
gfc_try
bool
gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
mpz_t *repeat)
{
@ -283,7 +283,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
&& ref->next == NULL);
mpz_init_set (end, offset);
mpz_add (end, end, *repeat);
if (spec_size (ref->u.ar.as, &size) == SUCCESS)
if (spec_size (ref->u.ar.as, &size))
{
if (mpz_cmp (end, size) > 0)
{
@ -319,8 +319,8 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
? con->expr : rvalue;
if (gfc_notify_std (GFC_STD_GNU,
"re-initialization of '%s' at %L",
symbol->name, &exprd->where) == FAILURE)
return FAILURE;
symbol->name, &exprd->where) == false)
return false;
}
while (con != NULL)
@ -372,7 +372,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
else
{
mpz_t size;
if (spec_size (ref->u.ar.as, &size) == SUCCESS)
if (spec_size (ref->u.ar.as, &size))
{
if (mpz_cmp (offset, size) >= 0)
{
@ -468,7 +468,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
if (ref || last_ts->type == BT_CHARACTER)
{
if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
return FAILURE;
return false;
expr = create_character_initializer (init, last_ts, ref, rvalue);
}
else
@ -485,8 +485,8 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
? init : rvalue;
if (gfc_notify_std (GFC_STD_GNU,
"re-initialization of '%s' at %L",
symbol->name, &expr->where) == FAILURE)
return FAILURE;
symbol->name, &expr->where) == false)
return false;
}
expr = gfc_copy_expr (rvalue);
@ -499,13 +499,13 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
else
last_con->expr = expr;
return SUCCESS;
return true;
abort:
if (!init)
gfc_free_expr (expr);
mpz_clear (offset);
return FAILURE;
return false;
}

2
gcc/fortran/data.h
View File

@ -19,5 +19,5 @@ along with GCC; see the file COPYING3. If not see
void gfc_formalize_init_value (gfc_symbol *);
void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *);
gfc_try gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t, mpz_t *);
bool gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t, mpz_t *);
void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *);

677
gcc/fortran/decl.c
View File

File diff suppressed because it is too large Load Diff

4
gcc/fortran/dependency.c
View File

@ -756,7 +756,7 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
}
}
if (gfc_dep_compare_expr(e1, e2) == 0)
if (gfc_dep_compare_expr (e1, e2) == 0)
{
/* Case 18: X - X = 0. */
mpz_set_si (*result, 0);
@ -1548,7 +1548,7 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
#define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
&& (a)->ts.type == BT_INTEGER)
if (IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride)
if (IS_CONSTANT_INTEGER (l_stride) && IS_CONSTANT_INTEGER (r_stride)
&& gfc_dep_difference (l_start, r_start, &tmp))
{
mpz_t gcd;

10
gcc/fortran/error.c
View File

@ -806,10 +806,10 @@ gfc_notification_std (int std)
/* Possibly issue a warning/error about use of a nonstandard (or deleted)
feature. An error/warning will be issued if the currently selected
standard does not contain the requested bits. Return FAILURE if
standard does not contain the requested bits. Return false if
an error is generated. */
gfc_try
bool
gfc_notify_std (int std, const char *gmsgid, ...)
{
va_list argp;
@ -819,10 +819,10 @@ gfc_notify_std (int std, const char *gmsgid, ...)
warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
if ((gfc_option.allow_std & std) != 0 && !warning)
return SUCCESS;
return true;
if (suppress_errors)
return warning ? SUCCESS : FAILURE;
return warning ? true : false;
cur_error_buffer = warning ? &warning_buffer : &error_buffer;
cur_error_buffer->flag = 1;
@ -883,7 +883,7 @@ gfc_notify_std (int std, const char *gmsgid, ...)
cur_error_buffer->flag = 0;
}
return (warning && !warnings_are_errors) ? SUCCESS : FAILURE;
return (warning && !warnings_are_errors) ? true : false;
}

646
gcc/fortran/expr.c
View File

File diff suppressed because it is too large Load Diff

2
gcc/fortran/f95-lang.c
View File

@ -221,7 +221,7 @@ gfc_init (void)
gfc_init_1 ();
if (gfc_new_file () != SUCCESS)
if (!gfc_new_file ())
fatal_error ("can't open input file: %s", gfc_source_file);
return true;

4
gcc/fortran/frontend-passes.c
View File

@ -588,7 +588,7 @@ cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
newvar = NULL;
for (j=0; j<i; j++)
{
if (gfc_dep_compare_functions(*(expr_array[i]),
if (gfc_dep_compare_functions (*(expr_array[i]),
*(expr_array[j]), true) == 0)
{
if (newvar == NULL)
@ -936,7 +936,7 @@ optimize_assignment (gfc_code * c)
remove_trim (rhs);
/* Replace a = ' ' by a = '' to optimize away a memcpy. */
if (is_empty_string(rhs))
if (is_empty_string (rhs))
rhs->value.character.length = 0;
}

252
gcc/fortran/gfortran.h
View File

@ -95,14 +95,6 @@ typedef enum
{ M_READ, M_WRITE, M_PRINT, M_INQUIRE }
io_kind;
/* The author remains confused to this day about the convention of
returning '0' for 'SUCCESS'... or was it the other way around? The
following enum makes things much more readable. We also start
values off at one instead of zero. */
typedef enum
{ SUCCESS = 1, FAILURE }
gfc_try;
/* These are flags for identifying whether we are reading a character literal
between quotes or normal source code. */
@ -1626,16 +1618,16 @@ gfc_intrinsic_arg;
typedef union
{
gfc_try (*f0)(void);
gfc_try (*f1)(struct gfc_expr *);
gfc_try (*f1m)(gfc_actual_arglist *);
gfc_try (*f2)(struct gfc_expr *, struct gfc_expr *);
gfc_try (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *);
gfc_try (*f3ml)(gfc_actual_arglist *);
gfc_try (*f3red)(gfc_actual_arglist *);
gfc_try (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
bool (*f0)(void);
bool (*f1)(struct gfc_expr *);
bool (*f1m)(gfc_actual_arglist *);
bool (*f2)(struct gfc_expr *, struct gfc_expr *);
bool (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *);
bool (*f3ml)(gfc_actual_arglist *);
bool (*f3red)(gfc_actual_arglist *);
bool (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *);
gfc_try (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
bool (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *, struct gfc_expr *);
}
gfc_check_f;
@ -2432,7 +2424,7 @@ gfc_char_t gfc_peek_char (void);
char gfc_peek_ascii_char (void);
void gfc_error_recovery (void);
void gfc_gobble_whitespace (void);
gfc_try gfc_new_file (void);
bool gfc_new_file (void);
const char * gfc_read_orig_filename (const char *, const char **);
extern gfc_source_form gfc_current_form;
@ -2505,7 +2497,7 @@ int gfc_error_check (void);
int gfc_error_flag_test (void);
notification gfc_notification_std (int);
gfc_try gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3);
bool gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3);
/* A general purpose syntax error. */
#define gfc_syntax_error(ST) \
@ -2525,7 +2517,7 @@ arith gfc_check_integer_range (mpz_t p, int kind);
bool gfc_check_character_range (gfc_char_t, int);
/* trans-types.c */
gfc_try gfc_check_any_c_kind (gfc_typespec *);
bool gfc_check_any_c_kind (gfc_typespec *);
int gfc_validate_kind (bt, int, bool);
int gfc_get_int_kind_from_width_isofortranenv (int size);
int gfc_get_real_kind_from_width_isofortranenv (int size);
@ -2548,72 +2540,72 @@ extern int gfc_character_storage_size;
/* symbol.c */
void gfc_clear_new_implicit (void);
gfc_try gfc_add_new_implicit_range (int, int);
gfc_try gfc_merge_new_implicit (gfc_typespec *);
bool gfc_add_new_implicit_range (int, int);
bool gfc_merge_new_implicit (gfc_typespec *);
void gfc_set_implicit_none (void);
void gfc_check_function_type (gfc_namespace *);
bool gfc_is_intrinsic_typename (const char *);
gfc_typespec *gfc_get_default_type (const char *, gfc_namespace *);
gfc_try gfc_set_default_type (gfc_symbol *, int, gfc_namespace *);
bool gfc_set_default_type (gfc_symbol *, int, gfc_namespace *);
void gfc_set_sym_referenced (gfc_symbol *);
gfc_try gfc_add_attribute (symbol_attribute *, locus *);
gfc_try gfc_add_ext_attribute (symbol_attribute *, ext_attr_id_t, locus *);
gfc_try gfc_add_allocatable (symbol_attribute *, locus *);
gfc_try gfc_add_codimension (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_contiguous (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_dimension (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_external (symbol_attribute *, locus *);
gfc_try gfc_add_intrinsic (symbol_attribute *, locus *);
gfc_try gfc_add_optional (symbol_attribute *, locus *);
gfc_try gfc_add_pointer (symbol_attribute *, locus *);
gfc_try gfc_add_cray_pointer (symbol_attribute *, locus *);
gfc_try gfc_add_cray_pointee (symbol_attribute *, locus *);
bool gfc_add_attribute (symbol_attribute *, locus *);
bool gfc_add_ext_attribute (symbol_attribute *, ext_attr_id_t, locus *);
bool gfc_add_allocatable (symbol_attribute *, locus *);
bool gfc_add_codimension (symbol_attribute *, const char *, locus *);
bool gfc_add_contiguous (symbol_attribute *, const char *, locus *);
bool gfc_add_dimension (symbol_attribute *, const char *, locus *);
bool gfc_add_external (symbol_attribute *, locus *);
bool gfc_add_intrinsic (symbol_attribute *, locus *);
bool gfc_add_optional (symbol_attribute *, locus *);
bool gfc_add_pointer (symbol_attribute *, locus *);
bool gfc_add_cray_pointer (symbol_attribute *, locus *);
bool gfc_add_cray_pointee (symbol_attribute *, locus *);
match gfc_mod_pointee_as (gfc_array_spec *);
gfc_try gfc_add_protected (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_result (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_save (symbol_attribute *, save_state, const char *, locus *);
gfc_try gfc_add_threadprivate (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_saved_common (symbol_attribute *, locus *);
gfc_try gfc_add_target (symbol_attribute *, locus *);
gfc_try gfc_add_dummy (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_generic (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_common (symbol_attribute *, locus *);
gfc_try gfc_add_in_common (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_in_equivalence (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_data (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_in_namelist (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_sequence (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_elemental (symbol_attribute *, locus *);
gfc_try gfc_add_pure (symbol_attribute *, locus *);
gfc_try gfc_add_recursive (symbol_attribute *, locus *);
gfc_try gfc_add_function (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_subroutine (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_volatile (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_asynchronous (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_proc (symbol_attribute *attr, const char *name, locus *where);
gfc_try gfc_add_abstract (symbol_attribute* attr, locus* where);
bool gfc_add_protected (symbol_attribute *, const char *, locus *);
bool gfc_add_result (symbol_attribute *, const char *, locus *);
bool gfc_add_save (symbol_attribute *, save_state, const char *, locus *);
bool gfc_add_threadprivate (symbol_attribute *, const char *, locus *);
bool gfc_add_saved_common (symbol_attribute *, locus *);
bool gfc_add_target (symbol_attribute *, locus *);
bool gfc_add_dummy (symbol_attribute *, const char *, locus *);
bool gfc_add_generic (symbol_attribute *, const char *, locus *);
bool gfc_add_common (symbol_attribute *, locus *);
bool gfc_add_in_common (symbol_attribute *, const char *, locus *);
bool gfc_add_in_equivalence (symbol_attribute *, const char *, locus *);
bool gfc_add_data (symbol_attribute *, const char *, locus *);
bool gfc_add_in_namelist (symbol_attribute *, const char *, locus *);
bool gfc_add_sequence (symbol_attribute *, const char *, locus *);
bool gfc_add_elemental (symbol_attribute *, locus *);
bool gfc_add_pure (symbol_attribute *, locus *);
bool gfc_add_recursive (symbol_attribute *, locus *);
bool gfc_add_function (symbol_attribute *, const char *, locus *);
bool gfc_add_subroutine (symbol_attribute *, const char *, locus *);
bool gfc_add_volatile (symbol_attribute *, const char *, locus *);
bool gfc_add_asynchronous (symbol_attribute *, const char *, locus *);
bool gfc_add_proc (symbol_attribute *attr, const char *name, locus *where);
bool gfc_add_abstract (symbol_attribute* attr, locus* where);
gfc_try gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *);
gfc_try gfc_add_is_bind_c (symbol_attribute *, const char *, locus *, int);
gfc_try gfc_add_extension (symbol_attribute *, locus *);
gfc_try gfc_add_value (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_flavor (symbol_attribute *, sym_flavor, const char *, locus *);
gfc_try gfc_add_entry (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_procedure (symbol_attribute *, procedure_type,
bool gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *);
bool gfc_add_is_bind_c (symbol_attribute *, const char *, locus *, int);
bool gfc_add_extension (symbol_attribute *, locus *);
bool gfc_add_value (symbol_attribute *, const char *, locus *);
bool gfc_add_flavor (symbol_attribute *, sym_flavor, const char *, locus *);
bool gfc_add_entry (symbol_attribute *, const char *, locus *);
bool gfc_add_procedure (symbol_attribute *, procedure_type,
const char *, locus *);
gfc_try gfc_add_intent (symbol_attribute *, sym_intent, locus *);
gfc_try gfc_add_explicit_interface (gfc_symbol *, ifsrc,
bool gfc_add_intent (symbol_attribute *, sym_intent, locus *);
bool gfc_add_explicit_interface (gfc_symbol *, ifsrc,
gfc_formal_arglist *, locus *);
gfc_try gfc_add_type (gfc_symbol *, gfc_typespec *, locus *);
bool gfc_add_type (gfc_symbol *, gfc_typespec *, locus *);
void gfc_clear_attr (symbol_attribute *);
gfc_try gfc_missing_attr (symbol_attribute *, locus *);
gfc_try gfc_copy_attr (symbol_attribute *, symbol_attribute *, locus *);
bool gfc_missing_attr (symbol_attribute *, locus *);
bool gfc_copy_attr (symbol_attribute *, symbol_attribute *, locus *);
gfc_try gfc_add_component (gfc_symbol *, const char *, gfc_component **);
bool gfc_add_component (gfc_symbol *, const char *, gfc_component **);
gfc_symbol *gfc_use_derived (gfc_symbol *);
gfc_symtree *gfc_use_derived_tree (gfc_symtree *);
gfc_component *gfc_find_component (gfc_symbol *, const char *, bool, bool);
@ -2621,7 +2613,7 @@ gfc_component *gfc_find_component (gfc_symbol *, const char *, bool, bool);
gfc_st_label *gfc_get_st_label (int);
void gfc_free_st_label (gfc_st_label *);
void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *);
gfc_try gfc_reference_st_label (gfc_st_label *, gfc_sl_type);
bool gfc_reference_st_label (gfc_st_label *, gfc_sl_type);
gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
@ -2637,11 +2629,11 @@ gfc_symtree* gfc_find_symtree_in_proc (const char *, gfc_namespace *);
int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **);
int gfc_find_sym_tree (const char *, gfc_namespace *, int, gfc_symtree **);
int gfc_get_symbol (const char *, gfc_namespace *, gfc_symbol **);
gfc_try gfc_verify_c_interop (gfc_typespec *);
gfc_try gfc_verify_c_interop_param (gfc_symbol *);
gfc_try verify_bind_c_sym (gfc_symbol *, gfc_typespec *, int, gfc_common_head *);
gfc_try verify_bind_c_derived_type (gfc_symbol *);
gfc_try verify_com_block_vars_c_interop (gfc_common_head *);
bool gfc_verify_c_interop (gfc_typespec *);
bool gfc_verify_c_interop_param (gfc_symbol *);
bool verify_bind_c_sym (gfc_symbol *, gfc_typespec *, int, gfc_common_head *);
bool verify_bind_c_derived_type (gfc_symbol *);
bool verify_com_block_vars_c_interop (gfc_common_head *);
gfc_symtree *generate_isocbinding_symbol (const char *, iso_c_binding_symbol,
const char *, gfc_symtree *, bool);
int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **, bool);
@ -2683,7 +2675,7 @@ void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */
gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
bool gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
bool gfc_is_associate_pointer (gfc_symbol*);
@ -2704,9 +2696,9 @@ void gfc_intrinsic_done_1 (void);
char gfc_type_letter (bt);
gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *);
gfc_try gfc_convert_type (gfc_expr *, gfc_typespec *, int);
gfc_try gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int);
gfc_try gfc_convert_chartype (gfc_expr *, gfc_typespec *);
bool gfc_convert_type (gfc_expr *, gfc_typespec *, int);
bool gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int);
bool gfc_convert_chartype (gfc_expr *, gfc_typespec *);
int gfc_generic_intrinsic (const char *);
int gfc_specific_intrinsic (const char *);
bool gfc_is_intrinsic (gfc_symbol*, int, locus);
@ -2723,7 +2715,7 @@ match gfc_intrinsic_func_interface (gfc_expr *, int);
match gfc_intrinsic_sub_interface (gfc_code *, int);
void gfc_warn_intrinsic_shadow (const gfc_symbol*, bool, bool);
gfc_try gfc_check_intrinsic_standard (const gfc_intrinsic_sym*, const char**,
bool gfc_check_intrinsic_standard (const gfc_intrinsic_sym*, const char**,
bool, locus);
/* match.c -- FIXME */
@ -2755,13 +2747,13 @@ gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
const char *gfc_extract_int (gfc_expr *, int *);
bool is_subref_array (gfc_expr *);
bool gfc_is_simply_contiguous (gfc_expr *, bool);
gfc_try gfc_check_init_expr (gfc_expr *);
bool gfc_check_init_expr (gfc_expr *);
gfc_expr *gfc_build_conversion (gfc_expr *);
void gfc_free_ref_list (gfc_ref *);
void gfc_type_convert_binary (gfc_expr *, int);
int gfc_is_constant_expr (gfc_expr *);
gfc_try gfc_simplify_expr (gfc_expr *, int);
bool gfc_simplify_expr (gfc_expr *, int);
int gfc_has_vector_index (gfc_expr *);
gfc_expr *gfc_get_expr (void);
@ -2784,15 +2776,15 @@ mpz_t *gfc_copy_shape_excluding (mpz_t *, int, gfc_expr *);
gfc_expr *gfc_copy_expr (gfc_expr *);
gfc_ref* gfc_copy_ref (gfc_ref*);
gfc_try gfc_specification_expr (gfc_expr *);
bool gfc_specification_expr (gfc_expr *);
int gfc_numeric_ts (gfc_typespec *);
int gfc_kind_max (gfc_expr *, gfc_expr *);
gfc_try gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3;
gfc_try gfc_check_assign (gfc_expr *, gfc_expr *, int);
gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_component *, gfc_expr *);
bool gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3;
bool gfc_check_assign (gfc_expr *, gfc_expr *, int);
bool gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
bool gfc_check_assign_symbol (gfc_symbol *, gfc_component *, gfc_expr *);
bool gfc_has_default_initializer (gfc_symbol *);
gfc_expr *gfc_default_initializer (gfc_typespec *);
@ -2806,7 +2798,7 @@ bool gfc_traverse_expr (gfc_expr *, gfc_symbol *,
bool (*)(gfc_expr *, gfc_symbol *, int*),
int);
void gfc_expr_set_symbols_referenced (gfc_expr *);
gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
bool gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
bool gfc_is_proc_ptr_comp (gfc_expr *);
@ -2820,7 +2812,7 @@ bool gfc_has_ultimate_pointer (gfc_expr *);
gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*,
locus, unsigned, ...);
gfc_try gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*);
bool gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*);
/* st.c */
@ -2834,23 +2826,23 @@ void gfc_free_statements (gfc_code *);
void gfc_free_association_list (gfc_association_list *);
/* resolve.c */
gfc_try gfc_resolve_expr (gfc_expr *);
bool gfc_resolve_expr (gfc_expr *);
void gfc_resolve (gfc_namespace *);
void gfc_resolve_blocks (gfc_code *, gfc_namespace *);
int gfc_impure_variable (gfc_symbol *);
int gfc_pure (gfc_symbol *);
int gfc_implicit_pure (gfc_symbol *);
int gfc_elemental (gfc_symbol *);
gfc_try gfc_resolve_iterator (gfc_iterator *, bool, bool);
gfc_try find_forall_index (gfc_expr *, gfc_symbol *, int);
gfc_try gfc_resolve_index (gfc_expr *, int);
gfc_try gfc_resolve_dim_arg (gfc_expr *);
bool gfc_resolve_iterator (gfc_iterator *, bool, bool);
bool find_forall_index (gfc_expr *, gfc_symbol *, int);
bool gfc_resolve_index (gfc_expr *, int);
bool gfc_resolve_dim_arg (gfc_expr *);
int gfc_is_formal_arg (void);
void gfc_resolve_substring_charlen (gfc_expr *);
match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
gfc_expr *gfc_expr_to_initialize (gfc_expr *);
bool gfc_type_is_extensible (gfc_symbol *);
gfc_try gfc_resolve_intrinsic (gfc_symbol *, locus *);
bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
/* array.c */
@ -2859,31 +2851,31 @@ gfc_iterator *gfc_copy_iterator (gfc_iterator *);
void gfc_free_array_spec (gfc_array_spec *);
gfc_array_ref *gfc_copy_array_ref (gfc_array_ref *);
gfc_try gfc_set_array_spec (gfc_symbol *, gfc_array_spec *, locus *);
bool gfc_set_array_spec (gfc_symbol *, gfc_array_spec *, locus *);
gfc_array_spec *gfc_copy_array_spec (gfc_array_spec *);
gfc_try gfc_resolve_array_spec (gfc_array_spec *, int);
bool gfc_resolve_array_spec (gfc_array_spec *, int);
int gfc_compare_array_spec (gfc_array_spec *, gfc_array_spec *);
void gfc_simplify_iterator_var (gfc_expr *);
gfc_try gfc_expand_constructor (gfc_expr *, bool);
bool gfc_expand_constructor (gfc_expr *, bool);
int gfc_constant_ac (gfc_expr *);
int gfc_expanded_ac (gfc_expr *);
gfc_try gfc_resolve_character_array_constructor (gfc_expr *);
gfc_try gfc_resolve_array_constructor (gfc_expr *);
gfc_try gfc_check_constructor_type (gfc_expr *);
gfc_try gfc_check_iter_variable (gfc_expr *);
gfc_try gfc_check_constructor (gfc_expr *, gfc_try (*)(gfc_expr *));
gfc_try gfc_array_size (gfc_expr *, mpz_t *);
gfc_try gfc_array_dimen_size (gfc_expr *, int, mpz_t *);
gfc_try gfc_array_ref_shape (gfc_array_ref *, mpz_t *);
bool gfc_resolve_character_array_constructor (gfc_expr *);
bool gfc_resolve_array_constructor (gfc_expr *);
bool gfc_check_constructor_type (gfc_expr *);
bool gfc_check_iter_variable (gfc_expr *);
bool gfc_check_constructor (gfc_expr *, bool (*)(gfc_expr *));
bool gfc_array_size (gfc_expr *, mpz_t *);
bool gfc_array_dimen_size (gfc_expr *, int, mpz_t *);
bool gfc_array_ref_shape (gfc_array_ref *, mpz_t *);
gfc_array_ref *gfc_find_array_ref (gfc_expr *);
tree gfc_conv_array_initializer (tree type, gfc_expr *);
gfc_try spec_size (gfc_array_spec *, mpz_t *);
gfc_try spec_dimen_size (gfc_array_spec *, int, mpz_t *);
bool spec_size (gfc_array_spec *, mpz_t *);
bool spec_dimen_size (gfc_array_spec *, int, mpz_t *);
int gfc_is_compile_time_shape (gfc_array_spec *);
gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *, mpz_t *);
bool gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *, mpz_t *);
/* interface.c -- FIXME: some of these should be in symbol.c */
@ -2893,15 +2885,15 @@ int gfc_compare_types (gfc_typespec *, gfc_typespec *);
int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int,
char *, int, const char *, const char *);
void gfc_check_interfaces (gfc_namespace *);
gfc_try gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
bool gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *);
gfc_symbol *gfc_search_interface (gfc_interface *, int,
gfc_actual_arglist **);
match gfc_extend_expr (gfc_expr *);
void gfc_free_formal_arglist (gfc_formal_arglist *);
gfc_try gfc_extend_assign (gfc_code *, gfc_namespace *);
gfc_try gfc_check_new_interface (gfc_interface *, gfc_symbol *, locus);
gfc_try gfc_add_interface (gfc_symbol *);
bool gfc_extend_assign (gfc_code *, gfc_namespace *);
bool gfc_check_new_interface (gfc_interface *, gfc_symbol *, locus);
bool gfc_add_interface (gfc_symbol *);
gfc_interface *gfc_current_interface_head (void);
void gfc_set_current_interface_head (gfc_interface *);
gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
@ -2909,23 +2901,23 @@ bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*);
bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
int gfc_has_vector_subscript (gfc_expr*);
gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
gfc_try gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
/* io.c */
extern gfc_st_label format_asterisk;
void gfc_free_open (gfc_open *);
gfc_try gfc_resolve_open (gfc_open *);
bool gfc_resolve_open (gfc_open *);
void gfc_free_close (gfc_close *);
gfc_try gfc_resolve_close (gfc_close *);
bool gfc_resolve_close (gfc_close *);
void gfc_free_filepos (gfc_filepos *);
gfc_try gfc_resolve_filepos (gfc_filepos *);
bool gfc_resolve_filepos (gfc_filepos *);
void gfc_free_inquire (gfc_inquire *);
gfc_try gfc_resolve_inquire (gfc_inquire *);
bool gfc_resolve_inquire (gfc_inquire *);
void gfc_free_dt (gfc_dt *);
gfc_try gfc_resolve_dt (gfc_dt *, locus *);
bool gfc_resolve_dt (gfc_dt *, locus *);
void gfc_free_wait (gfc_wait *);
gfc_try gfc_resolve_wait (gfc_wait *);
bool gfc_resolve_wait (gfc_wait *);
/* module.c */
void gfc_module_init_2 (void);
@ -2941,7 +2933,7 @@ match gfc_match_rvalue (gfc_expr **);
match gfc_match_varspec (gfc_expr*, int, bool, bool);
int gfc_check_digit (char, int);
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
gfc_try gfc_convert_to_structure_constructor (gfc_expr *, gfc_symbol *,
bool gfc_convert_to_structure_constructor (gfc_expr *, gfc_symbol *,
gfc_expr **,
gfc_actual_arglist **, bool);
@ -2962,7 +2954,7 @@ void gfc_delete_bbt (void *, void *, compare_fn);
void gfc_dump_parse_tree (gfc_namespace *, FILE *);
/* parse.c */
gfc_try gfc_parse_file (void);
bool gfc_parse_file (void);
void gfc_global_used (gfc_gsymbol *, locus *);
gfc_namespace* gfc_build_block_ns (gfc_namespace *);
@ -2972,8 +2964,8 @@ int gfc_dep_compare_expr (gfc_expr *, gfc_expr *);
bool gfc_dep_difference (gfc_expr *, gfc_expr *, mpz_t *);
/* check.c */
gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
gfc_try gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*,
bool gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
bool gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*,
size_t*, size_t*, size_t*);
/* class.c */
@ -2991,15 +2983,15 @@ bool gfc_is_class_scalar_expr (gfc_expr *);
bool gfc_is_class_container_ref (gfc_expr *e);
gfc_expr *gfc_class_null_initializer (gfc_typespec *, gfc_expr *);
unsigned int gfc_hash_value (gfc_symbol *);
gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **, bool);
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
gfc_symbol *gfc_find_intrinsic_vtab (gfc_typespec *);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*,
const char*, bool, locus*);
gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, bool*,
const char*, bool, locus*);
gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, bool*,
gfc_intrinsic_op, bool,
locus*);
gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);

322
gcc/fortran/interface.c
View File

@ -213,7 +213,7 @@ gfc_match_interface (void)
return MATCH_ERROR;
if (!sym->attr.generic
&& gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
&& !gfc_add_generic (&sym->attr, sym->name, NULL))
return MATCH_ERROR;
if (sym->attr.dummy)
@ -251,8 +251,7 @@ gfc_match_abstract_interface (void)
{
match m;
if (gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C")
== FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C"))
return MATCH_ERROR;
m = gfc_match_eos ();
@ -326,23 +325,23 @@ gfc_match_end_interface (void)
/* The following if-statements are used to enforce C1202
from F2003. */
if ((strcmp(s1, "==") == 0 && strcmp(s2, ".eq.") == 0)
|| (strcmp(s1, ".eq.") == 0 && strcmp(s2, "==") == 0))
if ((strcmp(s1, "==") == 0 && strcmp (s2, ".eq.") == 0)
|| (strcmp(s1, ".eq.") == 0 && strcmp (s2, "==") == 0))
break;
if ((strcmp(s1, "/=") == 0 && strcmp(s2, ".ne.") == 0)
|| (strcmp(s1, ".ne.") == 0 && strcmp(s2, "/=") == 0))
if ((strcmp(s1, "/=") == 0 && strcmp (s2, ".ne.") == 0)
|| (strcmp(s1, ".ne.") == 0 && strcmp (s2, "/=") == 0))
break;
if ((strcmp(s1, "<=") == 0 && strcmp(s2, ".le.") == 0)
|| (strcmp(s1, ".le.") == 0 && strcmp(s2, "<=") == 0))
if ((strcmp(s1, "<=") == 0 && strcmp (s2, ".le.") == 0)
|| (strcmp(s1, ".le.") == 0 && strcmp (s2, "<=") == 0))
break;
if ((strcmp(s1, "<") == 0 && strcmp(s2, ".lt.") == 0)
|| (strcmp(s1, ".lt.") == 0 && strcmp(s2, "<") == 0))
if ((strcmp(s1, "<") == 0 && strcmp (s2, ".lt.") == 0)
|| (strcmp(s1, ".lt.") == 0 && strcmp (s2, "<") == 0))
break;
if ((strcmp(s1, ">=") == 0 && strcmp(s2, ".ge.") == 0)
|| (strcmp(s1, ".ge.") == 0 && strcmp(s2, ">=") == 0))
if ((strcmp(s1, ">=") == 0 && strcmp (s2, ".ge.") == 0)
|| (strcmp(s1, ".ge.") == 0 && strcmp (s2, ">=") == 0))
break;
if ((strcmp(s1, ">") == 0 && strcmp(s2, ".gt.") == 0)
|| (strcmp(s1, ".gt.") == 0 && strcmp(s2, ">") == 0))
if ((strcmp(s1, ">") == 0 && strcmp (s2, ".gt.") == 0)
|| (strcmp(s1, ".gt.") == 0 && strcmp (s2, ">") == 0))
break;
m = MATCH_ERROR;
@ -1019,19 +1018,19 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
/* Check if the characteristics of two dummy arguments match,
cf. F08:12.3.2. */
static gfc_try
static bool
check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
bool type_must_agree, char *errmsg, int err_len)
{
if (s1 == NULL || s2 == NULL)
return s1 == s2 ? SUCCESS : FAILURE;
return s1 == s2 ? true : false;
/* Check type and rank. */
if (type_must_agree && !compare_type_rank (s2, s1))
{
snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
s1->name);
return FAILURE;
return false;
}
/* Check INTENT. */
@ -1039,7 +1038,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
s1->name);
return FAILURE;
return false;
}
/* Check OPTIONAL attribute. */
@ -1047,7 +1046,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
s1->name);
return FAILURE;
return false;
}
/* Check ALLOCATABLE attribute. */
@ -1055,7 +1054,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
s1->name);
return FAILURE;
return false;
}
/* Check POINTER attribute. */
@ -1063,7 +1062,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
s1->name);
return FAILURE;
return false;
}
/* Check TARGET attribute. */
@ -1071,7 +1070,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
s1->name);
return FAILURE;
return false;
}
/* FIXME: Do more comprehensive testing of attributes, like e.g.
@ -1086,7 +1085,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "Interface mismatch in dummy procedure "
"'%s': %s", s1->name, err);
return FAILURE;
return false;
}
}
@ -1104,7 +1103,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
case -3:
snprintf (errmsg, err_len, "Character length mismatch "
"in argument '%s'", s1->name);
return FAILURE;
return false;
case -2:
/* FIXME: Implement a warning for this case.
@ -1132,7 +1131,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
s1->name);
return FAILURE;
return false;
}
if (s1->as->type == AS_EXPLICIT)
@ -1152,7 +1151,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
case -3:
snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
"argument '%s'", i + 1, s1->name);
return FAILURE;
return false;
case -2:
/* FIXME: Implement a warning for this case.
@ -1172,14 +1171,14 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
}
}
return SUCCESS;
return true;
}
/* Check if the characteristics of two function results match,
cf. F08:12.3.3. */
static gfc_try
static bool
check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
char *errmsg, int err_len)
{
@ -1189,13 +1188,13 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
r2 = s2->result ? s2->result : s2;
if (r1->ts.type == BT_UNKNOWN)
return SUCCESS;
return true;
/* Check type and rank. */
if (!compare_type_rank (r1, r2))
{
snprintf (errmsg, err_len, "Type/rank mismatch in function result");
return FAILURE;
return false;
}
/* Check ALLOCATABLE attribute. */
@ -1203,7 +1202,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
"function result");
return FAILURE;
return false;
}
/* Check POINTER attribute. */
@ -1211,7 +1210,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "POINTER attribute mismatch in "
"function result");
return FAILURE;
return false;
}
/* Check CONTIGUOUS attribute. */
@ -1219,7 +1218,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
"function result");
return FAILURE;
return false;
}
/* Check PROCEDURE POINTER attribute. */
@ -1227,7 +1226,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
"function result");
return FAILURE;
return false;
}
/* Check string length. */
@ -1237,7 +1236,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
{
snprintf (errmsg, err_len, "Character length mismatch "
"in function result");
return FAILURE;
return false;
}
if (r1->ts.u.cl->length)
@ -1251,7 +1250,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
case -3:
snprintf (errmsg, err_len, "Character length mismatch "
"in function result");
return FAILURE;
return false;
case -2:
/* FIXME: Implement a warning for this case.
@ -1279,7 +1278,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
if (r1->as->type != r2->as->type)
{
snprintf (errmsg, err_len, "Shape mismatch in function result");
return FAILURE;
return false;
}
if (r1->as->type == AS_EXPLICIT)
@ -1299,7 +1298,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
case -3:
snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
"function result", i + 1);
return FAILURE;
return false;
case -2:
/* FIXME: Implement a warning for this case.
@ -1318,7 +1317,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
}
}
return SUCCESS;
return true;
}
@ -1362,8 +1361,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
if (s1->attr.function && s2->attr.function)
{
/* If both are functions, check result characteristics. */
if (check_result_characteristics (s1, s2, errmsg, err_len)
== FAILURE)
if (!check_result_characteristics (s1, s2, errmsg, err_len))
return 0;
}
@ -1423,8 +1421,8 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
if (strict_flag)
{
/* Check all characteristics. */
if (check_dummy_characteristics (f1->sym, f2->sym,
true, errmsg, err_len) == FAILURE)
if (!check_dummy_characteristics (f1->sym, f2->sym, true,
errmsg, err_len))
return 0;
}
else if (!compare_type_rank (f2->sym, f1->sym))
@ -1491,9 +1489,9 @@ check_interface0 (gfc_interface *p, const char *interface_name)
/* F2003, C1207. F2008, C1207. */
if (p->sym->attr.proc == PROC_INTERNAL
&& gfc_notify_std (GFC_STD_F2008, "Internal procedure "
"'%s' in %s at %L", p->sym->name, interface_name,
&p->sym->declared_at) == FAILURE)
&& !gfc_notify_std (GFC_STD_F2008, "Internal procedure "
"'%s' in %s at %L", p->sym->name,
interface_name, &p->sym->declared_at))
return 1;
}
p = psave;
@ -1879,7 +1877,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
gfc_add_function (&act_sym->attr, act_sym->name,
&act_sym->declared_at);
if (act_sym->ts.type == BT_UNKNOWN
&& gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
&& !gfc_set_default_type (act_sym, 1, act_sym->ns))
return 0;
}
else if (formal->attr.subroutine && !act_sym->attr.subroutine)
@ -2478,7 +2476,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
/* Make sure that intrinsic vtables exist for calls to unlimited
polymorphic formal arguments. */
if (UNLIMITED_POLY(f->sym)
if (UNLIMITED_POLY (f->sym)
&& a->expr->ts.type != BT_DERIVED
&& a->expr->ts.type != BT_CLASS)
gfc_find_intrinsic_vtab (&a->expr->ts);
@ -2528,7 +2526,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
gfc_error ("Actual argument at %L to assumed-type dummy is of "
"derived type with type-bound or FINAL procedures",
&a->expr->where);
return FAILURE;
return false;
}
}
@ -2741,11 +2739,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
&& CLASS_DATA (f->sym)->attr.class_pointer)
|| (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
&& gfc_check_vardef_context (a->expr, true, false, false, context)
== FAILURE)
&& !gfc_check_vardef_context (a->expr, true, false, false, context))
return 0;
if (gfc_check_vardef_context (a->expr, false, false, false, context)
== FAILURE)
if (!gfc_check_vardef_context (a->expr, false, false, false, context))
return 0;
}
@ -2919,9 +2915,9 @@ pair_cmp (const void *p1, const void *p2)
/* Given two expressions from some actual arguments, test whether they
refer to the same expression. The analysis is conservative.
Returning FAILURE will produce no warning. */
Returning false will produce no warning. */
static gfc_try
static bool
compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
{
const gfc_ref *r1, *r2;
@ -2930,39 +2926,39 @@ compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
|| e1->expr_type != EXPR_VARIABLE
|| e2->expr_type != EXPR_VARIABLE
|| e1->symtree->n.sym != e2->symtree->n.sym)
return FAILURE;
return false;
/* TODO: improve comparison, see expr.c:show_ref(). */
for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
{
if (r1->type != r2->type)
return FAILURE;
return false;
switch (r1->type)
{
case REF_ARRAY:
if (r1->u.ar.type != r2->u.ar.type)
return FAILURE;
return false;
/* TODO: At the moment, consider only full arrays;
we could do better. */
if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
return FAILURE;
return false;
break;
case REF_COMPONENT:
if (r1->u.c.component != r2->u.c.component)
return FAILURE;
return false;
break;
case REF_SUBSTRING:
return FAILURE;
return false;
default:
gfc_internal_error ("compare_actual_expr(): Bad component code");
}
}
if (!r1 && !r2)
return SUCCESS;
return FAILURE;
return true;
return false;
}
@ -2970,7 +2966,7 @@ compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
another, check that identical actual arguments aren't not
associated with some incompatible INTENTs. */
static gfc_try
static bool
check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
{
sym_intent f1_intent, f2_intent;
@ -2978,7 +2974,7 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_actual_arglist *a1;
size_t n, i, j;
argpair *p;
gfc_try t = SUCCESS;
bool t = true;
n = 0;
for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
@ -3015,7 +3011,7 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_internal_error ("check_some_aliasing(): corrupted data");
/* Are the expression the same? */
if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
if (!compare_actual_expr (p[i].a->expr, p[j].a->expr))
break;
f2_intent = p[j].f->sym->attr.intent;
if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
@ -3026,7 +3022,7 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_intent_string (f1_intent), p[i].f->sym->name,
gfc_intent_string (f2_intent), p[j].f->sym->name,
&p[i].a->expr->where);
t = FAILURE;
t = false;
}
}
}
@ -3039,7 +3035,7 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
another, check that they are compatible in the sense that intents
are not mismatched. */
static gfc_try
static bool
check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
{
sym_intent f_intent;
@ -3065,7 +3061,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_error ("Procedure argument at %L is local to a PURE "
"procedure and has the POINTER attribute",
&a->expr->where);
return FAILURE;
return false;
}
}
@ -3077,7 +3073,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_error ("Coindexed actual argument at %L in PURE procedure "
"is passed to an INTENT(%s) argument",
&a->expr->where, gfc_intent_string (f_intent));
return FAILURE;
return false;
}
if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
@ -3087,7 +3083,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_error ("Coindexed actual argument at %L in PURE procedure "
"is passed to a POINTER dummy argument",
&a->expr->where);
return FAILURE;
return false;
}
}
@ -3098,11 +3094,11 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
gfc_error ("Coindexed polymorphic actual argument at %L is passed "
"polymorphic dummy argument '%s'",
&a->expr->where, f->sym->name);
return FAILURE;
return false;
}
}
return SUCCESS;
return true;
}
@ -3110,7 +3106,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
well, the actual argument list will also end up being properly
sorted. */
gfc_try
bool
gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
gfc_formal_arglist *dummy_args;
@ -3139,7 +3135,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
gfc_error("The pointer object '%s' at %L must have an explicit "
"function interface or be declared as array",
sym->name, where);
return FAILURE;
return false;
}
if (sym->attr.allocatable && !sym->attr.external)
@ -3147,14 +3143,14 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
gfc_error("The allocatable object '%s' at %L must have an explicit "
"function interface or be declared as array",
sym->name, where);
return FAILURE;
return false;
}
if (sym->attr.allocatable)
{
gfc_error("Allocatable function '%s' at %L must have an explicit "
"function interface", sym->name, where);
return FAILURE;
return false;
}
for (a = *ap; a; a = a->next)
@ -3194,7 +3190,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
&& a->expr->ts.type == BT_UNKNOWN)
{
gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
return FAILURE;
return false;
}
/* TS 29113, C407b. */
@ -3203,25 +3199,25 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
gfc_error ("Assumed-rank argument requires an explicit interface "
"at %L", &a->expr->where);
return FAILURE;
return false;
}
}
return SUCCESS;
return true;
}
dummy_args = gfc_sym_get_dummy_args (sym);
if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, where))
return FAILURE;
return false;
if (check_intents (dummy_args, *ap) == FAILURE)
return FAILURE;
if (!check_intents (dummy_args, *ap))
return false;
if (gfc_option.warn_aliasing)
check_some_aliasing (dummy_args, *ap);
return SUCCESS;
return true;
}
@ -3427,7 +3423,7 @@ matching_typebound_op (gfc_expr** tb_base,
{
gfc_typebound_proc* tb;
gfc_symbol* derived;
gfc_try result;
bool result;
while (base->expr->expr_type == EXPR_OP
&& base->expr->value.op.op == INTRINSIC_PARENTHESES)
@ -3462,7 +3458,7 @@ matching_typebound_op (gfc_expr** tb_base,
/* This means we hit a PRIVATE operator which is use-associated and
should thus not be seen. */
if (result == FAILURE)
if (!result)
tb = NULL;
/* Look through the super-type hierarchy for a matching specific
@ -3653,13 +3649,13 @@ gfc_extend_expr (gfc_expr *e)
a call to it and succeed. */
if (tbo)
{
gfc_try result;
bool result;
gcc_assert (tb_base);
build_compcall_for_operator (e, actual, tb_base, tbo, gname);
result = gfc_resolve_expr (e);
if (result == FAILURE)
if (!result)
return MATCH_ERROR;
return MATCH_YES;
@ -3681,7 +3677,7 @@ gfc_extend_expr (gfc_expr *e)
e->value.function.name = NULL;
e->user_operator = 1;
if (gfc_resolve_expr (e) == FAILURE)
if (!gfc_resolve_expr (e))
return MATCH_ERROR;
return MATCH_YES;
@ -3690,10 +3686,10 @@ gfc_extend_expr (gfc_expr *e)
/* Tries to replace an assignment code node with a subroutine call to
the subroutine associated with the assignment operator. Return
SUCCESS if the node was replaced. On FAILURE, no error is
true if the node was replaced. On false, no error is
generated. */
gfc_try
bool
gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
{
gfc_actual_arglist *actual;
@ -3711,7 +3707,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
&& (rhs->rank == 0 || rhs->rank == lhs->rank)
&& (lhs->ts.type == rhs->ts.type
|| (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
return FAILURE;
return false;
actual = gfc_get_actual_arglist ();
actual->expr = lhs;
@ -3753,12 +3749,12 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
/* c is resolved from the caller, so no need to do it here. */
return SUCCESS;
return true;
}
free (actual->next);
free (actual);
return FAILURE;
return false;
}
/* Replace the assignment with the call. */
@ -3768,7 +3764,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
c->expr2 = NULL;
c->ext.actual = actual;
return SUCCESS;
return true;
}
@ -3776,7 +3772,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
the given interface list. Ambiguity isn't checked yet since module
procedures can be present without interfaces. */
gfc_try
bool
gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
{
gfc_interface *ip;
@ -3787,17 +3783,17 @@ gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
{
gfc_error ("Entity '%s' at %L is already present in the interface",
new_sym->name, &loc);
return FAILURE;
return false;
}
}
return SUCCESS;
return true;
}
/* Add a symbol to the current interface. */
gfc_try
bool
gfc_add_interface (gfc_symbol *new_sym)
{
gfc_interface **head, *intr;
@ -3808,7 +3804,7 @@ gfc_add_interface (gfc_symbol *new_sym)
{
case INTERFACE_NAMELESS:
case INTERFACE_ABSTRACT:
return SUCCESS;
return true;
case INTERFACE_INTRINSIC_OP:
for (ns = current_interface.ns; ns; ns = ns->parent)
@ -3816,62 +3812,62 @@ gfc_add_interface (gfc_symbol *new_sym)
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
if (gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
gfc_current_locus) == FAILURE
|| gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym,
gfc_current_locus) == FAILURE)
return FAILURE;
if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
gfc_current_locus)
|| !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
if (gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
gfc_current_locus) == FAILURE
|| gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym,
gfc_current_locus) == FAILURE)
return FAILURE;
if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
gfc_current_locus)
|| !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
if (gfc_check_new_interface (ns->op[INTRINSIC_GT], new_sym,
gfc_current_locus) == FAILURE
|| gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym,
gfc_current_locus) == FAILURE)
return FAILURE;
if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
new_sym, gfc_current_locus)
|| !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
if (gfc_check_new_interface (ns->op[INTRINSIC_GE], new_sym,
gfc_current_locus) == FAILURE
|| gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym,
gfc_current_locus) == FAILURE)
return FAILURE;
if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
new_sym, gfc_current_locus)
|| !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
if (gfc_check_new_interface (ns->op[INTRINSIC_LT], new_sym,
gfc_current_locus) == FAILURE
|| gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym,
gfc_current_locus) == FAILURE)
return FAILURE;
if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
new_sym, gfc_current_locus)
|| !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
if (gfc_check_new_interface (ns->op[INTRINSIC_LE], new_sym,
gfc_current_locus) == FAILURE
|| gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym,
gfc_current_locus) == FAILURE)
return FAILURE;
if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
new_sym, gfc_current_locus)
|| !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
new_sym, gfc_current_locus))
return false;
break;
default:
if (gfc_check_new_interface (ns->op[current_interface.op], new_sym,
gfc_current_locus) == FAILURE)
return FAILURE;
if (!gfc_check_new_interface (ns->op[current_interface.op],
new_sym, gfc_current_locus))
return false;
}
head = &current_interface.ns->op[current_interface.op];
@ -3884,18 +3880,18 @@ gfc_add_interface (gfc_symbol *new_sym)
if (sym == NULL)
continue;
if (gfc_check_new_interface (sym->generic, new_sym, gfc_current_locus)
== FAILURE)
return FAILURE;
if (!gfc_check_new_interface (sym->generic,
new_sym, gfc_current_locus))
return false;
}
head = &current_interface.sym->generic;
break;
case INTERFACE_USER_OP:
if (gfc_check_new_interface (current_interface.uop->op, new_sym,
gfc_current_locus) == FAILURE)
return FAILURE;
if (!gfc_check_new_interface (current_interface.uop->op,
new_sym, gfc_current_locus))
return false;
head = &current_interface.uop->op;
break;
@ -3911,7 +3907,7 @@ gfc_add_interface (gfc_symbol *new_sym)
intr->next = *head;
*head = intr;
return SUCCESS;
return true;
}
@ -3980,7 +3976,7 @@ gfc_free_formal_arglist (gfc_formal_arglist *p)
/* Check that it is ok for the type-bound procedure 'proc' to override the
procedure 'old', cf. F08:4.5.7.3. */
gfc_try
bool
gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
locus where;
@ -3998,7 +3994,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("Can't overwrite GENERIC '%s' at %L",
old->name, &proc->n.tb->where);
return FAILURE;
return false;
}
where = proc->n.tb->where;
@ -4010,7 +4006,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a procedure binding declared"
" NON_OVERRIDABLE", proc->name, &where);
return FAILURE;
return false;
}
/* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
@ -4018,7 +4014,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
" non-DEFERRED binding", proc->name, &where);
return FAILURE;
return false;
}
/* If the overridden binding is PURE, the overriding must be, too. */
@ -4026,7 +4022,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
proc->name, &where);
return FAILURE;
return false;
}
/* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
@ -4035,13 +4031,13 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
" ELEMENTAL", proc->name, &where);
return FAILURE;
return false;
}
if (!old_target->attr.elemental && proc_target->attr.elemental)
{
gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
" be ELEMENTAL, either", proc->name, &where);
return FAILURE;
return false;
}
/* If the overridden binding is a SUBROUTINE, the overriding must also be a
@ -4050,7 +4046,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
" SUBROUTINE", proc->name, &where);
return FAILURE;
return false;
}
/* If the overridden binding is a FUNCTION, the overriding must also be a
@ -4061,15 +4057,15 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
" FUNCTION", proc->name, &where);
return FAILURE;
return false;
}
if (check_result_characteristics (proc_target, old_target,
err, sizeof(err)) == FAILURE)
if (!check_result_characteristics (proc_target, old_target, err,
sizeof(err)))
{
gfc_error ("Result mismatch for the overriding procedure "
"'%s' at %L: %s", proc->name, &where, err);
return FAILURE;
return false;
}
}
@ -4080,7 +4076,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
" PRIVATE", proc->name, &where);
return FAILURE;
return false;
}
/* Compare the formal argument lists of both procedures. This is also abused
@ -4112,16 +4108,16 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
" to match the corresponding argument of the overridden"
" procedure", proc_formal->sym->name, proc->name, &where,
old_formal->sym->name);
return FAILURE;
return false;
}
check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
if (check_dummy_characteristics (proc_formal->sym, old_formal->sym,
check_type, err, sizeof(err)) == FAILURE)
if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym,
check_type, err, sizeof(err)))
{
gfc_error ("Argument mismatch for the overriding procedure "
"'%s' at %L: %s", proc->name, &where, err);
return FAILURE;
return false;
}
++argpos;
@ -4130,7 +4126,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L must have the same number of formal arguments as"
" the overridden procedure", proc->name, &where);
return FAILURE;
return false;
}
/* If the overridden binding is NOPASS, the overriding one must also be
@ -4139,7 +4135,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
" NOPASS", proc->name, &where);
return FAILURE;
return false;
}
/* If the overridden binding is PASS(x), the overriding one must also be
@ -4150,7 +4146,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
" PASS", proc->name, &where);
return FAILURE;
return false;
}
if (proc_pass_arg != old_pass_arg)
@ -4158,9 +4154,9 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
" the same position as the passed-object dummy argument of"
" the overridden procedure", proc->name, &where);
return FAILURE;
return false;
}
}
return SUCCESS;
return true;
}

175
gcc/fortran/intrinsic.c
View File

@ -178,7 +178,7 @@ find_char_conv (gfc_typespec *from, gfc_typespec *to)
and call the proper check function rather than forcing each
function to manipulate the argument list. */
static gfc_try
static bool
do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
{
gfc_expr *a1, *a2, *a3, *a4, *a5;
@ -343,7 +343,7 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type
static void
add_sym_0 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
int kind, int standard,
gfc_try (*check) (void),
bool (*check) (void),
gfc_expr *(*simplify) (void),
void (*resolve) (gfc_expr *))
{
@ -386,7 +386,7 @@ add_sym_0s (const char *name, gfc_isym_id id, int standard,
static void
add_sym_1 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
int kind, int standard,
gfc_try (*check) (gfc_expr *),
bool (*check) (gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *),
const char *a1, bt type1, int kind1, int optional1)
@ -411,7 +411,7 @@ add_sym_1 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
static void
add_sym_1_intent (const char *name, gfc_isym_id id, enum klass cl,
int actual_ok, bt type, int kind, int standard,
gfc_try (*check) (gfc_expr *),
bool (*check) (gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *),
const char *a1, bt type1, int kind1, int optional1,
@ -436,7 +436,7 @@ add_sym_1_intent (const char *name, gfc_isym_id id, enum klass cl,
static void
add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
int standard, gfc_try (*check) (gfc_expr *),
int standard, bool (*check) (gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *), void (*resolve) (gfc_code *),
const char *a1, bt type1, int kind1, int optional1,
sym_intent intent1)
@ -461,7 +461,7 @@ add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
static void
add_sym_1m (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
int kind, int standard,
gfc_try (*check) (gfc_actual_arglist *),
bool (*check) (gfc_actual_arglist *),
gfc_expr *(*simplify) (gfc_expr *),
void (*resolve) (gfc_expr *, gfc_actual_arglist *),
const char *a1, bt type1, int kind1, int optional1,
@ -488,7 +488,7 @@ add_sym_1m (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt t
static void
add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
int kind, int standard,
gfc_try (*check) (gfc_expr *, gfc_expr *),
bool (*check) (gfc_expr *, gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *),
const char *a1, bt type1, int kind1, int optional1,
@ -515,7 +515,7 @@ add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
static void
add_sym_2_intent (const char *name, gfc_isym_id id, enum klass cl,
int actual_ok, bt type, int kind, int standard,
gfc_try (*check) (gfc_expr *, gfc_expr *),
bool (*check) (gfc_expr *, gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *),
const char *a1, bt type1, int kind1, int optional1,
@ -543,7 +543,7 @@ add_sym_2_intent (const char *name, gfc_isym_id id, enum klass cl,
static void
add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type,
int kind, int standard,
gfc_try (*check) (gfc_expr *, gfc_expr *),
bool (*check) (gfc_expr *, gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
void (*resolve) (gfc_code *),
const char *a1, bt type1, int kind1, int optional1,
@ -571,7 +571,7 @@ add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type,
static void
add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
int kind, int standard,
gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
const char *a1, bt type1, int kind1, int optional1,
@ -600,7 +600,7 @@ add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
static void
add_sym_3ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
int kind, int standard,
gfc_try (*check) (gfc_actual_arglist *),
bool (*check) (gfc_actual_arglist *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
const char *a1, bt type1, int kind1, int optional1,
@ -629,7 +629,7 @@ add_sym_3ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt
static void
add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
int kind, int standard,
gfc_try (*check) (gfc_actual_arglist *),
bool (*check) (gfc_actual_arglist *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
const char *a1, bt type1, int kind1, int optional1,
@ -658,7 +658,7 @@ add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt
static void
add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type,
int kind, int standard,
gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
void (*resolve) (gfc_code *),
const char *a1, bt type1, int kind1, int optional1,
@ -688,7 +688,7 @@ add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type,
static void
add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
int kind, int standard,
gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *),
void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
@ -721,7 +721,7 @@ add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
static void
add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
int standard,
gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *),
void (*resolve) (gfc_code *),
@ -754,7 +754,7 @@ add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
static void
add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
int standard,
gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *),
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *, gfc_expr *),
@ -981,7 +981,7 @@ gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc)
return false;
/* See if this intrinsic is allowed in the current standard. */
if (gfc_check_intrinsic_standard (isym, &symstd, false, loc) == FAILURE)
if (!gfc_check_intrinsic_standard (isym, &symstd, false, loc))
{
if (sym->attr.proc == PROC_UNKNOWN
&& gfc_option.warn_intrinsics_std)
@ -3574,9 +3574,9 @@ remove_nullargs (gfc_actual_arglist **ap)
with the format arglist. Arguments that are not present are given
a blank gfc_actual_arglist structure. If something is obviously
wrong (say, a missing required argument) we abort sorting and
return FAILURE. */
return false. */
static gfc_try
static bool
sort_actual (const char *name, gfc_actual_arglist **ap,
gfc_intrinsic_arg *formal, locus *where)
{
@ -3593,7 +3593,7 @@ sort_actual (const char *name, gfc_actual_arglist **ap,
a = actual;
if (f == NULL && a == NULL) /* No arguments */
return SUCCESS;
return true;
for (;;)
{ /* Put the nonkeyword arguments in a 1:1 correspondence */
@ -3615,7 +3615,7 @@ sort_actual (const char *name, gfc_actual_arglist **ap,
goto do_sort;
gfc_error ("Too many arguments in call to '%s' at %L", name, where);
return FAILURE;
return false;
keywords:
/* Associate the remaining actual arguments, all of which have
@ -3634,14 +3634,14 @@ keywords:
else
gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
a->name, name, where);
return FAILURE;
return false;
}
if (f->actual != NULL)
{
gfc_error ("Argument '%s' appears twice in call to '%s' at %L",
f->name, name, where);
return FAILURE;
return false;
}
f->actual = a;
@ -3655,7 +3655,7 @@ optional:
{
gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
f->name, name, where);
return FAILURE;
return false;
}
}
@ -3669,7 +3669,7 @@ do_sort:
if (f->actual && f->actual->label != NULL && f->ts.type)
{
gfc_error ("ALTERNATE RETURN not permitted at %L", where);
return FAILURE;
return false;
}
if (f->actual == NULL)
@ -3689,7 +3689,7 @@ do_sort:
}
actual->next = NULL; /* End the sorted argument list. */
return SUCCESS;
return true;
}
@ -3697,7 +3697,7 @@ do_sort:
list. The lists are checked for agreement of type. We don't check
for arrayness here. */
static gfc_try
static bool
check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
int error_flag)
{
@ -3730,7 +3730,7 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
gfc_current_intrinsic, &actual->expr->where,
gfc_typename (&formal->ts),
gfc_typename (&actual->expr->ts));
return FAILURE;
return false;
}
/* If the formal argument is INTENT([IN]OUT), check for definability. */
@ -3741,13 +3741,12 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
: NULL);
/* No pointer arguments for intrinsics. */
if (gfc_check_vardef_context (actual->expr, false, false, false,
context) == FAILURE)
return FAILURE;
if (!gfc_check_vardef_context (actual->expr, false, false, false, context))
return false;
}
}
return SUCCESS;
return true;
}
@ -3838,11 +3837,11 @@ resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
/* Given an intrinsic symbol node and an expression node, call the
simplification function (if there is one), perhaps replacing the
expression with something simpler. We return FAILURE on an error
of the simplification, SUCCESS if the simplification worked, even
expression with something simpler. We return false on an error
of the simplification, true if the simplification worked, even
if nothing has changed in the expression itself. */
static gfc_try
static bool
do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
{
gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
@ -3926,7 +3925,7 @@ do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
finish:
if (result == &gfc_bad_expr)
return FAILURE;
return false;
if (result == NULL)
resolve_intrinsic (specific, e); /* Must call at run-time */
@ -3936,12 +3935,12 @@ finish:
gfc_replace_expr (e, result);
}
return SUCCESS;
return true;
}
/* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
error messages. This subroutine returns FAILURE if a subroutine
error messages. This subroutine returns false if a subroutine
has more than MAX_INTRINSIC_ARGS, in which case the actual argument
list cannot match any intrinsic. */
@ -3965,14 +3964,14 @@ init_arglist (gfc_intrinsic_sym *isym)
/* Given a pointer to an intrinsic symbol and an expression consisting
of a function call, see if the function call is consistent with the
intrinsic's formal argument list. Return SUCCESS if the expression
and intrinsic match, FAILURE otherwise. */
intrinsic's formal argument list. Return true if the expression
and intrinsic match, false otherwise. */
static gfc_try
static bool
check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
{
gfc_actual_arglist *arg, **ap;
gfc_try t;
bool t;
ap = &expr->value.function.actual;
@ -3985,9 +3984,8 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
|| specific->check.f1m == gfc_check_min_max_double)
return (*specific->check.f1m) (*ap);
if (sort_actual (specific->name, ap, specific->formal,
&expr->where) == FAILURE)
return FAILURE;
if (!sort_actual (specific->name, ap, specific->formal, &expr->where))
return false;
if (specific->check.f3ml == gfc_check_minloc_maxloc)
/* This is special because we might have to reorder the argument list. */
@ -4008,7 +4006,7 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
if (specific->check.f1 == NULL)
{
t = check_arglist (ap, specific, error_flag);
if (t == SUCCESS)
if (t)
expr->ts = specific->ts;
}
else
@ -4016,7 +4014,7 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
}
/* Check conformance of elemental intrinsics. */
if (t == SUCCESS && specific->elemental)
if (t && specific->elemental)
{
int n = 0;
gfc_expr *first_expr;
@ -4027,16 +4025,16 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
first_expr = arg->expr;
for ( ; arg && arg->expr; arg = arg->next, n++)
if (gfc_check_conformance (first_expr, arg->expr,
"arguments '%s' and '%s' for "
"intrinsic '%s'",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic) == FAILURE)
return FAILURE;
if (!gfc_check_conformance (first_expr, arg->expr,
"arguments '%s' and '%s' for "
"intrinsic '%s'",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic))
return false;
}
if (t == FAILURE)
if (!t)
remove_nullargs (ap);
return t;
@ -4049,9 +4047,9 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
textual representation of the symbols standard status (like
"new in Fortran 2008", "a GNU extension" or "obsolescent in Fortran 95") that
can be used to construct a detailed warning/error message in case of
a FAILURE. */
a false. */
gfc_try
bool
gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym,
const char** symstd, bool silent, locus where)
{
@ -4059,7 +4057,7 @@ gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym,
/* For -fall-intrinsics, just succeed. */
if (gfc_option.flag_all_intrinsics)
return SUCCESS;
return true;
/* Find the symbol's standard message for later usage. */
switch (isym->standard)
@ -4113,17 +4111,17 @@ gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym,
gfc_warning ("Intrinsic '%s' (is %s) is used at %L",
isym->name, _(symstd_msg), &where);
return SUCCESS;
return true;
}
/* If allowing the symbol's standard, succeed, too. */
if (gfc_option.allow_std & isym->standard)
return SUCCESS;
return true;
/* Otherwise, fail. */
if (symstd)
*symstd = _(symstd_msg);
return FAILURE;
return false;
}
@ -4149,7 +4147,7 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
int flag;
if (expr->value.function.isym != NULL)
return (do_simplify (expr->value.function.isym, expr) == FAILURE)
return (!do_simplify(expr->value.function.isym, expr))
? MATCH_ERROR : MATCH_YES;
if (!error_flag)
@ -4181,9 +4179,8 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE
|| isym->id == GFC_ISYM_CMPLX)
&& gfc_init_expr_flag
&& gfc_notify_std (GFC_STD_F2003, "Function '%s' "
"as initialization expression at %L", name,
&expr->where) == FAILURE)
&& !gfc_notify_std (GFC_STD_F2003, "Function '%s' as initialization "
"expression at %L", name, &expr->where))
{
if (!error_flag)
gfc_pop_suppress_errors ();
@ -4197,7 +4194,7 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
{
init_arglist (isym);
if (isym->check.f1m (expr->value.function.actual) == SUCCESS)
if (isym->check.f1m(expr->value.function.actual))
goto got_specific;
if (!error_flag)
@ -4218,7 +4215,7 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
{
if (specific == isym)
continue;
if (check_specific (specific, expr, 0) == SUCCESS)
if (check_specific (specific, expr, 0))
{
gfc_pop_suppress_errors ();
goto got_specific;
@ -4228,7 +4225,7 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
gfc_pop_suppress_errors ();
if (check_specific (isym, expr, error_flag) == FAILURE)
if (!check_specific (isym, expr, error_flag))
{
if (!error_flag)
gfc_pop_suppress_errors ();
@ -4244,7 +4241,7 @@ got_specific:
if (!error_flag)
gfc_pop_suppress_errors ();
if (do_simplify (specific, expr) == FAILURE)
if (!do_simplify (specific, expr))
return MATCH_ERROR;
/* F95, 7.1.6.1, Initialization expressions
@ -4257,9 +4254,9 @@ got_specific:
where each argument is an initialization expression */
if (gfc_init_expr_flag && isym->elemental && flag
&& gfc_notify_std (GFC_STD_F2003, "Elemental function "
"as initialization expression with non-integer/non-"
"character arguments at %L", &expr->where) == FAILURE)
&& !gfc_notify_std (GFC_STD_F2003, "Elemental function as "
"initialization expression with non-integer/non-"
"character arguments at %L", &expr->where))
return MATCH_ERROR;
return MATCH_YES;
@ -4295,17 +4292,17 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
init_arglist (isym);
if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
if (!sort_actual (name, &c->ext.actual, isym->formal, &c->loc))
goto fail;
if (isym->check.f1 != NULL)
{
if (do_check (isym, c->ext.actual) == FAILURE)
if (!do_check (isym, c->ext.actual))
goto fail;
}
else
{
if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
if (!check_arglist (&c->ext.actual, isym, 1))
goto fail;
}
@ -4343,7 +4340,7 @@ fail:
/* Call gfc_convert_type() with warning enabled. */
gfc_try
bool
gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag)
{
return gfc_convert_type_warn (expr, ts, eflag, 1);
@ -4360,7 +4357,7 @@ gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag)
'wflag' controls the warning related to conversion. */
gfc_try
bool
gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
{
gfc_intrinsic_sym *sym;
@ -4381,7 +4378,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
{
/* Sometimes the RHS acquire the type. */
expr->ts = *ts;
return SUCCESS;
return true;
}
if (expr->ts.type == BT_UNKNOWN)
@ -4389,7 +4386,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED
&& gfc_compare_types (&expr->ts, ts))
return SUCCESS;
return true;
sym = find_conv (&expr->ts, ts);
if (sym == NULL)
@ -4499,22 +4496,22 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
expr->ts = *ts;
if (gfc_is_constant_expr (expr->value.function.actual->expr)
&& do_simplify (sym, expr) == FAILURE)
&& !do_simplify (sym, expr))
{
if (eflag == 2)
goto bad;
return FAILURE; /* Error already generated in do_simplify() */
return false; /* Error already generated in do_simplify() */
}
return SUCCESS;
return true;
bad:
if (eflag == 1)
{
gfc_error ("Can't convert %s to %s at %L",
gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
return FAILURE;
return false;
}
gfc_internal_error ("Can't convert %s to %s at %L",
@ -4524,7 +4521,7 @@ bad:
}
gfc_try
bool
gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts)
{
gfc_intrinsic_sym *sym;
@ -4568,13 +4565,13 @@ gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts)
expr->ts = *ts;
if (gfc_is_constant_expr (expr->value.function.actual->expr)
&& do_simplify (sym, expr) == FAILURE)
&& !do_simplify (sym, expr))
{
/* Error already generated in do_simplify() */
return FAILURE;
return false;
}
return SUCCESS;
return true;
}
@ -4600,8 +4597,8 @@ gfc_warn_intrinsic_shadow (const gfc_symbol* sym, bool in_module, bool func)
/* If no intrinsic was found with this name or it's not included in the
selected standard, everything's fine. */
if (!isym || gfc_check_intrinsic_standard (isym, NULL, true,
sym->declared_at) == FAILURE)
if (!isym || !gfc_check_intrinsic_standard (isym, NULL, true,
sym->declared_at))
return;
/* Emit the warning. */

368
gcc/fortran/intrinsic.h
View File

@ -25,195 +25,195 @@ extern gfc_expr gfc_bad_expr;
/* Check functions. */
gfc_try gfc_check_a_ikind (gfc_expr *, gfc_expr *);
gfc_try gfc_check_a_xkind (gfc_expr *, gfc_expr *);
gfc_try gfc_check_a_p (gfc_expr *, gfc_expr *);
gfc_try gfc_check_x_yd (gfc_expr *, gfc_expr *);
bool gfc_check_a_ikind (gfc_expr *, gfc_expr *);
bool gfc_check_a_xkind (gfc_expr *, gfc_expr *);
bool gfc_check_a_p (gfc_expr *, gfc_expr *);
bool gfc_check_x_yd (gfc_expr *, gfc_expr *);
gfc_try gfc_check_abs (gfc_expr *);
gfc_try gfc_check_access_func (gfc_expr *, gfc_expr *);
gfc_try gfc_check_achar (gfc_expr *, gfc_expr *);
gfc_try gfc_check_all_any (gfc_expr *, gfc_expr *);
gfc_try gfc_check_allocated (gfc_expr *);
gfc_try gfc_check_associated (gfc_expr *, gfc_expr *);
gfc_try gfc_check_atan_2 (gfc_expr *, gfc_expr *);
gfc_try gfc_check_atan2 (gfc_expr *, gfc_expr *);
gfc_try gfc_check_atomic_def (gfc_expr *, gfc_expr *);
gfc_try gfc_check_atomic_ref (gfc_expr *, gfc_expr *);
gfc_try gfc_check_besn (gfc_expr *, gfc_expr *);
gfc_try gfc_check_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_bge_bgt_ble_blt (gfc_expr *, gfc_expr *);
gfc_try gfc_check_bitfcn (gfc_expr *, gfc_expr *);
gfc_try gfc_check_char (gfc_expr *, gfc_expr *);
gfc_try gfc_check_chdir (gfc_expr *);
gfc_try gfc_check_chmod (gfc_expr *, gfc_expr *);
gfc_try gfc_check_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_complex (gfc_expr *, gfc_expr *);
gfc_try gfc_check_count (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_cshift (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_ctime (gfc_expr *);
gfc_try gfc_check_datan2 (gfc_expr *, gfc_expr *);
gfc_try gfc_check_dcmplx (gfc_expr *, gfc_expr *);
gfc_try gfc_check_dble (gfc_expr *);
gfc_try gfc_check_digits (gfc_expr *);
gfc_try gfc_check_dot_product (gfc_expr *, gfc_expr *);
gfc_try gfc_check_dprod (gfc_expr *, gfc_expr *);
gfc_try gfc_check_dshift (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_dtime_etime (gfc_expr *);
gfc_try gfc_check_fgetputc (gfc_expr *, gfc_expr *);
gfc_try gfc_check_fgetput (gfc_expr *);
gfc_try gfc_check_float (gfc_expr *);
gfc_try gfc_check_fstat (gfc_expr *, gfc_expr *);
gfc_try gfc_check_ftell (gfc_expr *);
gfc_try gfc_check_fn_c (gfc_expr *);
gfc_try gfc_check_fn_d (gfc_expr *);
gfc_try gfc_check_fn_r (gfc_expr *);
gfc_try gfc_check_fn_rc (gfc_expr *);
gfc_try gfc_check_fn_rc2008 (gfc_expr *);
gfc_try gfc_check_fnum (gfc_expr *);
gfc_try gfc_check_hostnm (gfc_expr *);
gfc_try gfc_check_huge (gfc_expr *);
gfc_try gfc_check_hypot (gfc_expr *, gfc_expr *);
gfc_try gfc_check_i (gfc_expr *);
gfc_try gfc_check_iand (gfc_expr *, gfc_expr *);
gfc_try gfc_check_and (gfc_expr *, gfc_expr *);
gfc_try gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_ichar_iachar (gfc_expr *, gfc_expr *);
gfc_try gfc_check_idnint (gfc_expr *);
gfc_try gfc_check_ieor (gfc_expr *, gfc_expr *);
gfc_try gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_int (gfc_expr *, gfc_expr *);
gfc_try gfc_check_intconv (gfc_expr *);
gfc_try gfc_check_ior (gfc_expr *, gfc_expr *);
gfc_try gfc_check_irand (gfc_expr *);
gfc_try gfc_check_isatty (gfc_expr *);
gfc_try gfc_check_isnan (gfc_expr *);
gfc_try gfc_check_ishft (gfc_expr *, gfc_expr *);
gfc_try gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_kill (gfc_expr *, gfc_expr *);
gfc_try gfc_check_kind (gfc_expr *);
gfc_try gfc_check_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_lcobound (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_len_lentrim (gfc_expr *, gfc_expr *);
gfc_try gfc_check_link (gfc_expr *, gfc_expr *);
gfc_try gfc_check_lge_lgt_lle_llt (gfc_expr *, gfc_expr *);
gfc_try gfc_check_loc (gfc_expr *);
gfc_try gfc_check_logical (gfc_expr *, gfc_expr *);
gfc_try gfc_check_min_max (gfc_actual_arglist *);
gfc_try gfc_check_min_max_integer (gfc_actual_arglist *);
gfc_try gfc_check_min_max_real (gfc_actual_arglist *);
gfc_try gfc_check_min_max_double (gfc_actual_arglist *);
gfc_try gfc_check_malloc (gfc_expr *);
gfc_try gfc_check_mask (gfc_expr *, gfc_expr *);
gfc_try gfc_check_matmul (gfc_expr *, gfc_expr *);
gfc_try gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_minloc_maxloc (gfc_actual_arglist *);
gfc_try gfc_check_minval_maxval (gfc_actual_arglist *);
gfc_try gfc_check_nearest (gfc_expr *, gfc_expr *);
gfc_try gfc_check_new_line (gfc_expr *);
gfc_try gfc_check_norm2 (gfc_expr *, gfc_expr *);
gfc_try gfc_check_null (gfc_expr *);
gfc_try gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_parity (gfc_expr *, gfc_expr *);
gfc_try gfc_check_precision (gfc_expr *);
gfc_try gfc_check_present (gfc_expr *);
gfc_try gfc_check_product_sum (gfc_actual_arglist *);
gfc_try gfc_check_radix (gfc_expr *);
gfc_try gfc_check_rand (gfc_expr *);
gfc_try gfc_check_range (gfc_expr *);
gfc_try gfc_check_rank (gfc_expr *);
gfc_try gfc_check_real (gfc_expr *, gfc_expr *);
gfc_try gfc_check_rename (gfc_expr *, gfc_expr *);
gfc_try gfc_check_repeat (gfc_expr *, gfc_expr *);
gfc_try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_same_type_as (gfc_expr *, gfc_expr *);
gfc_try gfc_check_scale (gfc_expr *, gfc_expr *);
gfc_try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_second_sub (gfc_expr *);
gfc_try gfc_check_secnds (gfc_expr *);
gfc_try gfc_check_selected_char_kind (gfc_expr *);
gfc_try gfc_check_selected_int_kind (gfc_expr *);
gfc_try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_set_exponent (gfc_expr *, gfc_expr *);
gfc_try gfc_check_shape (gfc_expr *, gfc_expr *);
gfc_try gfc_check_shift (gfc_expr *, gfc_expr *);
gfc_try gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_sign (gfc_expr *, gfc_expr *);
gfc_try gfc_check_signal (gfc_expr *, gfc_expr *);
gfc_try gfc_check_sizeof (gfc_expr *);
gfc_try gfc_check_c_associated (gfc_expr *, gfc_expr *);
gfc_try gfc_check_c_f_pointer (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_c_f_procpointer (gfc_expr *, gfc_expr *);
gfc_try gfc_check_c_funloc (gfc_expr *);
gfc_try gfc_check_c_loc (gfc_expr *);
gfc_try gfc_check_c_sizeof (gfc_expr *);
gfc_try gfc_check_sngl (gfc_expr *);
gfc_try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_srand (gfc_expr *);
gfc_try gfc_check_stat (gfc_expr *, gfc_expr *);
gfc_try gfc_check_storage_size (gfc_expr *, gfc_expr *);
gfc_try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_symlnk (gfc_expr *, gfc_expr *);
gfc_try gfc_check_transf_bit_intrins (gfc_actual_arglist *);
gfc_try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_transpose (gfc_expr *);
gfc_try gfc_check_trim (gfc_expr *);
gfc_try gfc_check_ttynam (gfc_expr *);
gfc_try gfc_check_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_ucobound (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_umask (gfc_expr *);
gfc_try gfc_check_unlink (gfc_expr *);
gfc_try gfc_check_unpack (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_x (gfc_expr *);
bool gfc_check_abs (gfc_expr *);
bool gfc_check_access_func (gfc_expr *, gfc_expr *);
bool gfc_check_achar (gfc_expr *, gfc_expr *);
bool gfc_check_all_any (gfc_expr *, gfc_expr *);
bool gfc_check_allocated (gfc_expr *);
bool gfc_check_associated (gfc_expr *, gfc_expr *);
bool gfc_check_atan_2 (gfc_expr *, gfc_expr *);
bool gfc_check_atan2 (gfc_expr *, gfc_expr *);
bool gfc_check_atomic_def (gfc_expr *, gfc_expr *);
bool gfc_check_atomic_ref (gfc_expr *, gfc_expr *);
bool gfc_check_besn (gfc_expr *, gfc_expr *);
bool gfc_check_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_bge_bgt_ble_blt (gfc_expr *, gfc_expr *);
bool gfc_check_bitfcn (gfc_expr *, gfc_expr *);
bool gfc_check_char (gfc_expr *, gfc_expr *);
bool gfc_check_chdir (gfc_expr *);
bool gfc_check_chmod (gfc_expr *, gfc_expr *);
bool gfc_check_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_complex (gfc_expr *, gfc_expr *);
bool gfc_check_count (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_cshift (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_ctime (gfc_expr *);
bool gfc_check_datan2 (gfc_expr *, gfc_expr *);
bool gfc_check_dcmplx (gfc_expr *, gfc_expr *);
bool gfc_check_dble (gfc_expr *);
bool gfc_check_digits (gfc_expr *);
bool gfc_check_dot_product (gfc_expr *, gfc_expr *);
bool gfc_check_dprod (gfc_expr *, gfc_expr *);
bool gfc_check_dshift (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_dtime_etime (gfc_expr *);
bool gfc_check_fgetputc (gfc_expr *, gfc_expr *);
bool gfc_check_fgetput (gfc_expr *);
bool gfc_check_float (gfc_expr *);
bool gfc_check_fstat (gfc_expr *, gfc_expr *);
bool gfc_check_ftell (gfc_expr *);
bool gfc_check_fn_c (gfc_expr *);
bool gfc_check_fn_d (gfc_expr *);
bool gfc_check_fn_r (gfc_expr *);
bool gfc_check_fn_rc (gfc_expr *);
bool gfc_check_fn_rc2008 (gfc_expr *);
bool gfc_check_fnum (gfc_expr *);
bool gfc_check_hostnm (gfc_expr *);
bool gfc_check_huge (gfc_expr *);
bool gfc_check_hypot (gfc_expr *, gfc_expr *);
bool gfc_check_i (gfc_expr *);
bool gfc_check_iand (gfc_expr *, gfc_expr *);
bool gfc_check_and (gfc_expr *, gfc_expr *);
bool gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_ichar_iachar (gfc_expr *, gfc_expr *);
bool gfc_check_idnint (gfc_expr *);
bool gfc_check_ieor (gfc_expr *, gfc_expr *);
bool gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_int (gfc_expr *, gfc_expr *);
bool gfc_check_intconv (gfc_expr *);
bool gfc_check_ior (gfc_expr *, gfc_expr *);
bool gfc_check_irand (gfc_expr *);
bool gfc_check_isatty (gfc_expr *);
bool gfc_check_isnan (gfc_expr *);
bool gfc_check_ishft (gfc_expr *, gfc_expr *);
bool gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_kill (gfc_expr *, gfc_expr *);
bool gfc_check_kind (gfc_expr *);
bool gfc_check_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_lcobound (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_len_lentrim (gfc_expr *, gfc_expr *);
bool gfc_check_link (gfc_expr *, gfc_expr *);
bool gfc_check_lge_lgt_lle_llt (gfc_expr *, gfc_expr *);
bool gfc_check_loc (gfc_expr *);
bool gfc_check_logical (gfc_expr *, gfc_expr *);
bool gfc_check_min_max (gfc_actual_arglist *);
bool gfc_check_min_max_integer (gfc_actual_arglist *);
bool gfc_check_min_max_real (gfc_actual_arglist *);
bool gfc_check_min_max_double (gfc_actual_arglist *);
bool gfc_check_malloc (gfc_expr *);
bool gfc_check_mask (gfc_expr *, gfc_expr *);
bool gfc_check_matmul (gfc_expr *, gfc_expr *);
bool gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_minloc_maxloc (gfc_actual_arglist *);
bool gfc_check_minval_maxval (gfc_actual_arglist *);
bool gfc_check_nearest (gfc_expr *, gfc_expr *);
bool gfc_check_new_line (gfc_expr *);
bool gfc_check_norm2 (gfc_expr *, gfc_expr *);
bool gfc_check_null (gfc_expr *);
bool gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_parity (gfc_expr *, gfc_expr *);
bool gfc_check_precision (gfc_expr *);
bool gfc_check_present (gfc_expr *);
bool gfc_check_product_sum (gfc_actual_arglist *);
bool gfc_check_radix (gfc_expr *);
bool gfc_check_rand (gfc_expr *);
bool gfc_check_range (gfc_expr *);
bool gfc_check_rank (gfc_expr *);
bool gfc_check_real (gfc_expr *, gfc_expr *);
bool gfc_check_rename (gfc_expr *, gfc_expr *);
bool gfc_check_repeat (gfc_expr *, gfc_expr *);
bool gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_same_type_as (gfc_expr *, gfc_expr *);
bool gfc_check_scale (gfc_expr *, gfc_expr *);
bool gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_second_sub (gfc_expr *);
bool gfc_check_secnds (gfc_expr *);
bool gfc_check_selected_char_kind (gfc_expr *);
bool gfc_check_selected_int_kind (gfc_expr *);
bool gfc_check_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_set_exponent (gfc_expr *, gfc_expr *);
bool gfc_check_shape (gfc_expr *, gfc_expr *);
bool gfc_check_shift (gfc_expr *, gfc_expr *);
bool gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_sign (gfc_expr *, gfc_expr *);
bool gfc_check_signal (gfc_expr *, gfc_expr *);
bool gfc_check_sizeof (gfc_expr *);
bool gfc_check_c_associated (gfc_expr *, gfc_expr *);
bool gfc_check_c_f_pointer (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_c_f_procpointer (gfc_expr *, gfc_expr *);
bool gfc_check_c_funloc (gfc_expr *);
bool gfc_check_c_loc (gfc_expr *);
bool gfc_check_c_sizeof (gfc_expr *);
bool gfc_check_sngl (gfc_expr *);
bool gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_srand (gfc_expr *);
bool gfc_check_stat (gfc_expr *, gfc_expr *);
bool gfc_check_storage_size (gfc_expr *, gfc_expr *);
bool gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_symlnk (gfc_expr *, gfc_expr *);
bool gfc_check_transf_bit_intrins (gfc_actual_arglist *);
bool gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_transpose (gfc_expr *);
bool gfc_check_trim (gfc_expr *);
bool gfc_check_ttynam (gfc_expr *);
bool gfc_check_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_ucobound (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_umask (gfc_expr *);
bool gfc_check_unlink (gfc_expr *);
bool gfc_check_unpack (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_x (gfc_expr *);
/* Intrinsic subroutines. */
gfc_try gfc_check_alarm_sub (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_chdir_sub (gfc_expr *, gfc_expr *);
gfc_try gfc_check_chmod_sub (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_cpu_time (gfc_expr *);
gfc_try gfc_check_ctime_sub (gfc_expr *, gfc_expr *);
gfc_try gfc_check_system_clock (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_date_and_time (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_exit (gfc_expr *);
gfc_try gfc_check_fdate_sub (gfc_expr *);
gfc_try gfc_check_flush (gfc_expr *);
gfc_try gfc_check_free (gfc_expr *);
gfc_try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_gerror (gfc_expr *);
gfc_try gfc_check_getarg (gfc_expr *, gfc_expr *);
gfc_try gfc_check_getlog (gfc_expr *);
gfc_try gfc_check_move_alloc (gfc_expr *, gfc_expr *);
gfc_try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
bool gfc_check_alarm_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_chdir_sub (gfc_expr *, gfc_expr *);
bool gfc_check_chmod_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_cpu_time (gfc_expr *);
bool gfc_check_ctime_sub (gfc_expr *, gfc_expr *);
bool gfc_check_system_clock (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_date_and_time (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_exit (gfc_expr *);
bool gfc_check_fdate_sub (gfc_expr *);
bool gfc_check_flush (gfc_expr *);
bool gfc_check_free (gfc_expr *);
bool gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_gerror (gfc_expr *);
bool gfc_check_getarg (gfc_expr *, gfc_expr *);
bool gfc_check_getlog (gfc_expr *);
bool gfc_check_move_alloc (gfc_expr *, gfc_expr *);
bool gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
gfc_try gfc_check_random_number (gfc_expr *);
gfc_try gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_dtime_etime_sub (gfc_expr *, gfc_expr *);
gfc_try gfc_check_fgetputc_sub (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_fgetput_sub (gfc_expr *, gfc_expr *);
gfc_try gfc_check_fseek_sub (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_ftell_sub (gfc_expr *, gfc_expr *);
gfc_try gfc_check_getcwd_sub (gfc_expr *, gfc_expr *);
gfc_try gfc_check_hostnm_sub (gfc_expr *, gfc_expr *);
gfc_try gfc_check_image_index (gfc_expr *, gfc_expr *);
gfc_try gfc_check_itime_idate (gfc_expr *);
gfc_try gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_ltime_gmtime (gfc_expr *, gfc_expr *);
gfc_try gfc_check_perror (gfc_expr *);
gfc_try gfc_check_rename_sub (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_link_sub (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_symlnk_sub (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_sleep_sub (gfc_expr *);
gfc_try gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_system_sub (gfc_expr *, gfc_expr *);
gfc_try gfc_check_this_image (gfc_expr *, gfc_expr *);
gfc_try gfc_check_ttynam_sub (gfc_expr *, gfc_expr *);
gfc_try gfc_check_umask_sub (gfc_expr *, gfc_expr *);
gfc_try gfc_check_unlink_sub (gfc_expr *, gfc_expr *);
bool gfc_check_random_number (gfc_expr *);
bool gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_dtime_etime_sub (gfc_expr *, gfc_expr *);
bool gfc_check_fgetputc_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_fgetput_sub (gfc_expr *, gfc_expr *);
bool gfc_check_fseek_sub (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_ftell_sub (gfc_expr *, gfc_expr *);
bool gfc_check_getcwd_sub (gfc_expr *, gfc_expr *);
bool gfc_check_hostnm_sub (gfc_expr *, gfc_expr *);
bool gfc_check_image_index (gfc_expr *, gfc_expr *);
bool gfc_check_itime_idate (gfc_expr *);
bool gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_ltime_gmtime (gfc_expr *, gfc_expr *);
bool gfc_check_perror (gfc_expr *);
bool gfc_check_rename_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_link_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_symlnk_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_sleep_sub (gfc_expr *);
bool gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_system_sub (gfc_expr *, gfc_expr *);
bool gfc_check_this_image (gfc_expr *, gfc_expr *);
bool gfc_check_ttynam_sub (gfc_expr *, gfc_expr *);
bool gfc_check_umask_sub (gfc_expr *, gfc_expr *);
bool gfc_check_unlink_sub (gfc_expr *, gfc_expr *);
/* Simplification functions. */

317
gcc/fortran/io.c
View File

@ -100,7 +100,7 @@ static const io_tag
static gfc_dt *current_dt;
#define RESOLVE_TAG(x, y) if (resolve_tag(x, y) == FAILURE) return FAILURE;
#define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false;
/**************** Fortran 95 FORMAT parser *****************/
@ -452,15 +452,15 @@ format_lex (void)
c = next_char_not_space (&error);
if (c == 'P')
{
if (gfc_notify_std (GFC_STD_F2003, "DP format "
"specifier not allowed at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "DP format "
"specifier not allowed at %C"))
return FMT_ERROR;
token = FMT_DP;
}
else if (c == 'C')
{
if (gfc_notify_std (GFC_STD_F2003, "DC format "
"specifier not allowed at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "DC format "
"specifier not allowed at %C"))
return FMT_ERROR;
token = FMT_DC;
}
@ -545,7 +545,7 @@ token_to_string (format_token t)
by itself, and we are checking it for validity. The dual origin
means that the warning message is a little less than great. */
static gfc_try
static bool
check_format (bool is_input)
{
const char *posint_required = _("Positive width required");
@ -559,13 +559,13 @@ check_format (bool is_input)
format_token t, u;
int level;
int repeat;
gfc_try rv;
bool rv;
use_last_char = 0;
saved_token = FMT_NONE;
level = 0;
repeat = 0;
rv = SUCCESS;
rv = true;
format_string_pos = 0;
t = format_lex ();
@ -648,10 +648,9 @@ format_item_1:
/* X requires a prior number if we're being pedantic. */
if (mode != MODE_FORMAT)
format_locus.nextc += format_string_pos;
if (gfc_notify_std (GFC_STD_GNU, "X descriptor "
"requires leading space count at %L", &format_locus)
== FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_GNU, "X descriptor requires leading "
"space count at %L", &format_locus))
return false;
goto between_desc;
case FMT_SIGN:
@ -678,9 +677,8 @@ format_item_1:
if (t == FMT_ERROR)
goto fail;
if (gfc_notify_std (GFC_STD_GNU, "$ descriptor at %L",
&format_locus) == FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_GNU, "$ descriptor at %L", &format_locus))
return false;
if (t != FMT_RPAREN || level > 0)
{
gfc_warning ("$ should be the last specifier in format at %L",
@ -825,9 +823,9 @@ data_desc:
error = zero_width;
goto syntax;
}
if (gfc_notify_std (GFC_STD_F2008, "'G0' in "
"format at %L", &format_locus) == FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_F2008, "'G0' in format at %L",
&format_locus))
return false;
u = format_lex ();
if (u != FMT_PERIOD)
{
@ -1058,9 +1056,8 @@ between_desc:
default:
if (mode != MODE_FORMAT)
format_locus.nextc += format_string_pos - 1;
if (gfc_notify_std (GFC_STD_GNU, "Missing comma at %L",
&format_locus) == FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus))
return false;
/* If we do not actually return a failure, we need to unwind this
before the next round. */
if (mode != MODE_FORMAT)
@ -1121,9 +1118,8 @@ extension_optional_comma:
default:
if (mode != MODE_FORMAT)
format_locus.nextc += format_string_pos;
if (gfc_notify_std (GFC_STD_GNU, "Missing comma at %L",
&format_locus) == FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus))
return false;
/* If we do not actually return a failure, we need to unwind this
before the next round. */
if (mode != MODE_FORMAT)
@ -1142,7 +1138,7 @@ syntax:
else
gfc_error ("%s in format string at %L", error, &format_locus);
fail:
rv = FAILURE;
rv = false;
finished:
return rv;
@ -1152,13 +1148,13 @@ finished:
/* Given an expression node that is a constant string, see if it looks
like a format string. */
static gfc_try
static bool
check_format_string (gfc_expr *e, bool is_input)
{
gfc_try rv;
bool rv;
int i;
if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
return SUCCESS;
return true;
mode = MODE_STRING;
format_string = e->value.character.string;
@ -1172,7 +1168,7 @@ check_format_string (gfc_expr *e, bool is_input)
string, like '(A10,I3)F5'
start at the end and move back to the last character processed,
spaces are OK */
if (rv == SUCCESS && e->value.character.length > format_string_pos)
if (rv && e->value.character.length > format_string_pos)
for (i=e->value.character.length-1;i>format_string_pos-1;i--)
if (e->value.character.string[i] != ' ')
{
@ -1215,7 +1211,7 @@ gfc_match_format (void)
start = gfc_current_locus;
if (check_format (false) == FAILURE)
if (!check_format (false))
return MATCH_ERROR;
if (gfc_match_eos () != MATCH_YES)
@ -1366,7 +1362,7 @@ match_ltag (const io_tag *tag, gfc_st_label ** label)
return MATCH_ERROR;
}
if (gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
if (!gfc_reference_st_label (*label, ST_LABEL_TARGET))
return MATCH_ERROR;
return m;
@ -1375,7 +1371,7 @@ match_ltag (const io_tag *tag, gfc_st_label ** label)
/* Resolution of the FORMAT tag, to be called from resolve_tag. */
static gfc_try
static bool
resolve_tag_format (const gfc_expr *e)
{
if (e->expr_type == EXPR_CONSTANT
@ -1384,7 +1380,7 @@ resolve_tag_format (const gfc_expr *e)
{
gfc_error ("Constant expression in FORMAT tag at %L must be "
"of type default CHARACTER", &e->where);
return FAILURE;
return false;
}
/* If e's rank is zero and e is not an element of an array, it should be
@ -1402,75 +1398,74 @@ resolve_tag_format (const gfc_expr *e)
{
gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER "
"or of INTEGER", &e->where);
return FAILURE;
return false;
}
else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
{
if (gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED "
"variable in FORMAT tag at %L", &e->where)
== FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED variable in "
"FORMAT tag at %L", &e->where))
return false;
if (e->symtree->n.sym->attr.assign != 1)
{
gfc_error ("Variable '%s' at %L has not been assigned a "
"format label", e->symtree->n.sym->name, &e->where);
return FAILURE;
return false;
}
}
else if (e->ts.type == BT_INTEGER)
{
gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
"variable", gfc_basic_typename (e->ts.type), &e->where);
return FAILURE;
return false;
}
return SUCCESS;
return true;
}
/* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
It may be assigned an Hollerith constant. */
if (e->ts.type != BT_CHARACTER)
{
if (gfc_notify_std (GFC_STD_LEGACY, "Non-character "
"in FORMAT tag at %L", &e->where) == FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag "
"at %L", &e->where))
return false;
if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
{
gfc_error ("Non-character assumed shape array element in FORMAT"
" tag at %L", &e->where);
return FAILURE;
return false;
}
if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
{
gfc_error ("Non-character assumed size array element in FORMAT"
" tag at %L", &e->where);
return FAILURE;
return false;
}
if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
{
gfc_error ("Non-character pointer array element in FORMAT tag at %L",
&e->where);
return FAILURE;
return false;
}
}
return SUCCESS;
return true;
}
/* Do expression resolution and type-checking on an expression tag. */
static gfc_try
static bool
resolve_tag (const io_tag *tag, gfc_expr *e)
{
if (e == NULL)
return SUCCESS;
return true;
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
if (!gfc_resolve_expr (e))
return false;
if (tag == &tag_format)
return resolve_tag_format (e);
@ -1479,51 +1474,48 @@ resolve_tag (const io_tag *tag, gfc_expr *e)
{
gfc_error ("%s tag at %L must be of type %s", tag->name,
&e->where, gfc_basic_typename (tag->type));
return FAILURE;
return false;
}
if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind)
{
gfc_error ("%s tag at %L must be a character string of default kind",
tag->name, &e->where);
return FAILURE;
return false;
}
if (e->rank != 0)
{
gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
return FAILURE;
return false;
}
if (tag == &tag_iomsg)
{
if (gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L",
&e->where) == FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where))
return false;
}
if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
&& e->ts.kind != gfc_default_integer_kind)
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
"INTEGER in %s tag at %L", tag->name, &e->where)
== FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
"INTEGER in %s tag at %L", tag->name, &e->where))
return false;
}
if (tag == &tag_exist && e->ts.kind != gfc_default_logical_kind)
{
if (gfc_notify_std (GFC_STD_F2008, "Nondefault LOGICAL "
"in %s tag at %L", tag->name, &e->where)
== FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_F2008, "Nondefault LOGICAL "
"in %s tag at %L", tag->name, &e->where))
return false;
}
if (tag == &tag_newunit)
{
if (gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier"
" at %L", &e->where) == FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L",
&e->where))
return false;
}
/* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
@ -1533,18 +1525,17 @@ resolve_tag (const io_tag *tag, gfc_expr *e)
char context[64];
sprintf (context, _("%s tag"), tag->name);
if (gfc_check_vardef_context (e, false, false, false, context) == FAILURE)
return FAILURE;
if (!gfc_check_vardef_context (e, false, false, false, context))
return false;
}
if (tag == &tag_convert)
{
if (gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L",
&e->where) == FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where))
return false;
}
return SUCCESS;
return true;
}
@ -1657,7 +1648,7 @@ gfc_free_open (gfc_open *open)
/* Resolve everything in a gfc_open structure. */
gfc_try
bool
gfc_resolve_open (gfc_open *open)
{
@ -1682,10 +1673,10 @@ gfc_resolve_open (gfc_open *open)
RESOLVE_TAG (&tag_convert, open->convert);
RESOLVE_TAG (&tag_newunit, open->newunit);
if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET))
return false;
return SUCCESS;
return true;
}
@ -1895,8 +1886,8 @@ gfc_match_open (void)
/* Checks on the ASYNCHRONOUS specifier. */
if (open->asynchronous)
{
if (gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %C "
"not allowed in Fortran 95") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %C "
"not allowed in Fortran 95"))
goto cleanup;
if (open->asynchronous->expr_type == EXPR_CONSTANT)
@ -1913,8 +1904,8 @@ gfc_match_open (void)
/* Checks on the BLANK specifier. */
if (open->blank)
{
if (gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
"not allowed in Fortran 95") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
"not allowed in Fortran 95"))
goto cleanup;
if (open->blank->expr_type == EXPR_CONSTANT)
@ -1931,8 +1922,8 @@ gfc_match_open (void)
/* Checks on the DECIMAL specifier. */
if (open->decimal)
{
if (gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
"not allowed in Fortran 95") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
"not allowed in Fortran 95"))
goto cleanup;
if (open->decimal->expr_type == EXPR_CONSTANT)
@ -1963,8 +1954,8 @@ gfc_match_open (void)
/* Checks on the ENCODING specifier. */
if (open->encoding)
{
if (gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C "
"not allowed in Fortran 95") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C "
"not allowed in Fortran 95"))
goto cleanup;
if (open->encoding->expr_type == EXPR_CONSTANT)
@ -2014,8 +2005,8 @@ gfc_match_open (void)
/* Checks on the ROUND specifier. */
if (open->round)
{
if (gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
"not allowed in Fortran 95") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
"not allowed in Fortran 95"))
goto cleanup;
if (open->round->expr_type == EXPR_CONSTANT)
@ -2034,8 +2025,8 @@ gfc_match_open (void)
/* Checks on the SIGN specifier. */
if (open->sign)
{
if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
"not allowed in Fortran 95") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
"not allowed in Fortran 95"))
goto cleanup;
if (open->sign->expr_type == EXPR_CONSTANT)
@ -2282,7 +2273,7 @@ cleanup:
/* Resolve everything in a gfc_close structure. */
gfc_try
bool
gfc_resolve_close (gfc_close *close)
{
RESOLVE_TAG (&tag_unit, close->unit);
@ -2290,8 +2281,8 @@ gfc_resolve_close (gfc_close *close)
RESOLVE_TAG (&tag_iostat, close->iostat);
RESOLVE_TAG (&tag_status, close->status);
if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET))
return false;
if (close->unit == NULL)
{
@ -2308,7 +2299,7 @@ gfc_resolve_close (gfc_close *close)
loc = close->err->where;
gfc_error ("CLOSE statement at %L requires a UNIT number", &loc);
return FAILURE;
return false;
}
if (close->unit->expr_type == EXPR_CONSTANT
@ -2319,7 +2310,7 @@ gfc_resolve_close (gfc_close *close)
&close->unit->where);
}
return SUCCESS;
return true;
}
@ -2435,14 +2426,14 @@ cleanup:
}
gfc_try
bool
gfc_resolve_filepos (gfc_filepos *fp)
{
RESOLVE_TAG (&tag_unit, fp->unit);
RESOLVE_TAG (&tag_iostat, fp->iostat);
RESOLVE_TAG (&tag_iomsg, fp->iomsg);
if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET))
return false;
if (fp->unit->expr_type == EXPR_CONSTANT
&& fp->unit->ts.type == BT_INTEGER
@ -2452,7 +2443,7 @@ gfc_resolve_filepos (gfc_filepos *fp)
&fp->unit->where);
}
return SUCCESS;
return true;
}
@ -2480,8 +2471,7 @@ gfc_match_rewind (void)
match
gfc_match_flush (void)
{
if (gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C")
== FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C"))
return MATCH_ERROR;
return match_filepos (ST_FLUSH, EXEC_FLUSH);
@ -2583,7 +2573,7 @@ match_dt_format (gfc_dt *dt)
goto conflict;
}
if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
if (!gfc_reference_st_label (label, ST_LABEL_FORMAT))
return MATCH_ERROR;
dt->format_label = label;
@ -2785,7 +2775,7 @@ gfc_free_dt (gfc_dt *dt)
/* Resolve everything in a gfc_dt structure. */
gfc_try
bool
gfc_resolve_dt (gfc_dt *dt, locus *loc)
{
gfc_expr *e;
@ -2815,10 +2805,10 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
if (e == NULL)
{
gfc_error ("UNIT not specified at %L", loc);
return FAILURE;
return false;
}
if (gfc_resolve_expr (e) == SUCCESS
if (gfc_resolve_expr (e)
&& (e->ts.type != BT_INTEGER
&& (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
{
@ -2828,7 +2818,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
{
gfc_error ("UNIT specification at %L must be an INTEGER expression "
"or a CHARACTER variable", &e->where);
return FAILURE;
return false;
}
else
{
@ -2850,7 +2840,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
{
gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
&dt->extra_comma->where);
return FAILURE;
return false;
}
}
}
@ -2860,21 +2850,21 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
if (gfc_has_vector_index (e))
{
gfc_error ("Internal unit with vector subscript at %L", &e->where);
return FAILURE;
return false;
}
/* If we are writing, make sure the internal unit can be changed. */
gcc_assert (k != M_PRINT);
if (k == M_WRITE
&& gfc_check_vardef_context (e, false, false, false,
_("internal unit in WRITE")) == FAILURE)
return FAILURE;
&& !gfc_check_vardef_context (e, false, false, false,
_("internal unit in WRITE")))
return false;
}
if (e->rank && e->ts.type != BT_CHARACTER)
{
gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
return FAILURE;
return false;
}
if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
@ -2882,7 +2872,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
{
gfc_error ("UNIT number in statement at %L must be non-negative",
&e->where);
return FAILURE;
return false;
}
/* If we are reading and have a namelist, check that all namelist symbols
@ -2893,61 +2883,61 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
for (n = dt->namelist->namelist; n; n = n->next)
{
gfc_expr* e;
gfc_try t;
bool t;
e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
t = gfc_check_vardef_context (e, false, false, false, NULL);
gfc_free_expr (e);
if (t == FAILURE)
if (!t)
{
gfc_error ("NAMELIST '%s' in READ statement at %L contains"
" the symbol '%s' which may not appear in a"
" variable definition context",
dt->namelist->name, loc, n->sym->name);
return FAILURE;
return false;
}
}
}
if (dt->extra_comma
&& gfc_notify_std (GFC_STD_GNU, "Comma before i/o "
"item list at %L", &dt->extra_comma->where) == FAILURE)
return FAILURE;
&& !gfc_notify_std (GFC_STD_GNU, "Comma before i/o item list at %L",
&dt->extra_comma->where))
return false;
if (dt->err)
{
if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET))
return false;
if (dt->err->defined == ST_LABEL_UNKNOWN)
{
gfc_error ("ERR tag label %d at %L not defined",
dt->err->value, &dt->err_where);
return FAILURE;
return false;
}
}
if (dt->end)
{
if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET))
return false;
if (dt->end->defined == ST_LABEL_UNKNOWN)
{
gfc_error ("END tag label %d at %L not defined",
dt->end->value, &dt->end_where);
return FAILURE;
return false;
}
}
if (dt->eor)
{
if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET))
return false;
if (dt->eor->defined == ST_LABEL_UNKNOWN)
{
gfc_error ("EOR tag label %d at %L not defined",
dt->eor->value, &dt->eor_where);
return FAILURE;
return false;
}
}
@ -2957,10 +2947,10 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
{
gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
&dt->format_label->where);
return FAILURE;
return false;
}
return SUCCESS;
return true;
}
@ -3257,9 +3247,8 @@ if (condition) \
if (dt->namelist != NULL)
{
if (gfc_notify_std (GFC_STD_F2003, "Internal file "
"at %L with namelist", &expr->where)
== FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with "
"namelist", &expr->where))
m = MATCH_ERROR;
}
@ -3313,7 +3302,7 @@ if (condition) \
{
static const char * asynchronous[] = { "YES", "NO", NULL };
if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS)
if (!gfc_reduce_init_expr (dt->asynchronous))
{
gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
"expression", &dt->asynchronous->where);
@ -3341,8 +3330,8 @@ if (condition) \
if (dt->decimal)
{
if (gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
"not allowed in Fortran 95") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
"not allowed in Fortran 95"))
return MATCH_ERROR;
if (dt->decimal->expr_type == EXPR_CONSTANT)
@ -3362,8 +3351,8 @@ if (condition) \
if (dt->blank)
{
if (gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
"not allowed in Fortran 95") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
"not allowed in Fortran 95"))
return MATCH_ERROR;
if (dt->blank->expr_type == EXPR_CONSTANT)
@ -3383,8 +3372,8 @@ if (condition) \
if (dt->pad)
{
if (gfc_notify_std (GFC_STD_F2003, "PAD= at %C "
"not allowed in Fortran 95") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %C "
"not allowed in Fortran 95"))
return MATCH_ERROR;
if (dt->pad->expr_type == EXPR_CONSTANT)
@ -3404,8 +3393,8 @@ if (condition) \
if (dt->round)
{
if (gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
"not allowed in Fortran 95") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
"not allowed in Fortran 95"))
return MATCH_ERROR;
if (dt->round->expr_type == EXPR_CONSTANT)
@ -3425,7 +3414,7 @@ if (condition) \
{
/* When implemented, change the following to use gfc_notify_std F2003.
if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
"not allowed in Fortran 95") == FAILURE)
"not allowed in Fortran 95") == false)
return MATCH_ERROR; */
if (dt->sign->expr_type == EXPR_CONSTANT)
{
@ -3449,8 +3438,8 @@ if (condition) \
if (dt->delim)
{
if (gfc_notify_std (GFC_STD_F2003, "DELIM= at %C "
"not allowed in Fortran 95") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %C "
"not allowed in Fortran 95"))
return MATCH_ERROR;
if (dt->delim->expr_type == EXPR_CONSTANT)
@ -3557,8 +3546,8 @@ if (condition) \
}
expr = dt->format_expr;
if (gfc_simplify_expr (expr, 0) == FAILURE
|| check_format_string (expr, k == M_READ) == FAILURE)
if (!gfc_simplify_expr (expr, 0)
|| !check_format_string (expr, k == M_READ))
return MATCH_ERROR;
return m;
@ -3598,8 +3587,8 @@ match_io (io_kind k)
gfc_find_symbol (name, NULL, 1, &sym);
if (sym && sym->attr.flavor == FL_NAMELIST)
{
if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
"%C is an extension") == FAILURE)
if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
"%C is an extension"))
{
m = MATCH_ERROR;
goto cleanup;
@ -4048,7 +4037,7 @@ cleanup:
/* Resolve everything in a gfc_inquire structure. */
gfc_try
bool
gfc_resolve_inquire (gfc_inquire *inquire)
{
RESOLVE_TAG (&tag_unit, inquire->unit);
@ -4064,8 +4053,8 @@ gfc_resolve_inquire (gfc_inquire *inquire)
char context[64]; \
sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
if (gfc_check_vardef_context ((expr), false, false, false, \
context) == FAILURE) \
return FAILURE; \
context) == false) \
return false; \
}
INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
@ -4104,10 +4093,10 @@ gfc_resolve_inquire (gfc_inquire *inquire)
INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream);
#undef INQUIRE_RESOLVE_TAG
if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET))
return false;
return SUCCESS;
return true;
}
@ -4125,7 +4114,7 @@ gfc_free_wait (gfc_wait *wait)
}
gfc_try
bool
gfc_resolve_wait (gfc_wait *wait)
{
RESOLVE_TAG (&tag_unit, wait->unit);
@ -4133,13 +4122,13 @@ gfc_resolve_wait (gfc_wait *wait)
RESOLVE_TAG (&tag_iostat, wait->iostat);
RESOLVE_TAG (&tag_id, wait->id);
if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET))
return false;
if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET))
return false;
return SUCCESS;
return true;
}
/* Match an element of a WAIT statement. */
@ -4202,8 +4191,8 @@ gfc_match_wait (void)
goto syntax;
}
if (gfc_notify_std (GFC_STD_F2003, "WAIT at %C "
"not allowed in Fortran 95") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C "
"not allowed in Fortran 95"))
goto cleanup;
if (gfc_pure (NULL))

181
gcc/fortran/match.c
View File

@ -505,8 +505,8 @@ gfc_match_label (void)
return MATCH_ERROR;
}
if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
gfc_new_block->name, NULL) == FAILURE)
if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
gfc_new_block->name, NULL))
return MATCH_ERROR;
return MATCH_YES;
@ -531,7 +531,7 @@ gfc_match_name (char *buffer)
c = gfc_next_ascii_char ();
if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
{
if (gfc_error_flag_test() == 0 && c != '(')
if (gfc_error_flag_test () == 0 && c != '(')
gfc_error ("Invalid character in name at %C");
gfc_current_locus = old_loc;
return MATCH_NO;
@ -1268,7 +1268,7 @@ gfc_match_program (void)
if (m == MATCH_ERROR)
return m;
if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
if (!gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL))
return MATCH_ERROR;
gfc_new_block = sym;
@ -1383,16 +1383,15 @@ match_arithmetic_if (void)
if (m != MATCH_YES)
return m;
if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
|| gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
|| gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
|| !gfc_reference_st_label (l2, ST_LABEL_TARGET)
|| !gfc_reference_st_label (l3, ST_LABEL_TARGET))
{
gfc_free_expr (expr);
return MATCH_ERROR;
}
if (gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF "
"statement at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF statement at %C"))
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
@ -1464,16 +1463,15 @@ gfc_match_if (gfc_statement *if_type)
return MATCH_ERROR;
}
if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
|| gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
|| gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
|| !gfc_reference_st_label (l2, ST_LABEL_TARGET)
|| !gfc_reference_st_label (l3, ST_LABEL_TARGET))
{
gfc_free_expr (expr);
return MATCH_ERROR;
}
if (gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF "
"statement at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF statement at %C"))
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
@ -1539,7 +1537,7 @@ gfc_match_if (gfc_statement *if_type)
restore between tries. */
#define match(string, subr, statement) \
if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
gfc_clear_error ();
@ -1746,7 +1744,7 @@ gfc_match_critical (void)
return MATCH_ERROR;
}
if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
if (gfc_find_state (COMP_DO_CONCURRENT))
{
gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
"block");
@ -1756,8 +1754,7 @@ gfc_match_critical (void)
if (gfc_implicit_pure (NULL))
gfc_current_ns->proc_name->attr.implicit_pure = 0;
if (gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C")
== FAILURE)
if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C"))
return MATCH_ERROR;
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
@ -1766,7 +1763,7 @@ gfc_match_critical (void)
return MATCH_ERROR;
}
if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
if (gfc_find_state (COMP_CRITICAL))
{
gfc_error ("Nested CRITICAL block at %C");
return MATCH_ERROR;
@ -1775,7 +1772,7 @@ gfc_match_critical (void)
new_st.op = EXEC_CRITICAL;
if (label != NULL
&& gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
&& !gfc_reference_st_label (label, ST_LABEL_TARGET))
return MATCH_ERROR;
return MATCH_YES;
@ -2380,8 +2377,7 @@ gfc_match_do (void)
gfc_forall_iterator *head;
gfc_expr *mask;
if (gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT "
"construct at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C"))
return MATCH_ERROR;
@ -2398,7 +2394,7 @@ gfc_match_do (void)
goto concurr_cleanup;
if (label != NULL
&& gfc_reference_st_label (label, ST_LABEL_DO_TARGET) == FAILURE)
&& !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
goto concurr_cleanup;
new_st.label1 = label;
@ -2452,7 +2448,7 @@ concurr_cleanup:
done:
if (label != NULL
&& gfc_reference_st_label (label, ST_LABEL_DO_TARGET) == FAILURE)
&& !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
goto cleanup;
new_st.label1 = label;
@ -2579,8 +2575,8 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
return MATCH_ERROR;
}
gcc_assert (op == EXEC_EXIT);
if (gfc_notify_std (GFC_STD_F2008, "EXIT statement with no"
" do-construct-name at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no"
" do-construct-name at %C"))
return MATCH_ERROR;
break;
@ -2686,12 +2682,12 @@ gfc_match_stopcode (gfc_statement st)
if (gfc_implicit_pure (NULL))
gfc_current_ns->proc_name->attr.implicit_pure = 0;
if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
if (st == ST_STOP && gfc_find_state (COMP_CRITICAL))
{
gfc_error ("Image control statement STOP at %C in CRITICAL block");
goto cleanup;
}
if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT))
{
gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
goto cleanup;
@ -2770,9 +2766,7 @@ gfc_match_pause (void)
m = gfc_match_stopcode (ST_PAUSE);
if (m == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement"
" at %C")
== FAILURE)
if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C"))
m = MATCH_ERROR;
}
return m;
@ -2793,8 +2787,7 @@ gfc_match_stop (void)
match
gfc_match_error_stop (void)
{
if (gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C")
== FAILURE)
if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C"))
return MATCH_ERROR;
return gfc_match_stopcode (ST_ERROR_STOP);
@ -2833,14 +2826,14 @@ lock_unlock_statement (gfc_statement st)
return MATCH_ERROR;
}
if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
if (gfc_find_state (COMP_CRITICAL))
{
gfc_error ("Image control statement %s at %C in CRITICAL block",
st == ST_LOCK ? "LOCK" : "UNLOCK");
return MATCH_ERROR;
}
if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
if (gfc_find_state (COMP_DO_CONCURRENT))
{
gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
st == ST_LOCK ? "LOCK" : "UNLOCK");
@ -2979,8 +2972,7 @@ cleanup:
match
gfc_match_lock (void)
{
if (gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C")
== FAILURE)
if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C"))
return MATCH_ERROR;
return lock_unlock_statement (ST_LOCK);
@ -2990,8 +2982,7 @@ gfc_match_lock (void)
match
gfc_match_unlock (void)
{
if (gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C")
== FAILURE)
if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C"))
return MATCH_ERROR;
return lock_unlock_statement (ST_UNLOCK);
@ -3023,8 +3014,7 @@ sync_statement (gfc_statement st)
if (gfc_implicit_pure (NULL))
gfc_current_ns->proc_name->attr.implicit_pure = 0;
if (gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C")
== FAILURE)
if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C"))
return MATCH_ERROR;
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
@ -3033,13 +3023,13 @@ sync_statement (gfc_statement st)
return MATCH_ERROR;
}
if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
if (gfc_find_state (COMP_CRITICAL))
{
gfc_error ("Image control statement SYNC at %C in CRITICAL block");
return MATCH_ERROR;
}
if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
if (gfc_find_state (COMP_DO_CONCURRENT))
{
gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
return MATCH_ERROR;
@ -3217,13 +3207,11 @@ gfc_match_assign (void)
if (gfc_match (" %l", &label) == MATCH_YES)
{
if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN))
return MATCH_ERROR;
if (gfc_match (" to %v%t", &expr) == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN "
"statement at %C")
== FAILURE)
if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C"))
return MATCH_ERROR;
expr->symtree->n.sym->attr.assign = 1;
@ -3255,7 +3243,7 @@ gfc_match_goto (void)
if (gfc_match (" %l%t", &label) == MATCH_YES)
{
if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
return MATCH_ERROR;
new_st.op = EXEC_GOTO;
@ -3267,9 +3255,7 @@ gfc_match_goto (void)
if (gfc_match_variable (&expr, 0) == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO "
"statement at %C")
== FAILURE)
if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C"))
return MATCH_ERROR;
new_st.op = EXEC_GOTO;
@ -3293,7 +3279,7 @@ gfc_match_goto (void)
if (m != MATCH_YES)
goto syntax;
if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
goto cleanup;
if (head == NULL)
@ -3338,7 +3324,7 @@ gfc_match_goto (void)
if (m != MATCH_YES)
goto syntax;
if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
goto cleanup;
if (head == NULL)
@ -3377,8 +3363,7 @@ gfc_match_goto (void)
if (gfc_match (" %e%t", &expr) != MATCH_YES)
goto syntax;
if (gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO "
"at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C"))
return MATCH_ERROR;
/* At this point, a computed GOTO has been fully matched and an
@ -3460,8 +3445,8 @@ gfc_match_allocate (void)
{
if (gfc_match (" :: ") == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F2003, "typespec in "
"ALLOCATE at %L", &old_locus) == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
&old_locus))
goto cleanup;
if (ts.deferred)
@ -3516,8 +3501,8 @@ gfc_match_allocate (void)
deferred_locus = tail->expr->where;
}
if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS
|| gfc_find_state (COMP_CRITICAL) == SUCCESS)
if (gfc_find_state (COMP_DO_CONCURRENT)
|| gfc_find_state (COMP_CRITICAL))
{
gfc_ref *ref;
bool coarray = tail->expr->symtree->n.sym->attr.codimension;
@ -3525,12 +3510,12 @@ gfc_match_allocate (void)
if (ref->type == REF_COMPONENT)
coarray = ref->u.c.component->attr.codimension;
if (coarray && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
if (coarray && gfc_find_state (COMP_DO_CONCURRENT))
{
gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
goto cleanup;
}
if (coarray && gfc_find_state (COMP_CRITICAL) == SUCCESS)
if (coarray && gfc_find_state (COMP_CRITICAL))
{
gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
goto cleanup;
@ -3625,8 +3610,7 @@ alloc_opt_list:
goto cleanup;
if (m == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L",
&tmp->where) == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where))
goto cleanup;
/* Enforce C630. */
@ -3649,8 +3633,7 @@ alloc_opt_list:
goto cleanup;
if (m == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L",
&tmp->where) == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where))
goto cleanup;
/* Enforce C630. */
@ -3669,9 +3652,9 @@ alloc_opt_list:
}
if (head->next
&& gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
" with more than a single allocate object",
&tmp->where) == FAILURE)
&& !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
" with more than a single allocate object",
&tmp->where))
goto cleanup;
source = tmp;
@ -3687,8 +3670,7 @@ alloc_opt_list:
goto cleanup;
if (m == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L",
&tmp->where) == FAILURE)
if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where))
goto cleanup;
/* Check F08:C636. */
@ -3900,14 +3882,14 @@ gfc_match_deallocate (void)
gfc_current_ns->proc_name->attr.implicit_pure = 0;
if (gfc_is_coarray (tail->expr)
&& gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
&& gfc_find_state (COMP_DO_CONCURRENT))
{
gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
goto cleanup;
}
if (gfc_is_coarray (tail->expr)
&& gfc_find_state (COMP_CRITICAL) == SUCCESS)
&& gfc_find_state (COMP_CRITICAL))
{
gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
goto cleanup;
@ -3962,8 +3944,7 @@ dealloc_opt_list:
goto cleanup;
if (m == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L",
&tmp->where) == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where))
goto cleanup;
if (saw_errmsg)
@ -4018,13 +3999,13 @@ gfc_match_return (void)
e = NULL;
if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
if (gfc_find_state (COMP_CRITICAL))
{
gfc_error ("Image control statement RETURN at %C in CRITICAL block");
return MATCH_ERROR;
}
if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
if (gfc_find_state (COMP_DO_CONCURRENT))
{
gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
return MATCH_ERROR;
@ -4033,7 +4014,7 @@ gfc_match_return (void)
if (gfc_match_eos () == MATCH_YES)
goto done;
if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
if (!gfc_find_state (COMP_SUBROUTINE))
{
gfc_error ("Alternate RETURN statement at %C is only allowed within "
"a SUBROUTINE");
@ -4066,8 +4047,8 @@ cleanup:
done:
gfc_enclosing_unit (&s);
if (s == COMP_PROGRAM
&& gfc_notify_std (GFC_STD_GNU, "RETURN statement in "
"main program at %C") == FAILURE)
&& !gfc_notify_std (GFC_STD_GNU, "RETURN statement in "
"main program at %C"))
return MATCH_ERROR;
new_st.op = EXEC_RETURN;
@ -4178,7 +4159,7 @@ gfc_match_call (void)
}
/* ...and then to try to make the symbol into a subroutine. */
if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
return MATCH_ERROR;
}
@ -4231,7 +4212,7 @@ gfc_match_call (void)
if (a->expr != NULL)
continue;
if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET))
continue;
i++;
@ -4450,14 +4431,13 @@ gfc_match_common (void)
if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
|| sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
{
if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
"can only be COMMON in "
"BLOCK DATA", sym->name)
== FAILURE)
if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at "
"%C can only be COMMON in BLOCK DATA",
sym->name))
goto cleanup;
}
if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
if (!gfc_add_in_common (&sym->attr, sym->name, NULL))
goto cleanup;
if (tail != NULL)
@ -4482,7 +4462,7 @@ gfc_match_common (void)
goto cleanup;
}
if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
if (!gfc_add_dimension (&sym->attr, sym->name, NULL))
goto cleanup;
if (sym->attr.pointer)
@ -4584,7 +4564,7 @@ gfc_match_block_data (void)
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL))
return MATCH_ERROR;
gfc_new_block = sym;
@ -4635,15 +4615,14 @@ gfc_match_namelist (void)
if (group_name->attr.flavor == FL_NAMELIST
&& group_name->attr.use_assoc
&& gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
"at %C already is USE associated and can"
"not be respecified.", group_name->name)
== FAILURE)
&& !gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
"at %C already is USE associated and can"
"not be respecified.", group_name->name))
return MATCH_ERROR;
if (group_name->attr.flavor != FL_NAMELIST
&& gfc_add_flavor (&group_name->attr, FL_NAMELIST,
group_name->name, NULL) == FAILURE)
&& !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
group_name->name, NULL))
return MATCH_ERROR;
for (;;)
@ -4655,7 +4634,7 @@ gfc_match_namelist (void)
goto error;
if (sym->attr.in_namelist == 0
&& gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
&& !gfc_add_in_namelist (&sym->attr, sym->name, NULL))
goto error;
/* Use gfc_error_check here, rather than goto error, so that
@ -4721,8 +4700,8 @@ gfc_match_module (void)
if (m != MATCH_YES)
return m;
if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
gfc_new_block->name, NULL) == FAILURE)
if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
gfc_new_block->name, NULL))
return MATCH_ERROR;
return MATCH_YES;
@ -4811,7 +4790,7 @@ gfc_match_equivalence (void)
sym = set->expr->symtree->n.sym;
if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL))
goto cleanup;
if (sym->attr.in_common)
@ -4958,8 +4937,7 @@ gfc_match_st_function (void)
gfc_push_error (&old_error);
if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
sym->name, NULL) == FAILURE)
if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
goto undo_error;
if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
@ -4981,8 +4959,7 @@ gfc_match_st_function (void)
sym->value = expr;
if (gfc_notify_std (GFC_STD_F95_OBS,
"Statement function at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C"))
return MATCH_ERROR;
return MATCH_YES;

8
gcc/fortran/match.h
View File

@ -195,9 +195,9 @@ match gfc_match_volatile (void);
/* Fortran 2003 c interop.
TODO: some of these should be moved to another file rather than decl.c */
void set_com_block_bind_c (gfc_common_head *, int);
gfc_try set_verify_bind_c_sym (gfc_symbol *, int);
gfc_try set_verify_bind_c_com_block (gfc_common_head *, int);
gfc_try get_bind_c_idents (void);
bool set_verify_bind_c_sym (gfc_symbol *, int);
bool set_verify_bind_c_com_block (gfc_common_head *, int);
bool get_bind_c_idents (void);
match gfc_match_bind_c_stmt (void);
match gfc_match_suffix (gfc_symbol *, gfc_symbol **);
match gfc_match_bind_c (gfc_symbol *, bool);
@ -213,7 +213,7 @@ match gfc_match_literal_constant (gfc_expr **, int);
/* expr.c -- FIXME: this one should be eliminated by moving the
matcher to matchexp.c and a call to a new function in expr.c that
only makes sure the init expr. is valid. */
gfc_try gfc_reduce_init_expr (gfc_expr *expr);
bool gfc_reduce_init_expr (gfc_expr *expr);
match gfc_match_init_expr (gfc_expr **);
/* array.c. */

26
gcc/fortran/module.c
View File

@ -555,8 +555,8 @@ gfc_match_use (void)
{
if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F2003, "module "
"nature in USE statement at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "module "
"nature in USE statement at %C"))
goto cleanup;
if (strcmp (module_nature, "intrinsic") == 0)
@ -590,8 +590,7 @@ gfc_match_use (void)
{
m = gfc_match (" ::");
if (m == MATCH_YES &&
gfc_notify_std (GFC_STD_F2003,
"\"USE :: module\" at %C") == FAILURE)
!gfc_notify_std(GFC_STD_F2003, "\"USE :: module\" at %C"))
goto cleanup;
if (m != MATCH_YES)
@ -658,9 +657,8 @@ gfc_match_use (void)
m = gfc_match (" =>");
if (type == INTERFACE_USER_OP && m == MATCH_YES
&& (gfc_notify_std (GFC_STD_F2003, "Renaming "
"operators in USE statements at %C")
== FAILURE))
&& (!gfc_notify_std(GFC_STD_F2003, "Renaming "
"operators in USE statements at %C")))
goto cleanup;
if (type == INTERFACE_USER_OP)
@ -4089,7 +4087,7 @@ load_generic_interfaces (void)
if (st && !sym->attr.generic
&& !st->ambiguous
&& sym->module
&& strcmp(module, sym->module))
&& strcmp (module, sym->module))
{
ambiguous_set = true;
st->ambiguous = 1;
@ -6096,10 +6094,9 @@ use_iso_fortran_env_module (void)
found = true;
u->found = 1;
if (gfc_notify_std (symbol[i].standard, "The symbol '%s', "
"referenced at %L, is not in the selected "
"standard", symbol[i].name,
&u->where) == FAILURE)
if (!gfc_notify_std (symbol[i].standard, "The symbol '%s', "
"referenced at %L, is not in the selected "
"standard", symbol[i].name, &u->where))
continue;
if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
@ -6265,7 +6262,7 @@ gfc_use_module (gfc_use_list *module)
{
if (strcmp (module_name, "iso_fortran_env") == 0
&& gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV "
"intrinsic module at %C") != FAILURE)
"intrinsic module at %C"))
{
use_iso_fortran_env_module ();
free_rename (module->rename);
@ -6276,8 +6273,7 @@ gfc_use_module (gfc_use_list *module)
}
if (strcmp (module_name, "iso_c_binding") == 0
&& gfc_notify_std (GFC_STD_F2003,
"ISO_C_BINDING module at %C") != FAILURE)
&& gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C"))
{
import_iso_c_binding_module();
free_rename (module->rename);

19
gcc/fortran/openmp.c
View File

@ -316,9 +316,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
&& ! sym->attr.intrinsic
&& ! sym->attr.use_assoc
&& ((sym->attr.flavor == FL_UNKNOWN
&& gfc_add_flavor (&sym->attr, FL_PROCEDURE,
sym->name, NULL) == FAILURE)
|| gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
&& !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
|| !gfc_add_intrinsic (&sym->attr, NULL)))
{
gfc_free_omp_clauses (c);
return MATCH_ERROR;
@ -573,8 +572,7 @@ gfc_match_omp_threadprivate (void)
if (sym->attr.in_common)
gfc_error_now ("Threadprivate variable at %C is an element of "
"a COMMON block");
else if (gfc_add_threadprivate (&sym->attr, sym->name,
&sym->declared_at) == FAILURE)
else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
goto cleanup;
goto next_item;
case MATCH_NO:
@ -597,8 +595,7 @@ gfc_match_omp_threadprivate (void)
}
st->n.common->threadprivate = 1;
for (sym = st->n.common->head; sym; sym = sym->common_next)
if (gfc_add_threadprivate (&sym->attr, sym->name,
&sym->declared_at) == FAILURE)
if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
goto cleanup;
next_item:
@ -814,7 +811,7 @@ resolve_omp_clauses (gfc_code *code)
if (omp_clauses->if_expr)
{
gfc_expr *expr = omp_clauses->if_expr;
if (gfc_resolve_expr (expr) == FAILURE
if (!gfc_resolve_expr (expr)
|| expr->ts.type != BT_LOGICAL || expr->rank != 0)
gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
&expr->where);
@ -822,7 +819,7 @@ resolve_omp_clauses (gfc_code *code)
if (omp_clauses->final_expr)
{
gfc_expr *expr = omp_clauses->final_expr;
if (gfc_resolve_expr (expr) == FAILURE
if (!gfc_resolve_expr (expr)
|| expr->ts.type != BT_LOGICAL || expr->rank != 0)
gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
&expr->where);
@ -830,7 +827,7 @@ resolve_omp_clauses (gfc_code *code)
if (omp_clauses->num_threads)
{
gfc_expr *expr = omp_clauses->num_threads;
if (gfc_resolve_expr (expr) == FAILURE
if (!gfc_resolve_expr (expr)
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
gfc_error ("NUM_THREADS clause at %L requires a scalar "
"INTEGER expression", &expr->where);
@ -838,7 +835,7 @@ resolve_omp_clauses (gfc_code *code)
if (omp_clauses->chunk_size)
{
gfc_expr *expr = omp_clauses->chunk_size;
if (gfc_resolve_expr (expr) == FAILURE
if (!gfc_resolve_expr (expr)
|| expr->ts.type != BT_INTEGER || expr->rank != 0)
gfc_error ("SCHEDULE clause's chunk_size at %L requires "
"a scalar INTEGER expression", &expr->where);

62
gcc/fortran/parse.c
View File

@ -100,7 +100,7 @@ use_modules (void)
#define match(keyword, subr, st) \
do { \
if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
return st; \
else \
undo_new_statement (); \
@ -1068,7 +1068,7 @@ pop_state (void)
/* Try to find the given state in the state stack. */
gfc_try
bool
gfc_find_state (gfc_compile_state state)
{
gfc_state_data *p;
@ -1077,7 +1077,7 @@ gfc_find_state (gfc_compile_state state)
if (p->state == state)
break;
return (p == NULL) ? FAILURE : SUCCESS;
return (p == NULL) ? false : true;
}
@ -1763,7 +1763,7 @@ unexpected_statement (gfc_statement st)
/* Given the next statement seen by the matcher, make sure that it is
in proper order with the last. This subroutine is initialized by
calling it with an argument of ST_NONE. If there is a problem, we
issue an error and return FAILURE. Otherwise we return SUCCESS.
issue an error and return false. Otherwise we return true.
Individual parsers need to verify that the statements seen are
valid before calling here, i.e., ENTRY statements are not allowed in
@ -1815,7 +1815,7 @@ typedef struct
}
st_state;
static gfc_try
static bool
verify_st_order (st_state *p, gfc_statement st, bool silent)
{
@ -1897,7 +1897,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
/* All is well, record the statement in case we need it next time. */
p->where = gfc_current_locus;
p->last_statement = st;
return SUCCESS;
return true;
order:
if (!silent)
@ -1905,7 +1905,7 @@ order:
gfc_ascii_statement (st),
gfc_ascii_statement (p->last_statement), &p->where);
return FAILURE;
return false;
}
@ -1977,8 +1977,7 @@ parse_derived_contains (void)
goto error;
case ST_PROCEDURE:
if (gfc_notify_std (GFC_STD_F2003, "Type-bound"
" procedure at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C"))
goto error;
accept_statement (ST_PROCEDURE);
@ -1986,8 +1985,7 @@ parse_derived_contains (void)
break;
case ST_GENERIC:
if (gfc_notify_std (GFC_STD_F2003, "GENERIC binding"
" at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C"))
goto error;
accept_statement (ST_GENERIC);
@ -1995,9 +1993,8 @@ parse_derived_contains (void)
break;
case ST_FINAL:
if (gfc_notify_std (GFC_STD_F2003,
"FINAL procedure declaration"
" at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration"
" at %C"))
goto error;
accept_statement (ST_FINAL);
@ -2008,16 +2005,15 @@ parse_derived_contains (void)
to_finish = true;
if (!seen_comps
&& (gfc_notify_std (GFC_STD_F2008, "Derived type "
"definition at %C with empty CONTAINS "
"section") == FAILURE))
&& (!gfc_notify_std(GFC_STD_F2008, "Derived type definition "
"at %C with empty CONTAINS section")))
goto error;
/* ST_END_TYPE is accepted by parse_derived after return. */
break;
case ST_PRIVATE:
if (gfc_find_state (COMP_MODULE) == FAILURE)
if (!gfc_find_state (COMP_MODULE))
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
"a MODULE");
@ -2120,7 +2116,7 @@ endType:
break;
case ST_PRIVATE:
if (gfc_find_state (COMP_MODULE) == FAILURE)
if (!gfc_find_state (COMP_MODULE))
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
"a MODULE");
@ -2395,8 +2391,8 @@ loop:
gfc_new_block->attr.pointer = 0;
gfc_new_block->attr.proc_pointer = 1;
}
if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
gfc_new_block->formal, NULL) == FAILURE)
if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
gfc_new_block->formal, NULL))
{
reject_statement ();
gfc_free_namespace (gfc_current_ns);
@ -2642,7 +2638,7 @@ loop:
verify_st_order (&dummyss, ST_NONE, false);
verify_st_order (&dummyss, st, false);
if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
verify_now = true;
}
@ -2683,7 +2679,7 @@ loop:
case ST_DERIVED_DECL:
case_decl:
declSt:
if (verify_st_order (&ss, st, false) == FAILURE)
if (!verify_st_order (&ss, st, false))
{
reject_statement ();
st = next_statement ();
@ -3313,14 +3309,14 @@ gfc_build_block_ns (gfc_namespace *parent_ns)
my_ns->proc_name = gfc_new_block;
else
{
gfc_try t;
bool t;
char buffer[20]; /* Enough to hold "block@2147483648\n". */
snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
my_ns->proc_name->name, NULL);
gcc_assert (t == SUCCESS);
gcc_assert (t);
gfc_commit_symbol (my_ns->proc_name);
}
@ -4026,9 +4022,9 @@ parse_contained (int module)
"ambiguous", gfc_new_block->name);
else
{
if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
&gfc_new_block->declared_at) ==
SUCCESS)
if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
sym->name,
&gfc_new_block->declared_at))
{
if (st == ST_FUNCTION)
gfc_add_function (&sym->attr, sym->name,
@ -4174,7 +4170,7 @@ contains:
if (p->state == COMP_CONTAINS)
n++;
if (gfc_find_state (COMP_MODULE) == SUCCESS)
if (gfc_find_state (COMP_MODULE) == true)
n--;
if (n > 0)
@ -4492,7 +4488,7 @@ translate_all_program_units (gfc_namespace *gfc_global_ns_list,
/* Top level parser. */
gfc_try
bool
gfc_parse_file (void)
{
int seen_program, errors_before, errors;
@ -4516,7 +4512,7 @@ gfc_parse_file (void)
gfc_statement_label = NULL;
if (setjmp (eof_buf))
return FAILURE; /* Come here on unexpected EOF */
return false; /* Come here on unexpected EOF */
/* Prepare the global namespace that will contain the
program units. */
@ -4663,7 +4659,7 @@ prog_units:
translate_all_program_units (gfc_global_ns_list, seen_program);
gfc_end_source_files ();
return SUCCESS;
return true;
duplicate_main:
/* If we see a duplicate main program, shut down. If the second
@ -4672,5 +4668,5 @@ duplicate_main:
gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
reject_statement ();
gfc_done_2 ();
return SUCCESS;
return true;
}

2
gcc/fortran/parse.h
View File

@ -60,7 +60,7 @@ extern gfc_state_data *gfc_state_stack;
#define gfc_current_state() (gfc_state_stack->state)
int gfc_check_do_variable (gfc_symtree *);
gfc_try gfc_find_state (gfc_compile_state);
bool gfc_find_state (gfc_compile_state);
gfc_state_data *gfc_enclosing_unit (gfc_compile_state *);
const char *gfc_ascii_statement (gfc_statement);
match gfc_match_enum (void);

115
gcc/fortran/primary.c
View File

@ -267,8 +267,7 @@ match_hollerith_constant (gfc_expr **result)
if (match_integer_constant (&e, 0) == MATCH_YES
&& gfc_match_char ('h') == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant "
"at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C"))
goto cleanup;
msg = gfc_extract_int (e, &num);
@ -391,9 +390,8 @@ match_boz_constant (gfc_expr **result)
goto backup;
if (x_hex
&& (gfc_notify_std (GFC_STD_GNU, "Hexadecimal "
"constant at %C uses non-standard syntax")
== FAILURE))
&& (!gfc_notify_std(GFC_STD_GNU, "Hexadecimal "
"constant at %C uses non-standard syntax")))
return MATCH_ERROR;
old_loc = gfc_current_locus;
@ -430,9 +428,8 @@ match_boz_constant (gfc_expr **result)
goto backup;
}
if (gfc_notify_std (GFC_STD_GNU, "BOZ constant "
"at %C uses non-standard postfix syntax")
== FAILURE)
if (!gfc_notify_std (GFC_STD_GNU, "BOZ constant "
"at %C uses non-standard postfix syntax"))
return MATCH_ERROR;
}
@ -467,9 +464,8 @@ match_boz_constant (gfc_expr **result)
}
if (!gfc_in_match_data ()
&& (gfc_notify_std (GFC_STD_F2003, "BOZ used outside a DATA "
"statement at %C")
== FAILURE))
&& (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA "
"statement at %C")))
return MATCH_ERROR;
*result = e;
@ -558,8 +554,8 @@ match_real_constant (gfc_expr **result, int signflag)
if (c == 'q')
{
if (gfc_notify_std (GFC_STD_GNU, "exponent-letter 'q' in "
"real-literal-constant at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_GNU, "exponent-letter 'q' in "
"real-literal-constant at %C"))
return MATCH_ERROR;
else if (gfc_option.warn_real_q_constant)
gfc_warning("Extension: exponent-letter 'q' in real-literal-constant "
@ -1217,8 +1213,8 @@ match_sym_complex_part (gfc_expr **result)
return MATCH_ERROR;
}
if (gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in "
"complex constant at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in "
"complex constant at %C"))
return MATCH_ERROR;
switch (sym->value->ts.type)
@ -1506,8 +1502,8 @@ match_actual_arg (gfc_expr **result)
if (sym->attr.in_common && !sym->attr.proc_pointer)
{
if (gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
&sym->declared_at) == FAILURE)
if (!gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, &sym->declared_at))
return MATCH_ERROR;
break;
}
@ -1646,8 +1642,7 @@ match_arg_list_function (gfc_actual_arglist *result)
}
}
if (gfc_notify_std (GFC_STD_GNU, "argument list "
"function at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C"))
{
m = MATCH_ERROR;
goto cleanup;
@ -1719,8 +1714,8 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
if (m != MATCH_YES)
goto cleanup;
if (gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
"at %C") == FAILURE)
if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
"at %C"))
goto cleanup;
tail->label = label;
@ -1936,7 +1931,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
for (;;)
{
gfc_try t;
bool t;
gfc_symtree *tbp;
m = gfc_match_name (name);
@ -1954,7 +1949,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
{
gfc_symbol* tbp_sym;
if (t == FAILURE)
if (!t)
return MATCH_ERROR;
gcc_assert (!tail || !tail->next);
@ -2311,7 +2306,7 @@ gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
the order required; this also checks along the way that each and every
component actually has an initializer and handles default initializers
for components without explicit value given. */
static gfc_try
static bool
build_actual_constructor (gfc_structure_ctor_component **comp_head,
gfc_constructor_base *ctor_head, gfc_symbol *sym)
{
@ -2341,11 +2336,12 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
&gfc_current_locus);
value->ts = comp->ts;
if (build_actual_constructor (comp_head, &value->value.constructor,
comp->ts.u.derived) == FAILURE)
if (!build_actual_constructor (comp_head,
&value->value.constructor,
comp->ts.u.derived))
{
gfc_free_expr (value);
return FAILURE;
return false;
}
gfc_constructor_append_expr (ctor_head, value, NULL);
@ -2358,17 +2354,16 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
{
if (comp->initializer)
{
if (gfc_notify_std (GFC_STD_F2003, "Structure"
" constructor with missing optional arguments"
" at %C") == FAILURE)
return FAILURE;
if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
"with missing optional arguments at %C"))
return false;
value = gfc_copy_expr (comp->initializer);
}
else
{
gfc_error ("No initializer for component '%s' given in the"
" structure constructor at %C!", comp->name);
return FAILURE;
return false;
}
}
else
@ -2386,11 +2381,11 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
gfc_free_structure_ctor_component (comp_iter);
}
}
return SUCCESS;
return true;
}
gfc_try
bool
gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
gfc_actual_arglist **arglist,
bool parent)
@ -2434,9 +2429,8 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
}
if (actual->name)
{
if (gfc_notify_std (GFC_STD_F2003, "Structure"
" constructor with named arguments at %C")
== FAILURE)
if (!gfc_notify_std (GFC_STD_F2003, "Structure"
" constructor with named arguments at %C"))
goto cleanup;
comp_tail->name = xstrdup (actual->name);
@ -2519,7 +2513,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
||
comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
{
gfc_try m;
bool m;
gfc_actual_arglist *arg_null = NULL;
actual->expr = comp_tail->val;
@ -2529,7 +2523,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
comp->ts.u.derived, &comp_tail->val,
comp->ts.u.derived->attr.zero_comp
? &arg_null : &actual, true);
if (m == FAILURE)
if (!m)
goto cleanup;
if (comp->ts.u.derived->attr.zero_comp)
@ -2547,7 +2541,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
actual = actual->next;
}
if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
if (!build_actual_constructor (&comp_head, &ctor_head, sym))
goto cleanup;
/* No component should be left, as this should have caused an error in the
@ -2585,7 +2579,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
gfc_current_locus = old_locus;
if (parent)
*arglist = actual;
return SUCCESS;
return true;
cleanup:
gfc_current_locus = old_locus;
@ -2598,7 +2592,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
}
gfc_constructor_free (ctor_head);
return FAILURE;
return false;
}
@ -2627,8 +2621,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
return m;
}
if (gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false)
!= SUCCESS)
if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false))
{
gfc_free_expr (e);
return MATCH_ERROR;
@ -2664,7 +2657,7 @@ check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
/* Procedure pointer as function result: Replace the function symbol by the
auto-generated hidden result variable named "ppr@". */
static gfc_try
static bool
replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
{
/* Check for procedure pointer result variable. */
@ -2679,9 +2672,9 @@ replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
(*sym)->result->attr.referenced = (*sym)->attr.referenced;
*sym = (*sym)->result;
*st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
return SUCCESS;
return true;
}
return FAILURE;
return false;
}
@ -2708,7 +2701,7 @@ gfc_match_rvalue (gfc_expr **result)
if (m != MATCH_YES)
return m;
if (gfc_find_state (COMP_INTERFACE) == SUCCESS
if (gfc_find_state (COMP_INTERFACE)
&& !gfc_current_ns->has_import_set)
i = gfc_get_sym_tree (name, NULL, &symtree, false);
else
@ -2854,8 +2847,7 @@ gfc_match_rvalue (gfc_expr **result)
m = gfc_match_varspec (e, 0, false, true);
if (!e->ref && sym->attr.flavor == FL_UNKNOWN
&& sym->ts.type == BT_UNKNOWN
&& gfc_add_flavor (&sym->attr, FL_PROCEDURE,
sym->name, NULL) == FAILURE)
&& !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
{
m = MATCH_ERROR;
break;
@ -2930,7 +2922,7 @@ gfc_match_rvalue (gfc_expr **result)
e->rank = sym->as->rank;
if (!sym->attr.function
&& gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
&& !gfc_add_function (&sym->attr, sym->name, NULL))
{
m = MATCH_ERROR;
break;
@ -2977,8 +2969,7 @@ gfc_match_rvalue (gfc_expr **result)
if (sym->attr.dimension || sym->attr.codimension)
{
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE)
if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
{
m = MATCH_ERROR;
break;
@ -2995,8 +2986,7 @@ gfc_match_rvalue (gfc_expr **result)
&& (CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.codimension))
{
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE)
if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
{
m = MATCH_ERROR;
break;
@ -3021,8 +3011,7 @@ gfc_match_rvalue (gfc_expr **result)
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE)
if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
{
m = MATCH_ERROR;
break;
@ -3069,15 +3058,15 @@ gfc_match_rvalue (gfc_expr **result)
e->expr_type = EXPR_VARIABLE;
if (sym->attr.flavor != FL_VARIABLE
&& gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE)
&& !gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL))
{
m = MATCH_ERROR;
break;
}
if (sym->ts.type == BT_UNKNOWN
&& gfc_set_default_type (sym, 1, NULL) == FAILURE)
&& !gfc_set_default_type (sym, 1, NULL))
{
m = MATCH_ERROR;
break;
@ -3098,7 +3087,7 @@ gfc_match_rvalue (gfc_expr **result)
e->expr_type = EXPR_FUNCTION;
if (!sym->attr.function
&& gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
&& !gfc_add_function (&sym->attr, sym->name, NULL))
{
m = MATCH_ERROR;
break;
@ -3233,7 +3222,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
flavor = FL_VARIABLE;
if (flavor != FL_UNKNOWN
&& gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
&& !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL))
return MATCH_ERROR;
}
break;
@ -3269,7 +3258,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
}
if (sym->attr.proc_pointer
|| replace_hidden_procptr_result (&sym, &st) == SUCCESS)
|| replace_hidden_procptr_result (&sym, &st))
break;
/* Fall through to error */

1726
gcc/fortran/resolve.c
View File

File diff suppressed because it is too large Load Diff

26
gcc/fortran/scanner.c
View File

@ -326,7 +326,7 @@ add_path_to_list (gfc_directorylist **list, const char *path,
q = (char *) alloca (len + 1);
memcpy (q, p, len + 1);
i = len - 1;
while (i >=0 && IS_DIR_SEPARATOR(q[i]))
while (i >=0 && IS_DIR_SEPARATOR (q[i]))
q[i--] = '\0';
if (stat (q, &st))
@ -1123,7 +1123,7 @@ restart:
else
gfc_advance_line ();
if (gfc_at_eof())
if (gfc_at_eof ())
goto not_continuation;
/* We've got a continuation line. If we are on the very next line after
@ -1831,7 +1831,7 @@ preprocessor_line (gfc_char_t *c)
}
static gfc_try load_file (const char *, const char *, bool);
static bool load_file (const char *, const char *, bool);
/* include_line()-- Checks a line buffer to see if it is an include
line. If so, we call load_file() recursively to load the included
@ -1902,7 +1902,7 @@ include_line (gfc_char_t *line)
read by anything else. */
filename = gfc_widechar_to_char (begin, -1);
if (load_file (filename, NULL, false) == FAILURE)
if (!load_file (filename, NULL, false))
exit (FATAL_EXIT_CODE);
free (filename);
@ -1912,7 +1912,7 @@ include_line (gfc_char_t *line)
/* Load a file into memory by calling load_line until the file ends. */
static gfc_try
static bool
load_file (const char *realfilename, const char *displayedname, bool initial)
{
gfc_char_t *line;
@ -1936,7 +1936,7 @@ load_file (const char *realfilename, const char *displayedname, bool initial)
fprintf (stderr, "%s:%d: Error: File '%s' is being included "
"recursively\n", current_file->filename, current_file->line,
filename);
return FAILURE;
return false;
}
if (initial)
@ -1951,7 +1951,7 @@ load_file (const char *realfilename, const char *displayedname, bool initial)
if (input == NULL)
{
gfc_error_now ("Can't open file '%s'", filename);
return FAILURE;
return false;
}
}
else
@ -1961,7 +1961,7 @@ load_file (const char *realfilename, const char *displayedname, bool initial)
{
fprintf (stderr, "%s:%d: Error: Can't open included file '%s'\n",
current_file->filename, current_file->line, filename);
return FAILURE;
return false;
}
}
@ -2096,19 +2096,19 @@ load_file (const char *realfilename, const char *displayedname, bool initial)
add_file_change (NULL, current_file->inclusion_line + 1);
current_file = current_file->up;
linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
return SUCCESS;
return true;
}
/* Open a new file and start scanning from that file. Returns SUCCESS
if everything went OK, FAILURE otherwise. If form == FORM_UNKNOWN
/* Open a new file and start scanning from that file. Returns true
if everything went OK, false otherwise. If form == FORM_UNKNOWN
it tries to determine the source form from the filename, defaulting
to free form. */
gfc_try
bool
gfc_new_file (void)
{
gfc_try result;
bool result;
if (gfc_cpp_enabled ())
{

37
gcc/fortran/simplify.c
View File

@ -3263,7 +3263,7 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
gcc_assert (array->expr_type == EXPR_VARIABLE);
gcc_assert (as);
if (gfc_resolve_array_spec (as, 0) == FAILURE)
if (!gfc_resolve_array_spec (as, 0))
return NULL;
/* The last dimension of an assumed-size array is special. */
@ -3313,8 +3313,7 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
{
if (upper)
{
if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer, NULL)
!= SUCCESS)
if (!gfc_ref_dimen_size (&ref->u.ar, d - 1, &result->value.integer, NULL))
goto returnNull;
}
else
@ -4078,7 +4077,7 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
case BT_CHARACTER:
#define LENGTH(x) ((x)->value.character.length)
#define STRING(x) ((x)->value.character.string)
if (LENGTH(extremum) < LENGTH(arg))
if (LENGTH (extremum) < LENGTH(arg))
{
gfc_char_t *tmp = STRING(extremum);
@ -4629,10 +4628,10 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
gfc_expr *result;
gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
if (!is_constant_array_expr(array)
|| !is_constant_array_expr(vector)
if (!is_constant_array_expr (array)
|| !is_constant_array_expr (vector)
|| (!gfc_is_constant_expr (mask)
&& !is_constant_array_expr(mask)))
&& !is_constant_array_expr (mask)))
return NULL;
result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
@ -5506,7 +5505,7 @@ gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
gfc_expr *result, *e, *f;
gfc_array_ref *ar;
int n;
gfc_try t;
bool t;
int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
if (source->rank == -1)
@ -5524,7 +5523,7 @@ gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
}
else if (source->shape)
{
t = SUCCESS;
t = true;
for (n = 0; n < source->rank; n++)
{
mpz_init (shape[n]);
@ -5532,13 +5531,13 @@ gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
}
}
else
t = FAILURE;
t = false;
for (n = 0; n < source->rank; n++)
{
e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
if (t == SUCCESS)
if (t)
{
mpz_set (e->value.integer, shape[n]);
mpz_clear (shape[n]);
@ -5631,7 +5630,7 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
if (dim == NULL)
{
if (gfc_array_size (array, &size) == FAILURE)
if (!gfc_array_size (array, &size))
return NULL;
}
else
@ -5640,7 +5639,7 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
return NULL;
d = mpz_get_ui (dim->value.integer) - 1;
if (gfc_array_dimen_size (array, d, &size) == FAILURE)
if (!gfc_array_dimen_size (array, d, &size))
return NULL;
}
@ -5668,7 +5667,7 @@ gfc_simplify_sizeof (gfc_expr *x)
return NULL;
if (x->rank && x->expr_type != EXPR_ARRAY
&& gfc_array_size (x, &array_size) == FAILURE)
&& !gfc_array_size (x, &array_size))
return NULL;
result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
@ -5897,7 +5896,7 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp
constructor. */
if (source->expr_type == EXPR_ARRAY)
{
if (gfc_array_size (source, &size) == FAILURE)
if (!gfc_array_size (source, &size))
gfc_internal_error ("Failure getting length of a constant array.");
}
else
@ -6123,13 +6122,13 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
|| !gfc_is_constant_expr (size))
return NULL;
if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
&result_size, &result_length) == FAILURE)
if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
&result_size, &result_length))
return NULL;
/* Calculate the size of the source. */
if (source->expr_type == EXPR_ARRAY
&& gfc_array_size (source, &tmp) == FAILURE)
&& !gfc_array_size (source, &tmp))
gfc_internal_error ("Failure getting length of a constant array.");
/* Create an empty new expression with the appropriate characteristics. */
@ -6395,7 +6394,7 @@ gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
if (!is_constant_array_expr (vector)
|| !is_constant_array_expr (mask)
|| (!gfc_is_constant_expr (field)
&& !is_constant_array_expr(field)))
&& !is_constant_array_expr (field)))
return NULL;
result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,

523
gcc/fortran/symbol.c
View File

File diff suppressed because it is too large Load Diff

4
gcc/fortran/trans-array.c
View File

@ -7582,7 +7582,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
comp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
tmp = gfc_trans_dealloc_allocated (comp,
CLASS_DATA (c)->attr.codimension);
else
@ -7647,7 +7647,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tmp = CLASS_DATA (c)->backend_decl;
comp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
else
{

10
gcc/fortran/trans-intrinsic.c
View File

@ -2192,9 +2192,9 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
minmax (a1, a2, a3, ...)
{
mvar = a1;
if (a2 .op. mvar || isnan(mvar))
if (a2 .op. mvar || isnan (mvar))
mvar = a2;
if (a3 .op. mvar || isnan(mvar))
if (a3 .op. mvar || isnan (mvar))
mvar = a3;
...
return mvar
@ -2749,7 +2749,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
if (norm2)
{
/* if (x(i) != 0.0)
/* if (x (i) != 0.0)
{
absX = abs(x(i))
if (absX > scale)
@ -3104,7 +3104,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
else
{
mpz_t asize;
if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
if (gfc_array_size (arrayexpr, &asize))
{
nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
mpz_clear (asize);
@ -3594,7 +3594,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
else
{
mpz_t asize;
if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
if (gfc_array_size (arrayexpr, &asize))
{
nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
mpz_clear (asize);

10
gcc/fortran/trans-openmp.c
View File

@ -500,7 +500,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
tree decl, backend_decl, stmt, type, outer_decl;
locus old_loc = gfc_current_locus;
const char *iname;
gfc_try t;
bool t;
decl = OMP_CLAUSE_DECL (c);
gfc_current_locus = where;
@ -562,7 +562,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
ref->u.ar.type = AR_FULL;
ref->u.ar.dimen = 0;
t = gfc_resolve_expr (e1);
gcc_assert (t == SUCCESS);
gcc_assert (t);
e2 = gfc_get_expr ();
e2->expr_type = EXPR_VARIABLE;
@ -570,12 +570,12 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
e2->symtree = symtree2;
e2->ts = sym->ts;
t = gfc_resolve_expr (e2);
gcc_assert (t == SUCCESS);
gcc_assert (t);
e3 = gfc_copy_expr (e1);
e3->symtree = symtree3;
t = gfc_resolve_expr (e3);
gcc_assert (t == SUCCESS);
gcc_assert (t);
iname = NULL;
switch (OMP_CLAUSE_REDUCTION_CODE (c))
@ -647,7 +647,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
e1 = gfc_copy_expr (e1);
e3 = gfc_copy_expr (e3);
t = gfc_resolve_expr (e4);
gcc_assert (t == SUCCESS);
gcc_assert (t);
/* Create the init statement list. */
pushlevel ();

18
gcc/fortran/trans-stmt.c
View File

@ -2661,7 +2661,7 @@ check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
return need_temp;
new_symtree = NULL;
if (find_forall_index (c->expr1, lsym, 2) == SUCCESS)
if (find_forall_index (c->expr1, lsym, 2))
{
forall_make_variable_temp (c, pre, post);
need_temp = 0;
@ -4757,21 +4757,21 @@ gfc_trans_where (gfc_code * code)
are the same. In short, this is VERY conservative and this
is needed because the two loops, required by the standard
are coalesced in gfc_trans_where_3. */
if (!gfc_check_dependency(cblock->next->expr1,
if (!gfc_check_dependency (cblock->next->expr1,
cblock->expr1, 0)
&& !gfc_check_dependency(eblock->next->expr1,
&& !gfc_check_dependency (eblock->next->expr1,
cblock->expr1, 0)
&& !gfc_check_dependency(cblock->next->expr1,
&& !gfc_check_dependency (cblock->next->expr1,
eblock->next->expr2, 1)
&& !gfc_check_dependency(eblock->next->expr1,
&& !gfc_check_dependency (eblock->next->expr1,
cblock->next->expr2, 1)
&& !gfc_check_dependency(cblock->next->expr1,
&& !gfc_check_dependency (cblock->next->expr1,
cblock->next->expr2, 1)
&& !gfc_check_dependency(eblock->next->expr1,
&& !gfc_check_dependency (eblock->next->expr1,
eblock->next->expr2, 1)
&& !gfc_check_dependency(cblock->next->expr1,
&& !gfc_check_dependency (cblock->next->expr1,
eblock->next->expr1, 0)
&& !gfc_check_dependency(eblock->next->expr1,
&& !gfc_check_dependency (eblock->next->expr1,
cblock->next->expr1, 0))
return gfc_trans_where_3 (cblock, eblock);
}

6
gcc/fortran/trans-types.c
View File

@ -132,7 +132,7 @@ int gfc_numeric_storage_size;
int gfc_character_storage_size;
gfc_try
bool
gfc_check_any_c_kind (gfc_typespec *ts)
{
int i;
@ -144,10 +144,10 @@ gfc_check_any_c_kind (gfc_typespec *ts)
Fortran kind being used exists in at least some form for C. */
if (c_interop_kinds_table[i].f90_type == ts->type &&
c_interop_kinds_table[i].value == ts->kind)
return SUCCESS;
return true;
}
return FAILURE;
return false;
}