Introduce a new predicate to simplify conditionals checking for
a character type whose length is the constant one.
gcc/fortran/ChangeLog:
* gfortran.h (gfc_length_one_character_type_p): New inline
function.
* check.cc (is_c_interoperable): Use
gfc_length_one_character_type_p.
* decl.cc (verify_bind_c_sym): Same.
* trans-expr.cc (gfc_conv_procedure_call): Same.
---
gcc/fortran/check.cc | 7 +++----
gcc/fortran/decl.cc | 4 +---
gcc/fortran/gfortran.h | 15 +++++++++++++++
gcc/fortran/trans-expr.cc | 8 ++------
4 files changed, 21 insertions(+), 13 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 4086dc71d34..6c45e6542f0 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -5250,10 +5250,9 @@ is_c_interoperable (gfc_expr *expr, const char **msg,
bool c_loc, bool c_f_ptr)
&& !gfc_simplify_expr (expr->ts.u.cl->length, 0))
gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed");
- if (!c_loc && expr->ts.u.cl
- && (!expr->ts.u.cl->length
- || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
- || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0))
+ if (!c_loc
+ && expr->ts.u.cl
+ && !gfc_length_one_character_type_p (&expr->ts))
{
*msg = "Type shall have a character length of 1";
return false;
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 844345df77e..8182ef29f43 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -6064,9 +6064,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
/* BIND(C) functions cannot return a character string. */
if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
- if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
- || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
- || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
+ if (!gfc_length_one_character_type_p (&tmp_sym->ts))
gfc_error ("Return type of BIND(C) function %qs of character "
"type at %L must have length 1", tmp_sym->name,
&(tmp_sym->declared_at));
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6482a885211..d44e5286626 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3181,6 +3181,21 @@ gfc_finalizer;
/************************ Function prototypes *************************/
+
+/* Returns true if the type specified in TS is a character type whose length
+ is the constant one. Otherwise returns false. */
+
+inline bool
+gfc_length_one_character_type_p (gfc_typespec *ts)
+{
+ return ts->type == BT_CHARACTER
+ && ts->u.cl
+ && ts->u.cl->length
+ && ts->u.cl->length->expr_type == EXPR_CONSTANT
+ && ts->u.cl->length->ts.type == BT_INTEGER
+ && mpz_cmp_ui (ts->u.cl->length->value.integer, 1) == 0;
+}
+
/* decl.cc */
bool gfc_in_match_data (void);
match gfc_match_char_spec (gfc_typespec *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ef3e6d08f78..6da3975f77c 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6453,12 +6453,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
dummy arguments are actually passed by value.
Strings are truncated to length 1.
The BIND(C) case is handled elsewhere. */
- if (fsym->ts.type == BT_CHARACTER
- && !fsym->ts.is_c_interop
- && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT
- && fsym->ts.u.cl->length->ts.type == BT_INTEGER
- && (mpz_cmp_ui
- (fsym->ts.u.cl->length->value.integer, 1) == 0))
+ if (!fsym->ts.is_c_interop
+ && gfc_length_one_character_type_p (&fsym->ts))
{
if (e->expr_type != EXPR_CONSTANT)
{
--
2.40.1
