From d0e7833b94953ba6b4a915150666969ad9fc66af Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Sat, 24 Apr 2021 20:51:41 +0200
Subject: PR fortran/100154 - ICE in gfc_conv_procedure_call, at
 fortran/trans-expr.c:6131

Add appropriate static checks for the character and status arguments to
the GNU Fortran intrinsic extensions fget[c], fput[c].  Extend variable
check to allow a function reference having a data pointer result.

gcc/fortran/ChangeLog:

	PR fortran/100154
	* check.c (variable_check): Allow function reference having a data
	pointer result.
	(arg_strlen_is_zero): New function.
	(gfc_check_fgetputc_sub): Add static check of character and status
	arguments.
	(gfc_check_fgetput_sub): Likewise.
	* intrinsic.c (add_subroutines): Fix argument name for the
	character argument to intrinsic subroutines fget[c], fput[c].

gcc/testsuite/ChangeLog:

	PR fortran/100154
	* gfortran.dg/pr100154.f90: New test.
---
 gcc/fortran/check.c | 36 ++++++++++++++++++++++++++++++++++--
 1 file changed, 34 insertions(+), 2 deletions(-)

(limited to 'gcc/fortran/check.c')

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 82db8e4..27bf3a7 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1055,6 +1055,13 @@ variable_check (gfc_expr *e, int n, bool allow_proc)
 	  return true;
     }
 
+  /* F2018:R902: function reference having a data pointer result.  */
+  if (e->expr_type == EXPR_FUNCTION
+      && e->symtree->n.sym->attr.flavor == FL_PROCEDURE
+      && e->symtree->n.sym->attr.function
+      && e->symtree->n.sym->attr.pointer)
+    return true;
+
   gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
 	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
 
@@ -5690,6 +5697,19 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
    functions).  */
 
 bool
+arg_strlen_is_zero (gfc_expr *c, int n)
+{
+  if (gfc_var_strlen (c) == 0)
+    {
+      gfc_error ("%qs argument of %qs intrinsic at %L must have "
+		 "length at least 1", gfc_current_intrinsic_arg[n]->name,
+		 gfc_current_intrinsic, &c->where);
+      return true;
+    }
+  return false;
+}
+
+bool
 gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
 {
   if (!type_check (unit, 0, BT_INTEGER))
@@ -5702,13 +5722,19 @@ gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
     return false;
   if (!kind_value_check (c, 1, gfc_default_character_kind))
     return false;
+  if (strcmp (gfc_current_intrinsic, "fgetc") == 0
+      && !variable_check (c, 1, false))
+    return false;
+  if (arg_strlen_is_zero (c, 1))
+    return false;
 
   if (status == NULL)
     return true;
 
   if (!type_check (status, 2, BT_INTEGER)
       || !kind_value_check (status, 2, gfc_default_integer_kind)
-      || !scalar_check (status, 2))
+      || !scalar_check (status, 2)
+      || !variable_check (status, 2, false))
     return false;
 
   return true;
@@ -5729,13 +5755,19 @@ gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
     return false;
   if (!kind_value_check (c, 0, gfc_default_character_kind))
     return false;
+  if (strcmp (gfc_current_intrinsic, "fget") == 0
+      && !variable_check (c, 0, false))
+    return false;
+  if (arg_strlen_is_zero (c, 0))
+    return false;
 
   if (status == NULL)
     return true;
 
   if (!type_check (status, 1, BT_INTEGER)
       || !kind_value_check (status, 1, gfc_default_integer_kind)
-      || !scalar_check (status, 1))
+      || !scalar_check (status, 1)
+      || !variable_check (status, 1, false))
     return false;
 
   return true;
-- 
cgit v1.1


From e314cfc371d8b2405a1d81e51b90f9fb24b9061f Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Fri, 23 Jul 2021 21:00:10 +0200
Subject: Fortran: extend check for array arguments and reject CLASS array
 elements.

gcc/fortran/ChangeLog:

	PR fortran/101536
	* check.c (array_check): Adjust check for the case of CLASS
	arrays.

gcc/testsuite/ChangeLog:

	PR fortran/101536
	* gfortran.dg/pr101536.f90: New test.
---
 gcc/fortran/check.c | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

(limited to 'gcc/fortran/check.c')

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 27bf3a7..851af1b 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -731,12 +731,11 @@ logical_array_check (gfc_expr *array, int n)
 static bool
 array_check (gfc_expr *e, int n)
 {
-  if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
+  if (e->rank != 0 && e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok
 	&& CLASS_DATA (e)->attr.dimension
 	&& CLASS_DATA (e)->as->rank)
     {
       gfc_add_class_array_ref (e);
-      return true;
     }
 
   if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
-- 
cgit v1.1