[PATCH, v1] PR fortran/48958 - Add runtime diagnostics for SIZE intrinsic function

[Harald Anlauf]

Dear all,

here is a first version to check the status of ALLOCATABLE and POINTER
arguments to the SIZE intrinsic at runtime.

What it does not yet cover is situations like

  complex, allocatable :: z(:)
  print *, size (z% re)

Feedback, such as comments for improvement, are welcome.

As is, the patch regtests cleanly on x86_64-pc-linux-gnu.

Thanks,
Harald


PR fortran/48958 - Add runtime diagnostics for SIZE intrinsic function

Add code for runtime checking of status of ALLOCATABLE and POINTER
arguments to the SIZE intrinsic when -fcheck=pointer is specified.

gcc/fortran/ChangeLog:

        * trans-intrinsic.c (gfc_conv_intrinsic_size): Generate runtime
        checking code for status of argument.

gcc/testsuite/ChangeLog:

        * gfortran.dg/pr48958.f90: New test.


diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index e0afc10d105..d17b623924c 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7929,6 +7929,35 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
       && strcmp (e->ref->u.c.component->name, "_data") == 0)
     sym = e->symtree->n.sym;

+  if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
+      && e
+      && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
+    {
+      symbol_attribute attr;
+      char *msg;
+
+      attr = gfc_expr_attr (e);
+      if (attr.allocatable)
+	msg = xasprintf ("Allocatable argument '%s' is not allocated",
+			 e->symtree->n.sym->name);
+      else if (attr.pointer)
+	msg = xasprintf ("Pointer argument '%s' is not associated",
+			 e->symtree->n.sym->name);
+      else
+	goto end_arg_check;
+
+      argse.descriptor_only = 1;
+      gfc_conv_expr_descriptor (&argse, actual->expr);
+      tree temp = gfc_conv_descriptor_data_get (argse.expr);
+      tree cond = fold_build2_loc (input_location, EQ_EXPR,
+				   logical_type_node, temp,
+				   fold_convert (TREE_TYPE (temp),
+						 null_pointer_node));
+      gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
+      free (msg);
+    }
+ end_arg_check:
+
   argse.data_not_needed = 1;
   if (gfc_is_class_array_function (e))
     {
diff --git a/gcc/testsuite/gfortran.dg/pr48958.f90 b/gcc/testsuite/gfortran.dg/pr48958.f90
new file mode 100644
index 00000000000..2b109374f40
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr48958.f90
@@ -0,0 +1,25 @@
+! { dg-do run }
+! { dg-options "-fcheck=pointer -fdump-tree-original" }
+! { dg-shouldfail "Fortran runtime error: Allocatable argument 'a' is not allocated" }
+! { dg-output "At line 13 .*" }
+! PR48958 - Add runtime diagnostics for SIZE intrinsic function
+
+program p
+  integer :: n
+  integer,  allocatable :: a(:)
+  integer,  pointer     :: b(:)
+  class(*), allocatable :: c(:)
+  integer               :: d(10)
+  print *, size (a)
+  print *, size (b)
+  print *, size (c)
+  print *, size (d)
+  print *, size (f(n))
+contains
+  function f (n)
+    integer, intent(in) :: n
+    real, allocatable   :: f(:)
+  end function f
+end
+
+! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 4 "original" } }