[Patch] Fortran: F2018 type(*),dimension(*) with scalars [PR104143]

[Tobias Burnus <tobias@codesourcery.com>]

[-- Attachment #1.1: Type: text/plain, Size: 2041 bytes --]

In several cases, one just wants to have the address where an object starts
without requiring the detour via 'c_loc' and the (locally) required 'target'
attribute.

In principle,  type(*),dimension(*)  of TS29113 permits this, except that
'dimension(*)' only permits arrays and array elements but not scalars.

Fortran 2018 modified this such that with 'type(*)' also scalars are permitted.
(See PR for the quotes.)

This patch implements this simple change. Before, implementations like MPI
had to use '!GCC$ attribute NO_ARG_CHECK ::' in addition to type(*),dimension(*)
to achieve this. In GCC, we do likewise, but that's at least inside the compiler,
cf. libgomp/openacc{.f90,_lib.h}.

OK for mainline?

Tobias

PS: I know that there are still patches to be reviewed; I am not sure wrt IEEE
but I think most of the clobber patches still need a review and likely also some
of Harald's patches. I think we also need to take care of some more of the ready
or nearly ready patches by José. (I somewhere have a list that could dig it out quickly,
if someone want to do some work on this. However, some were already handled by Harald.)

Unfortunately, I am currently too busy with other things (OpenMP, looking at
issues in mostly OpenMP-related testsuites, OpenMP spec issues, a bunch of odd
things) to really work on Fortran, especially as too many of the other listed
items are likewise non-primary work items and I shouldn't really keep increasing
the time spend on work-related-but-not-to-be-focused-on items...

Otherwise: Last weekend was the GNU Tools Cauldron, https://gcc.gnu.org/wiki/cauldron2022
A few slides are already online (including mine) and the recordings should become
available soon, in case you are interested.


-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955

[-- Attachment #2: assumed-type-rank.diff --]
[-- Type: text/x-patch, Size: 4107 bytes --]

Fortran: F2018 type(*),dimension(*) with scalars [PR104143]

Assumed-size dummy arguments accept arrays and array elements as actual
arguments. There are also a few exceptions when real scalars are permitted.
Since F2018, this includes scalar arguments to assumed-type dummies; while
type(*) was added in TS29113, this change is only in F2018 itself.

	PR fortran/104143

gcc/fortran/ChangeLog:

	* interface.cc (compare_parameter): Permit scalar args to
	'type(*), dimension(*)'.

gcc/testsuite/ChangeLog:

	* gfortran.dg/c-interop/c407b-2.f90: Remove dg-error.
	* gfortran.dg/assumed_type_16.f90: New test.
	* gfortran.dg/assumed_type_17.f90: New test.

 gcc/fortran/interface.cc                        | 11 ++++++++++-
 gcc/testsuite/gfortran.dg/assumed_type_16.f90   | 14 ++++++++++++++
 gcc/testsuite/gfortran.dg/assumed_type_17.f90   | 18 ++++++++++++++++++
 gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90 |  2 +-
 4 files changed, 43 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 71eec78259b..d3e199535b3 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -2692,7 +2692,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
      - if the actual argument is (a substring of) an element of a
        non-assumed-shape/non-pointer/non-polymorphic array; or
      - (F2003) if the actual argument is of type character of default/c_char
-       kind.  */
+       kind.
+     - (F2018) if the dummy argument is type(*).  */
 
   is_pointer = actual->expr_type == EXPR_VARIABLE
 	       ? actual->symtree->n.sym->attr.pointer : false;
@@ -2759,6 +2760,14 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 
   if (ref == NULL && actual->expr_type != EXPR_NULL)
     {
+      if (actual->rank == 0
+	  && formal->ts.type == BT_ASSUMED
+	  && formal->as
+	  && formal->as->type == AS_ASSUMED_SIZE)
+	/* This is new in F2018, type(*) is new in TS29113, but gfortran does
+	   not differentiate.  Thus, if type(*) exists, it is valid;
+	   otherwise, type(*) is already rejected.  */
+	return true;
       if (where
 	  && (!formal->attr.artificial || (!formal->maybe_array
 					   && !maybe_dummy_array_arg (actual))))
diff --git a/gcc/testsuite/gfortran.dg/assumed_type_16.f90 b/gcc/testsuite/gfortran.dg/assumed_type_16.f90
new file mode 100644
index 00000000000..52d8ef5ea20
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_type_16.f90
@@ -0,0 +1,14 @@
+! { dg-do compile }
+! { dg-additional-options "-std=f2008" }
+!
+! PR fortran/104143
+!
+ interface
+   subroutine foo(x)
+     type(*) :: x(*)  ! { dg-error "Fortran 2018: Assumed type" }
+   end
+ end interface
+ integer :: a
+ call foo(a)  ! { dg-error "Type mismatch in argument" }
+ call foo((a))  ! { dg-error "Type mismatch in argument" }
+end
diff --git a/gcc/testsuite/gfortran.dg/assumed_type_17.f90 b/gcc/testsuite/gfortran.dg/assumed_type_17.f90
new file mode 100644
index 00000000000..d6ccd3058ce
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_type_17.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! { dg-additional-options "-std=f2018 -fdump-tree-original" }
+!
+! PR fortran/104143
+!
+ interface
+   subroutine foo(x)
+     type(*) :: x(*)
+   end
+ end interface
+ integer :: a
+ call foo(a)
+ call foo((a))
+end
+
+! { dg-final { scan-tree-dump-times "foo \\(&a\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = a;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&D.\[0-9\]+\\);" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90
index 4f9f6c73d7d..49352fc9d71 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90
@@ -40,7 +40,7 @@ subroutine s0 (x)
 
   call g (x, 1)
   call f (x, 1)  ! { dg-error "Type mismatch" }
-  call h (x, 1)  ! { dg-error "Rank mismatch" }
+  call h (x, 1)  ! Scalar to type(*),dimension(*): Invalid in TS29113 but valid since F2018
 end subroutine
 
 ! Check that you can't use an assumed-type array variable in an array