[PATCH, v3] Fortran: restrictions on integer arguments to SYSTEM_CLOCK [PR112609]

[Harald Anlauf <anlauf@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 1228 bytes --]

Hi Mikael, Steve,

On 11/21/23 12:33, Mikael Morin wrote:
> Harald, you mentioned the lack of GFC_STD_F2023_DEL feature group in
> your first message, but I don't quite understand why you didn't add one.
>   It seems to me the most natural way to do this.

thanks for insisting on this variant.

In my first attack at this problem, I overlooked one place in
libgfortran.h, which I now was able to find and adjust.
Now everything falls into place.

> I suggest we emit a warning by default, error with -std=f2023 (I agree
> with Steve that we should push towards strict f2023 conformance), and no
> diagnostic with -std=gnu or -std=f2018 or lower.

As the majority agrees on this, I accept it.  The attached patch
now does this and fixes the testcases accordingly.

>> It seems that the solution is to fix the code in the testsuite.
>
> Agreed, these seem to explicitly test mismatching kinds, so add an
> option to prevent error.

Done.

I also fixed a few issues in the documentation in gfortran.texi .

As I currently cannot build a full compiler (see PR112643),
patch V3 is not properly regtested yet, but appears to give
results as discussed.

Comments?

> Mikael

Thanks,
Harald



[-- Attachment #2: pr104819-v3.patch --]
[-- Type: text/x-patch, Size: 11057 bytes --]

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 6c45e6542f0..e5cf6a495b5 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -4357,6 +4357,9 @@ gfc_check_null (gfc_expr *mold)
   if (mold == NULL)
     return true;
 
+  if (mold->expr_type == EXPR_NULL)
+    return true;
+
   if (!variable_check (mold, 0, true))
     return false;
 
@@ -5189,7 +5192,7 @@ is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
 {
   *msg = NULL;
 
-  if (expr->expr_type == EXPR_NULL)
+  if (expr->expr_type == EXPR_NULL && expr->ts.type == BT_UNKNOWN)
     {
       *msg = "NULL() is not interoperable";
       return false;
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index fc4fe662eab..641edf9d059 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -2387,6 +2387,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   gfc_component *ppc;
   bool codimension = false;
   gfc_array_spec *formal_as;
+  bool pointer_arg, allocatable_arg;
+  bool pre2018 = ((gfc_option.allow_std & GFC_STD_F2018) == 0);
 
   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
      procs c_f_pointer or c_f_procpointer, and we need to accept most
@@ -2564,13 +2566,20 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	}
     }
 
+  pointer_arg = gfc_expr_attr (actual).pointer;
+  allocatable_arg = gfc_expr_attr (actual).allocatable;
+
   /* F08: 12.5.2.5 Allocatable and pointer dummy variables.  However, this
      is necessary also for F03, so retain error for both.
+     F2018:15.5.2.5 relaxes this constraint to same attributes.
      NOTE: Other type/kind errors pre-empt this error.  Since they are F03
      compatible, no attempt has been made to channel to this one.  */
   if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual)
       && (CLASS_DATA (formal)->attr.allocatable
-	  ||CLASS_DATA (formal)->attr.class_pointer))
+	  || CLASS_DATA (formal)->attr.class_pointer)
+      && (pre2018
+	  || (allocatable_arg && CLASS_DATA (formal)->attr.allocatable)
+	  || (pointer_arg && CLASS_DATA (formal)->attr.class_pointer)))
     {
       if (where)
 	gfc_error ("Actual argument to %qs at %L must be unlimited "
@@ -2710,7 +2719,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   rank_check = where != NULL && !is_elemental && formal_as
     && (formal_as->type == AS_ASSUMED_SHAPE
 	|| formal_as->type == AS_DEFERRED)
-    && actual->expr_type != EXPR_NULL;
+    && !(actual->expr_type == EXPR_NULL
+	 && actual->ts.type == BT_UNKNOWN);
 
   /* Skip rank checks for NO_ARG_CHECK.  */
   if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
@@ -3184,8 +3194,10 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
   gfc_array_ref *actual_arr_ref;
   gfc_array_spec *fas, *aas;
   bool pointer_dummy, pointer_arg, allocatable_arg;
+  bool procptr_dummy, optional_dummy, allocatable_dummy;
 
   bool ok = true;
+  bool pre2018 = ((gfc_option.allow_std & GFC_STD_F2018) == 0);
 
   actual = *ap;
 
@@ -3296,15 +3308,66 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  && a->expr->ts.type != BT_ASSUMED)
 	gfc_find_vtab (&a->expr->ts);
 
+      /* Checks for NULL() actual arguments without MOLD.  */
+      if (a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN)
+	{
+	  /* Interp J3/22-146:
+	     "If the context of the reference to NULL is an <actual argument>
+	     corresponding to an <assumed-rank> dummy argument, MOLD shall be
+	     present."  */
+	  fas = (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)
+		 ? CLASS_DATA (f->sym)->as
+		 : f->sym->as);
+	  if (fas && fas->type == AS_ASSUMED_RANK)
+	    {
+	      gfc_error ("Intrinsic %<NULL()%> without %<MOLD%> argument "
+			 "at %L passed to assumed-rank dummy %qs",
+			 &a->expr->where, f->sym->name);
+	      ok = false;
+	      goto match;
+	    }
+
+	  /* Asummed-length dummy argument.  */
+	  if (f->sym->ts.type == BT_CHARACTER
+	      && !f->sym->ts.deferred
+	      && f->sym->ts.u.cl
+	      && f->sym->ts.u.cl->length == NULL)
+	    {
+	      gfc_error ("Intrinsic %<NULL()%> without %<MOLD%> argument "
+			 "at %L passed to assumed-length dummy %qs",
+			 &a->expr->where, f->sym->name);
+	      ok = false;
+	      goto match;
+	    }
+	}
+
+      /* Allow passing of NULL() as disassociated pointer, procedure
+	 pointer, or unallocated allocatable (F2008+) to a respective dummy
+	 argument.  */
+      pointer_dummy = ((f->sym->ts.type != BT_CLASS
+			&& f->sym->attr.pointer)
+		       || (f->sym->ts.type == BT_CLASS
+			   && CLASS_DATA (f->sym)->attr.class_pointer));
+
+      procptr_dummy = ((f->sym->ts.type != BT_CLASS
+			&& f->sym->attr.proc_pointer)
+		       || (f->sym->ts.type == BT_CLASS
+			   && CLASS_DATA (f->sym)->attr.proc_pointer));
+
+      optional_dummy = f->sym->attr.optional;
+
+      allocatable_dummy = ((f->sym->ts.type != BT_CLASS
+			    && f->sym->attr.allocatable)
+			   || (f->sym->ts.type == BT_CLASS
+			       && CLASS_DATA (f->sym)->attr.allocatable));
+
       if (a->expr->expr_type == EXPR_NULL
-	  && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
-	       && (f->sym->attr.allocatable || !f->sym->attr.optional
-		   || (gfc_option.allow_std & GFC_STD_F2008) == 0))
-	      || (f->sym->ts.type == BT_CLASS
-		  && !CLASS_DATA (f->sym)->attr.class_pointer
-		  && (CLASS_DATA (f->sym)->attr.allocatable
-		      || !f->sym->attr.optional
-		      || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
+	  && !pointer_dummy
+	  && !procptr_dummy
+	  && !(optional_dummy
+	       && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+	  && !(allocatable_dummy
+	       && (gfc_option.allow_std & GFC_STD_F2008) != 0))
 	{
 	  if (where
 	      && (!f->sym->attr.optional
@@ -3409,6 +3472,9 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
       if (f->sym->ts.type == BT_CLASS)
 	goto skip_size_check;
 
+      if (a->expr->expr_type == EXPR_NULL)
+	goto skip_size_check;
+
       actual_size = get_expr_storage_size (a->expr);
       formal_size = get_sym_storage_size (f->sym);
       if (actual_size != 0 && actual_size < formal_size
@@ -3606,6 +3672,71 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	    }
 	}
 
+      /* Check conditions on allocatable and pointer dummy variables:
+
+	 "The actual argument shall be polymorphic if and only if the
+	 associated dummy argument is polymorphic, and either both the
+	 actual and dummy arguments shall be unlimited polymorphic, or the
+	 declared type of the actual argument shall be the same as the
+	 declared type of the dummy argument."
+
+	 with a minor difference from F2008:15.5.2.5 to F2018:15.5.2.5,
+	 where the latter applies only to same (ALLOCATABLE or POINTER)
+	 attributes.  Note that checks related to unlimited polymorphism
+	 are also done in compare_parameter().  */
+      if ((pointer_dummy || allocatable_dummy)
+	  && (pointer_arg || allocatable_arg)
+	  && (pre2018
+	      || (pointer_dummy && pointer_arg)
+	      || (allocatable_dummy && allocatable_arg))
+	  && (f->sym->ts.type == BT_CLASS
+	      || a->expr->ts.type == BT_CLASS))
+       {
+	  if (f->sym->ts.type == BT_CLASS && a->expr->ts.type != BT_CLASS
+	      && pointer_dummy)
+	    {
+	      if (where)
+		gfc_error ("Actual argument to %qs at %L must be a "
+			   "CLASS POINTER",
+			   f->sym->name, &a->expr->where);
+	      ok = false;
+	      goto match;
+	    }
+
+	  if (f->sym->ts.type != BT_CLASS && a->expr->ts.type == BT_CLASS
+	      && pointer_arg)
+	    {
+	      if (where)
+		gfc_error ("Actual argument to %qs at %L cannot be a "
+			   "CLASS POINTER",
+			   f->sym->name, &a->expr->where);
+	      ok = false;
+	      goto match;
+	    }
+
+	  if (f->sym->ts.type == BT_CLASS && a->expr->ts.type != BT_CLASS
+	      && allocatable_dummy)
+	    {
+	      if (where)
+		gfc_error ("Actual argument to %qs at %L must be a "
+			   "CLASS ALLOCATABLE",
+			   f->sym->name, &a->expr->where);
+	      ok = false;
+	      goto match;
+	    }
+
+	  if (f->sym->ts.type != BT_CLASS && a->expr->ts.type == BT_CLASS
+	      && allocatable_arg)
+	    {
+	      if (where)
+		gfc_error ("Actual argument to %qs at %L cannot be a "
+			   "CLASS ALLOCATABLE",
+			   f->sym->name, &a->expr->where);
+	      ok = false;
+	      goto match;
+	    }
+       }
+
 
       /* Fortran 2008, C1242.  */
       if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 50c4604a025..30b941356b6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6288,16 +6288,37 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	       && (fsym->ts.type != BT_CLASS
 		   || !CLASS_DATA (fsym)->attr.class_pointer))
 	{
-	  /* Pass a NULL pointer to denote an absent arg.  */
-	  gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
-		      && (fsym->ts.type != BT_CLASS
-			  || !CLASS_DATA (fsym)->attr.allocatable));
-	  gfc_init_se (&parmse, NULL);
-	  parmse.expr = null_pointer_node;
-	  if (arg->associated_dummy
-	      && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
-		 == BT_CHARACTER)
-	    parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
+	  if ((fsym->ts.type != BT_CLASS
+	       && fsym->attr.allocatable)
+	      || (fsym->ts.type == BT_CLASS
+		  && CLASS_DATA (fsym)->attr.allocatable))
+	    {
+	      /* Pass descriptor equivalent to an unallocated allocatable
+		 actual argument.  */
+	      if (e->rank != 0)
+		gfc_internal_error ("gfc_conv_procedure_call() TODO: "
+				    "NULL(allocatable(rank != 0))");
+	      /* Scalar version below.  */
+	      gfc_init_se (&parmse, NULL);
+	      gfc_conv_expr_reference (&parmse, e);
+	      tmp = parmse.expr;
+	      if (TREE_CODE (tmp) == ADDR_EXPR)
+		tmp = TREE_OPERAND (tmp, 0);
+	      parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
+							   fsym->attr);
+	      parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
+	    }
+	  else
+	    {
+	      /* Pass a NULL pointer to denote an absent optional arg.  */
+	      gcc_assert (fsym->attr.optional);
+	      gfc_init_se (&parmse, NULL);
+	      parmse.expr = null_pointer_node;
+	      if (arg->associated_dummy
+		  && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
+		  == BT_CHARACTER)
+		parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
+	    }
 	}
       else if (fsym && fsym->ts.type == BT_CLASS
 		 && e->ts.type == BT_DERIVED)
@@ -6852,7 +6873,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		     we can assign it to the data field.  */
 
 		  if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
-		      && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
+		      && fsym->ts.type != BT_CLASS
+		      && !(e->expr_type == EXPR_NULL
+			   && e->ts.type == BT_UNKNOWN))
 		    {
 		      tmp = parmse.expr;
 		      if (TREE_CODE (tmp) == ADDR_EXPR)