diff mbox series

[1/3] fortran: New predicate gfc_length_one_character_type_p

Message ID 20230809202122.695376-2-mikael@gcc.gnu.org
State Unresolved
Headers
Series fortran: fix length one character dummy args [PR110419] |

Checks

Context Check Description
snail/gcc-patch-check warning Git am fail log

Commit Message

Mikael Morin Aug. 9, 2023, 8:21 p.m. UTC 
  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 mbox series

Patch

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)
 			  {