1 files changed, 225 insertions, 56 deletions

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 299c216..1f17013 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -1107,6 +1107,36 @@ kind_value_check (gfc_expr *e, int n, int k)
 }
 
 
+/* Error message for an actual argument with an unsupported kind value.  */
+
+static void
+error_unsupported_kind (gfc_expr *e, int n)
+{
+  gfc_error ("Not supported: %qs argument of %qs intrinsic at %L with kind %d",
+	     gfc_current_intrinsic_arg[n]->name,
+	     gfc_current_intrinsic, &e->where, e->ts.kind);
+  return;
+}
+
+
+/* Check if the decimal exponent range of an integer variable is at least four
+   so that it is large enough to e.g. hold errno values and the values of
+   LIBERROR_* from libgfortran.h.  */
+
+static bool
+check_minrange4 (gfc_expr *e, int n)
+{
+  if (e->ts.kind >= 2)
+    return true;
+
+  gfc_error ("%qs argument of %qs intrinsic at %L must have "
+	     "a decimal exponent range of at least four",
+	     gfc_current_intrinsic_arg[n]->name,
+	     gfc_current_intrinsic, &e->where);
+  return false;
+}
+
+
 /* Make sure an expression is a variable.  */
 
 static bool
@@ -5559,6 +5589,27 @@ gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
   return true;
 }
 
+bool
+gfc_check_split (gfc_expr *string, gfc_expr *set, gfc_expr *pos, gfc_expr *back)
+{
+  if (!type_check (string, 0, BT_CHARACTER))
+    return false;
+
+  if (!type_check (set, 1, BT_CHARACTER))
+    return false;
+
+  if (!type_check (pos, 2, BT_INTEGER) || !scalar_check (pos, 2))
+    return false;
+
+  if (back != NULL
+      && (!type_check (back, 3, BT_LOGICAL) || !scalar_check (back, 3)))
+    return false;
+
+  if (!same_type_check (string, 0, set, 1))
+    return false;
+
+  return true;
+}
 
 bool
 gfc_check_secnds (gfc_expr *r)
@@ -5952,44 +6003,116 @@ gfc_check_c_sizeof (gfc_expr *arg)
 }
 
 
-bool
-gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
+/* Helper functions check_c_ptr_1 and check_c_ptr_2
+   used in gfc_check_c_associated.  */
+
+static inline
+bool check_c_ptr_1 (gfc_expr *c_ptr_1)
 {
+  if ((c_ptr_1->ts.type == BT_VOID)
+      && (c_ptr_1->expr_type == EXPR_FUNCTION))
+    return true;
+
   if (c_ptr_1->ts.type != BT_DERIVED
       || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
       || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
 	  && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
-    {
-      gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
-		 "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
-      return false;
-    }
+	goto check_1_error;
+
+  if ((c_ptr_1->ts.type == BT_DERIVED)
+       && (c_ptr_1->expr_type == EXPR_STRUCTURE)
+       && (c_ptr_1->ts.u.derived->intmod_sym_id
+	   == ISOCBINDING_NULL_FUNPTR))
+    goto check_1_error;
 
-  if (!scalar_check (c_ptr_1, 0))
+  if (scalar_check (c_ptr_1, 0))
+    return true;
+  else
+    /*  Return since the check_1_error message may not apply here. */
     return false;
 
-  if (c_ptr_2
-      && (c_ptr_2->ts.type != BT_DERIVED
-	  || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
-	  || (c_ptr_1->ts.u.derived->intmod_sym_id
-	      != c_ptr_2->ts.u.derived->intmod_sym_id)))
-    {
-      gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
-		 "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
-		 gfc_typename (&c_ptr_1->ts),
-		 gfc_typename (&c_ptr_2->ts));
-      return false;
-    }
+check_1_error:
+
+  gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
+	     "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
+  return false;
+}
+
+static inline
+bool check_c_ptr_2 (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
+{
+  switch (c_ptr_2->ts.type)
+  {
+    case BT_VOID:
+      if (c_ptr_2->expr_type == EXPR_FUNCTION)
+	{
+	  if ((c_ptr_1->ts.type == BT_DERIVED)
+	       && c_ptr_1->expr_type == EXPR_STRUCTURE
+	       && (c_ptr_1->ts.u.derived->intmod_sym_id
+		  == ISOCBINDING_FUNPTR))
+	    goto check_2_error;
+	}
+      break;
+
+    case BT_DERIVED:
+      if ((c_ptr_2->expr_type == EXPR_STRUCTURE)
+	   && (c_ptr_2->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR)
+	   && (c_ptr_1->ts.type == BT_VOID)
+	   && (c_ptr_1->expr_type == EXPR_FUNCTION))
+	return scalar_check (c_ptr_2, 1);
+
+      if ((c_ptr_2->expr_type == EXPR_STRUCTURE)
+	   && (c_ptr_1->ts.type == BT_VOID)
+	   && (c_ptr_1->expr_type == EXPR_FUNCTION))
+	goto check_2_error;
+
+      if (c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING)
+	goto check_2_error;
+
+      if (c_ptr_1->ts.type == BT_DERIVED
+	  && (c_ptr_1->ts.u.derived->intmod_sym_id
+	      != c_ptr_2->ts.u.derived->intmod_sym_id))
+	goto check_2_error;
+      break;
+
+    default:
+      goto check_2_error;
+  }
 
-  if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
+  if (scalar_check (c_ptr_2, 1))
+    return true;
+  else
+    /*  Return since the check_2_error message may not apply here. */
     return false;
 
-  return true;
+check_2_error:
+
+  gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
+	     "same type as C_PTR_1, found %s instead of %s", &c_ptr_2->where,
+	     gfc_typename (&c_ptr_2->ts), gfc_typename (&c_ptr_1->ts));
+
+  return false;
+ }
+
+
+bool
+gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
+{
+  if (c_ptr_2)
+    {
+      if (check_c_ptr_2 (c_ptr_1, c_ptr_2))
+	return check_c_ptr_1 (c_ptr_1);
+      else
+	return false;
+    }
+  else
+    return check_c_ptr_1 (c_ptr_1);
 }
 
 
 bool
-gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
+gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape,
+		       gfc_expr *lower)
 {
   symbol_attribute attr;
   const char *msg;
@@ -6064,6 +6187,43 @@ gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
 	}
     }
 
+  if (lower
+      && !gfc_notify_std (GFC_STD_F2023, "LOWER argument at %L to C_F_POINTER",
+			  &lower->where))
+    return false;
+
+  if (!shape && lower)
+    {
+      gfc_error ("Unexpected LOWER argument at %L to C_F_POINTER "
+		 "with scalar FPTR",
+		 &lower->where);
+      return false;
+    }
+
+  if (lower && !rank_check (lower, 3, 1))
+    return false;
+
+  if (lower && !type_check (lower, 3, BT_INTEGER))
+    return false;
+
+  if (lower)
+    {
+      mpz_t size;
+      if (gfc_array_size (lower, &size))
+	{
+	  if (mpz_cmp_ui (size, fptr->rank) != 0)
+	    {
+	      mpz_clear (size);
+	      gfc_error (
+		"LOWER argument at %L to C_F_POINTER must have the same "
+		"size as the RANK of FPTR",
+		&lower->where);
+	      return false;
+	    }
+	  mpz_clear (size);
+	}
+    }
+
   if (fptr->ts.type == BT_CLASS)
     {
       gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where);
@@ -6436,7 +6596,7 @@ gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_exp
 
 
 bool
-gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
+gfc_check_fstat (gfc_expr *unit, gfc_expr *values)
 {
   if (!type_check (unit, 0, BT_INTEGER))
     return false;
@@ -6444,11 +6604,22 @@ gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
   if (!scalar_check (unit, 0))
     return false;
 
-  if (!type_check (array, 1, BT_INTEGER)
-      || !kind_value_check (unit, 0, gfc_default_integer_kind))
+  if (!type_check (values, 1, BT_INTEGER))
     return false;
 
-  if (!array_check (array, 1))
+  if (values->ts.kind != 4 && values->ts.kind != 8)
+    {
+      error_unsupported_kind (values, 1);
+      return false;
+    }
+
+  if (!array_check (values, 1))
+    return false;
+
+  if (!variable_check (values, 1, false))
+    return false;
+
+  if (!array_size_check (values, 1, 13))
     return false;
 
   return true;
@@ -6456,31 +6627,24 @@ gfc_check_fstat (gfc_expr *unit, gfc_expr *array)
 
 
 bool
-gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status)
+gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *values, gfc_expr *status)
 {
-  if (!type_check (unit, 0, BT_INTEGER))
-    return false;
-
-  if (!scalar_check (unit, 0))
-    return false;
-
-  if (!type_check (array, 1, BT_INTEGER)
-      || !kind_value_check (array, 1, gfc_default_integer_kind))
-    return false;
-
-  if (!array_check (array, 1))
+  if (!gfc_check_fstat (unit, values))
     return false;
 
   if (status == NULL)
     return true;
 
   if (!type_check (status, 2, BT_INTEGER)
-      || !kind_value_check (status, 2, gfc_default_integer_kind))
+      || !check_minrange4 (status, 2))
     return false;
 
   if (!scalar_check (status, 2))
     return false;
 
+  if (!variable_check (status, 2, false))
+    return false;
+
   return true;
 }
 
@@ -6518,18 +6682,29 @@ gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset)
 
 
 bool
-gfc_check_stat (gfc_expr *name, gfc_expr *array)
+gfc_check_stat (gfc_expr *name, gfc_expr *values)
 {
   if (!type_check (name, 0, BT_CHARACTER))
     return false;
   if (!kind_value_check (name, 0, gfc_default_character_kind))
     return false;
 
-  if (!type_check (array, 1, BT_INTEGER)
-      || !kind_value_check (array, 1, gfc_default_integer_kind))
+  if (!type_check (values, 1, BT_INTEGER))
     return false;
 
-  if (!array_check (array, 1))
+  if (values->ts.kind != 4 && values->ts.kind != 8)
+    {
+      error_unsupported_kind (values, 1);
+      return false;
+    }
+
+  if (!array_check (values, 1))
+    return false;
+
+  if (!variable_check (values, 1, false))
+    return false;
+
+  if (!array_size_check (values, 1, 13))
     return false;
 
   return true;
@@ -6537,30 +6712,24 @@ gfc_check_stat (gfc_expr *name, gfc_expr *array)
 
 
 bool
-gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
+gfc_check_stat_sub (gfc_expr *name, gfc_expr *values, gfc_expr *status)
 {
-  if (!type_check (name, 0, BT_CHARACTER))
-    return false;
-  if (!kind_value_check (name, 0, gfc_default_character_kind))
-    return false;
-
-  if (!type_check (array, 1, BT_INTEGER)
-      || !kind_value_check (array, 1, gfc_default_integer_kind))
-    return false;
-
-  if (!array_check (array, 1))
+  if (!gfc_check_stat (name, values))
     return false;
 
   if (status == NULL)
     return true;
 
   if (!type_check (status, 2, BT_INTEGER)
-      || !kind_value_check (array, 1, gfc_default_integer_kind))
+      || !check_minrange4 (status, 2))
     return false;
 
   if (!scalar_check (status, 2))
     return false;
 
+  if (!variable_check (status, 2, false))
+    return false;
+
   return true;
 }