Fortran: Generic processing of assumed rank objects (f202y) [PR116733]

2024-10-23  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/116733
	* array.cc : White space corrections.
	* expr.cc (gfc_check_pointer_assign): Permit assumed rank
	target with -std=f202y. Add constraints that the data pointer
	object must have rank remapping specified and the that the data
	target be contiguous.
	* gfortran.h : Add a gfc_array_ref field 'ar' to the structure
	'gfc_association_list'.
	* interface.cc (gfc_compare_actual_formal): If -Wsurprising
	is set, emit a warning if an assumed size array is passed to an
	assumed rank dummy.
	* intrinsic.cc (do_ts29113_check): Permit an assumed rank arg.
	for reshape if -std=f202y and the argument is contiguous.
	* invoke.texi : Introduce -std=f202y. Whitespace errors.
	* lang.opt : Accept -std=f202y.
	* libgfortran.h : Define GFC_STD_F202Y.
	* match.cc (gfc_match_associate): If -std=f202y an assumed rank
	selector is allowed if it is contiguous and the associate name
	has rank remapping specified.
	* options.cc (gfc_init_options): -std=f202y is equivalent to
	-std=f2023 with experimental f202y features. White space issues
	* parse.cc (parse_associate): If the selector is assumed rank,
	use the 'ar' field of the association list to build an array
	specification.
	* primary.cc (gfc_match_varspec): Do not resolve the assumed
	rank selector of a class associate name at this stage to avoid
	the rank change.
	* resolve.cc (find_array_spec): If an array_ref dimension is -1
	reset it with the rank in the object's array_spec.
	(gfc_expression_rank): Do not check dimen types for an assumed
	rank variable expression.
	(resolve_variable): Do not emit the assumed rank context error
	if the context is pointer assignment and the variable is a
	target.
	(resolve_assoc_var): Resolve the bounds and check for missing
	bounds in the rank remap of an associate name with an assumed
	rank selector. Do not correct the rank of an associate name
	with an assumed rank selector.
	(resolve_symbol): Allow the reference to an assumed rank object
	if -std-f202y is enabled and the current operation is
	EXEC_BLOCK.
	* st.cc (gfc_free_association_list): Free bounds expressions
	of the 'ar' field, if present.
	* trans-array.cc (gfc_conv_ss_startstride): If -std=f202y and
	bounds checking activated, do not apply the assertion.
	* trans-expr.cc (gfc_trans_pointer_assignment): An assumed rank
	target has its offset set to zero.
	* trans-stmt.cc (trans_associate_var): If the selector is
	assumed rank, call gfc_trans_pointer_assignment using the 'ar'
	field in the association list as the array reference for expr1.
	The data target, expr2, is a copy of the selector expression.

gcc/testsuite/
	PR fortran/116733
	* gfortran.dg/associate_3.f03: Change error message.
	* gfortran.dg/f202y/f202y.exp: Enable tests of f202y features.
	* gfortran.dg/f202y/generic_assumed_rank_1.f90: New test.
	* gfortran.dg/f202y/generic_assumed_rank_2.f90: New test.
	* gfortran.dg/f202y/generic_assumed_rank_3.f90: New test.

5 files changed, 252 insertions, 3 deletions

diff --git a/gcc/testsuite/gfortran.dg/associate_3.f03 b/gcc/testsuite/gfortran.dg/associate_3.f03
index dfd5a99..7f690f3 100644
--- a/gcc/testsuite/gfortran.dg/associate_3.f03
+++ b/gcc/testsuite/gfortran.dg/associate_3.f03
@@ -9,15 +9,15 @@ PROGRAM main
 
   ASSOCIATE ! { dg-error "Expected association list" }
 
-  ASSOCIATE () ! { dg-error "Expected association" }
+  ASSOCIATE () ! { dg-error "Expected associate name" }
 
   ASSOCIATE (a => 1) 5 ! { dg-error "Junk after ASSOCIATE" }
 
   ASSOCIATE (x =>) ! { dg-error "Invalid association target" }
 
-  ASSOCIATE (=> 5) ! { dg-error "Expected association" }
+  ASSOCIATE (=> 5) ! { dg-error "Expected associate name" }
 
-  ASSOCIATE (x => 5, ) ! { dg-error "Expected association" }
+  ASSOCIATE (x => 5, ) ! { dg-error "Expected associate name" }
 
   myname: ASSOCIATE (a => 1)
   END ASSOCIATE ! { dg-error "Expected block name of 'myname'" }
diff --git a/gcc/testsuite/gfortran.dg/f202y/f202y.exp b/gcc/testsuite/gfortran.dg/f202y/f202y.exp
new file mode 100644
index 0000000..5890af5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/f202y/f202y.exp
@@ -0,0 +1,57 @@
+# Copyright (C) 2005-2024 Free Software Foundation, Inc.
+#
+# This file is part of GCC.
+#
+# GCC is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3, or (at your option)
+# any later version.
+#
+# GCC is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING3.  If not see
+# <http://www.gnu.org/licenses/>.
+
+# GCC testsuite that uses the `dg.exp' driver.
+
+# Load support procs.
+load_lib gfortran-dg.exp
+
+# Initialize `dg'.
+dg-init
+
+global gfortran_test_path
+global gfortran_aux_module_flags
+set gfortran_test_path $srcdir/$subdir
+set gfortran_aux_module_flags "-std=f202y"
+proc dg-compile-aux-modules { args } {
+    global gfortran_test_path
+    global gfortran_aux_module_flags
+    if { [llength $args] != 2 } {
+	error "dg-compile-aux-modules: needs one argument"
+	return
+    }
+
+    set level [info level]
+    if { [info procs dg-save-unknown] != [list] } {
+	rename dg-save-unknown dg-save-unknown-level-$level
+    }
+
+    dg-test $gfortran_test_path/[lindex $args 1] "" $gfortran_aux_module_flags
+    # cleanup-modules is intentionally not invoked here.
+
+    if { [info procs dg-save-unknown-level-$level] != [list] } {
+	rename dg-save-unknown-level-$level dg-save-unknown
+    }
+}
+
+# Main loop.
+gfortran-dg-runtest [lsort \
+       [find $srcdir/$subdir *.\[fF\]{,90,95,03,08} ] ] "-std=f202y" ""
+
+# All done.
+dg-finish
diff --git a/gcc/testsuite/gfortran.dg/f202y/generic_assumed_rank_1.f90 b/gcc/testsuite/gfortran.dg/f202y/generic_assumed_rank_1.f90
new file mode 100644
index 0000000..bca715e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/f202y/generic_assumed_rank_1.f90
@@ -0,0 +1,54 @@
+! { dg-do run }
+! { dg-options "-fcheck=bounds" }
+!
+! Test Reinhold Bader's F202y proposal (J3 DIN4) "Generic processing of assumed
+! rank objects". The present gfortran implementation includes pointer assignment
+! and ASSOCIATE, with rank remapping of the var or associate-name, and RESHAPE.
+! J3 document 24-136r1.txt, by Malcolm Cohen, considers further possibilities.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+   real :: x(2,2,2)
+   real, parameter :: xp(*) = [1,2,3,4,5,6,7,8]
+   x = reshape (xp, [2,2,2])
+   call my_sub (x)
+   if (any (reshape (x, [8]) .ne. xp(8:1:-1))) stop 1
+   call my_assumed_size_target (x)
+contains
+   subroutine my_sub (arg)
+     real, target, contiguous :: arg(..)
+     real, allocatable :: y(:)
+     real, pointer :: argp(:,:)
+     integer :: i
+
+     if (size (arg) .lt. 0) return
+
+     if (size (arg) .ne. 8) stop 10
+
+! Check reshape
+     y = reshape (arg, [size (arg)])
+     if (any (y .ne. xp)) stop 20
+
+! Check pointer assignment
+     argp(1:2,1: size(arg)/2) => arg
+     if (size (argp) .ne. size (x)) stop 30
+     if (any ((argp) .ne. reshape (x, [2, size (x)/2]))) stop 31
+
+! Check ASSOCIATE
+     i = size (arg)
+     associate (a(1:2,1:i/2) => arg)
+        if (any (a .ne. argp)) stop 40
+     end associate
+
+     associate (a(1:size(arg)) => arg)
+        if (any (a .ne. xp)) stop 41
+        a = a(8:1:-1)
+     end associate
+   end
+
+   subroutine my_assumed_size_target (arg)
+     real :: arg(2, 2, *)
+     call my_sub (arg)
+   end
+end
+! { dg-output "Fortran runtime warning: Assumed rank object arg is associated with an assumed size object" }
diff --git a/gcc/testsuite/gfortran.dg/f202y/generic_assumed_rank_2.f90 b/gcc/testsuite/gfortran.dg/f202y/generic_assumed_rank_2.f90
new file mode 100644
index 0000000..74ade73
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/f202y/generic_assumed_rank_2.f90
@@ -0,0 +1,53 @@
+! { dg-do compile }
+! { dg-options "-std=f2023 -Wsurprising" }
+!
+! Test Reinhold Bader's F202y proposal (J3 DIN4) "Generic processing of assumed
+! rank objects". The present gfortran implementation includes pointer assignment
+! and ASSOCIATE, with rank remapping of the var or associate-name, and RESHAPE.
+! J3 document 24-136r1.txt, by Malcolm Cohen, considers further possibilities.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+   real :: x(2,2,2)
+   real, parameter :: xp(*) = [1,2,3,4,5,6,7,8]
+   x = reshape (xp, [2,2,2])
+   call my_sub (x)
+   if (any (reshape (x, [8]) .ne. xp(8:1:-1))) stop 1
+   call my_assumed_size_target (x)
+contains
+   subroutine my_sub (arg)
+     real, target, contiguous :: arg(..)
+     real, allocatable :: y(:)
+     real, pointer :: argp(:,:)
+     integer :: i
+
+     if (size (arg) .lt. 0) return
+
+     if (size (arg) .ne. 8) stop 10
+
+! Check reshape
+     y = reshape (arg, [size (arg)]) ! { dg-error "experimental F202y feature" }
+     if (any (y .ne. xp)) stop 20
+
+! Check pointer assignment
+     argp(1:2,1: size(arg)/2) => arg ! { dg-error "experimental F202y feature" }
+     if (size (argp) .ne. size (x)) stop 30
+     if (any ((argp) .ne. reshape (x, [2, size (x)/2]))) stop 31
+
+! Check ASSOCIATE
+     i = size (arg)
+     associate (a(1:2,1:i/2) => arg) ! { dg-error "experimental F202y feature" }
+        if (any (a .ne. argp)) stop 40
+     end associate
+
+     associate (a(1:size(arg)) => arg)  ! { dg-error "experimental F202y feature" }
+        if (any (a .ne. xp)) stop 41
+        a = a(8:1:-1)
+     end associate
+   end
+
+   subroutine my_assumed_size_target (arg)
+     real :: arg(2, 2, *)
+     call my_sub (arg)    ! { dg-warning "to an assumed-rank dummy" }
+   end
+end
diff --git a/gcc/testsuite/gfortran.dg/f202y/generic_assumed_rank_3.f90 b/gcc/testsuite/gfortran.dg/f202y/generic_assumed_rank_3.f90
new file mode 100644
index 0000000..0fb5b02
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/f202y/generic_assumed_rank_3.f90
@@ -0,0 +1,85 @@
+! { dg-do run }
+! { dg-options "-std=f202y -Wsurprising" }
+!
+! Test Reinhold Bader's F202y proposal "Generic processing of assumed rank objects".
+! Tests class assumed rank objects.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+   type :: t1
+     integer :: i
+   end type
+   type, extends(t1) :: t2
+     integer :: j
+   end type
+
+   class(t1), allocatable :: x(:,:)
+   type(t2), parameter :: xp(*) = [t2(t1(1),2),t2(t1(3),4),t2(t1(5),6),t2(t1(7),8)]
+   x = reshape (xp, [2,2])
+   call my_sub1 (x)
+   if (any (x(2:1:-1,2:1:-1)%i .ne. reshape (xp%i, [2,2]))) stop 1
+   call my_sub2 (x)
+   if (any (x(2:1:-1,2:1:-1)%i .ne. reshape (xp%i, [2,2]))) stop 2
+   deallocate (x)
+contains
+   subroutine my_sub1 (class_arg)
+      class(t1), contiguous, target :: class_arg(..)
+      class(t1), pointer :: cp(:)
+      integer :: cp_sz
+      integer :: lb(1)
+      integer :: ub(1)
+      integer :: slb = 2
+
+      cp_sz = size (class_arg)
+      cp(slb:slb+cp_sz-1) => class_arg
+      if (any (cp%i .ne. xp%i)) stop 3
+      if (size (cp) .ne. cp_sz) stop 4
+      if (ubound (cp, 1) .ne. slb+cp_sz-1) stop 5
+
+      associate (ca(slb:slb+cp_sz-1) => class_arg)
+         lb = lbound (ca)
+         ub = ubound (ca)
+         if (size (ca) .ne. cp_sz) stop 6
+         if (ubound (ca, 1) .ne. slb+cp_sz-1) stop 7
+         select type (ca)
+            type is (t2)
+               ca = ca(ub(1):lb(1):-1)
+            class default
+         end select
+      end associate
+   end
+
+   subroutine my_sub2 (class_arg)
+      class(*), contiguous, target :: class_arg(..)
+      class(*), pointer :: cp(:, :)
+      integer :: cp_sz
+      cp_sz = size (class_arg)
+      cp(1:cp_sz/2, 1:cp_sz/2) => class_arg
+      call check (cp, cp_sz)
+      associate (ca(2:3,1:2) => class_arg)
+         select type (ca)
+            type is (t2)
+               ca = ca(3:2:-1,2:1:-1)
+            class default
+         end select
+      end associate
+   end
+
+   subroutine check (arg, sz)
+      class(*), intent(inOUT) :: arg(:, :)
+      integer :: sz
+      integer :: lb(2)
+      integer :: ub(2)
+      lb = lbound(arg)
+      ub = ubound(arg)
+      select type (s => arg)
+         type is (t2)
+            s = s(ub(1):lb(1):-1,ub(2):lb(1):-1)
+            if (any (reshape (s(lb(1):ub(1),lb(2):ub(2))%j, [sz]) &
+                .ne. xp%j)) stop 8
+
+         class default
+            stop 9
+      end select
+   end
+end