fortran: New predicate gfc_length_one_character_type_p

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.

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 4086dc71d340beb8fd0f4cf37f29028f04ba8e06..6c45e6542f04441cf86a4be544ed2f42a04a8be8 100644 (file)
--- 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 844345df77e98b6ac49641b47cf876e6fedfc238..8182ef29f43ff06eb822512dd7404279ee8bacca 100644 (file)
--- 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 9a00e6dea6f1f91077d2dc8a2c4ce37c79c93788..fd47000a88efd00640ab3d43324f50c0614ddd59 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3182,6 +3182,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 764565476af2dd5db4e81a6fb4e6ded976d40019..9c73b7e478598de460ce05cdae7550b57dc75999 100644 (file)
--- 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)
                          {