https://gcc.gnu.org/g:c5fa2108ce0f3030cb28f47a18bc974c4224b66d
commit r15-4573-gc5fa2108ce0f3030cb28f47a18bc974c4224b66d
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Wed Oct 23 14:34:20 2024 +0100
Fortran: Generic processing of assumed rank objects (f202y) [PR116733]
2024-10-23 Paul Thomas <pa...@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.
Diff:
---
gcc/fortran/array.cc | 6 +-
gcc/fortran/expr.cc | 26 ++++++-
gcc/fortran/gfortran.h | 2 +
gcc/fortran/interface.cc | 10 +++
gcc/fortran/intrinsic.cc | 17 ++++-
gcc/fortran/invoke.texi | 31 ++++----
gcc/fortran/lang.opt | 8 +-
gcc/fortran/libgfortran.h | 1 +
gcc/fortran/match.cc | 53 +++++++++++++-
gcc/fortran/options.cc | 27 ++++---
gcc/fortran/parse.cc | 27 ++++++-
gcc/fortran/primary.cc | 1 +
gcc/fortran/resolve.cc | 36 +++++++--
gcc/fortran/st.cc | 16 ++++
gcc/fortran/trans-array.cc | 9 ++-
gcc/fortran/trans-expr.cc | 65 +++++++++++++----
gcc/fortran/trans-stmt.cc | 56 +++++++++++++-
gcc/testsuite/gfortran.dg/associate_3.f03 | 6 +-
gcc/testsuite/gfortran.dg/f202y/f202y.exp | 57 +++++++++++++++
.../gfortran.dg/f202y/generic_assumed_rank_1.f90 | 54 ++++++++++++++
.../gfortran.dg/f202y/generic_assumed_rank_2.f90 | 53 ++++++++++++++
.../gfortran.dg/f202y/generic_assumed_rank_3.f90 | 85 ++++++++++++++++++++++
22 files changed, 581 insertions(+), 65 deletions(-)
diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index 773c5b72c851..6dedaed3d4d1 100644
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -869,7 +869,7 @@ gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as,
locus *error_loc)
{
int i;
symbol_attribute *attr;
-
+
if (as == NULL)
return true;
@@ -878,7 +878,7 @@ gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as,
locus *error_loc)
attr = &sym->attr;
if (gfc_submodule_procedure(attr))
return true;
-
+
if (as->rank
&& !gfc_add_dimension (&sym->attr, sym->name, error_loc))
return false;
@@ -2457,7 +2457,7 @@ gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t
*result, mpz_t *end)
mpz_set_ui (stride, 1);
else
{
- stride_expr = gfc_copy_expr(ar->stride[dimen]);
+ stride_expr = gfc_copy_expr(ar->stride[dimen]);
if (!gfc_simplify_expr (stride_expr, 1)
|| stride_expr->expr_type != EXPR_CONSTANT
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 65bb9f11815e..b3e0bf1fd91a 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -4371,9 +4371,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr
*rvalue,
return false;
}
+ /* An assumed rank target is an experimental F202y feature. */
+ if (rvalue->rank == -1 && !(gfc_option.allow_std & GFC_STD_F202Y))
+ {
+ gfc_error ("The assumed rank target at %L is an experimental F202y "
+ "feature. Use option -std=f202y to enable",
+ &rvalue->where);
+ return false;
+ }
+
/* The target must be either rank one or it must be simply contiguous
and F2008 must be allowed. */
- if (rvalue->rank != 1)
+ if (rvalue->rank != 1 && rvalue->rank != -1)
{
if (!gfc_is_simply_contiguous (rvalue, true, false))
{
@@ -4386,6 +4395,21 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr
*rvalue,
return false;
}
}
+ else if (rvalue->rank == -1)
+ {
+ gfc_error ("The data-target at %L is an assumed rank object and so the "
+ "data-pointer-object %s must have a bounds remapping list "
+ "(list of lbound:ubound for each dimension)",
+ &rvalue->where, lvalue->symtree->name);
+ return false;
+ }
+
+ if (rvalue->rank == -1 && !gfc_is_simply_contiguous (rvalue, true, false))
+ {
+ gfc_error ("The assumed rank data-target at %L must be contiguous",
+ &rvalue->where);
+ return false;
+ }
/* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
if (rvalue->expr_type == EXPR_NULL)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 9e81a81686c6..a55646d5604e 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3034,6 +3034,8 @@ typedef struct gfc_association_list
gfc_expr *target;
+ gfc_array_ref *ar;
+
/* Used for inferring the derived type of an associate name, whose selector
is a sibling derived type function that has not yet been parsed. */
gfc_symbol *derived_types;
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index b592fe4f6c7f..dbcbed8bf30c 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3337,6 +3337,16 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap,
gfc_formal_arglist *formal,
goto match;
}
+ if (warn_surprising
+ && a->expr->expr_type == EXPR_VARIABLE
+ && a->expr->symtree->n.sym->as
+ && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
+ && f->sym->as
+ && f->sym->as->type == AS_ASSUMED_RANK)
+ gfc_warning (0, "The assumed-size dummy %qs is being passed at %L to "
+ "an assumed-rank dummy %qs", a->expr->symtree->name,
+ &a->expr->where, f->sym->name);
+
if (a->expr->expr_type == EXPR_NULL
&& a->expr->ts.type == BT_UNKNOWN
&& f->sym->ts.type == BT_CHARACTER
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index c6fb0a6de45a..114f1b6c0458 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -293,11 +293,15 @@ do_ts29113_check (gfc_intrinsic_sym *specific,
gfc_actual_arglist *arg)
&a->expr->where, gfc_current_intrinsic);
ok = false;
}
- else if (a->expr->rank == -1 && !specific->inquiry)
+ else if (a->expr->rank == -1
+ && !(specific->inquiry
+ || (specific->id == GFC_ISYM_RESHAPE
+ && (gfc_option.allow_std & GFC_STD_F202Y))))
{
gfc_error ("Assumed-rank argument at %L is only permitted as actual "
- "argument to intrinsic inquiry functions",
- &a->expr->where);
+ "argument to intrinsic inquiry functions or to RESHAPE. "
+ "The latter is an experimental F202y feature. Use "
+ "-std=f202y to enable", &a->expr->where);
ok = false;
}
else if (a->expr->rank == -1 && arg != a)
@@ -307,6 +311,13 @@ do_ts29113_check (gfc_intrinsic_sym *specific,
gfc_actual_arglist *arg)
&a->expr->where, gfc_current_intrinsic);
ok = false;
}
+ else if (a->expr->rank == -1 && specific->id == GFC_ISYM_RESHAPE
+ && !gfc_is_simply_contiguous (a->expr, true, false))
+ {
+ gfc_error ("Assumed rank argument to the RESHAPE intrinsic at %L "
+ "must be contiguous", &a->expr->where);
+ ok = false;
+ }
}
return ok;
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index a9ac87d3a32f..fc6a8c6d07f3 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -1,5 +1,5 @@
@c Copyright (C) 2004-2024 Free Software Foundation, Inc.
-@c This is part of the GNU Fortran manual.
+@c This is part of the GNU Fortran manual.
@c For copying conditions, see the file gfortran.texi.
@ignore
@@ -139,7 +139,7 @@ by type. Explanations are in the following sections.
-H -P
-U@var{macro} -cpp -dD -dI -dM -dN -dU -fworking-directory
-imultilib @var{dir}
--iprefix @var{file} -iquote -isysroot @var{dir} -isystem @var{dir} -nocpp
+-iprefix @var{file} -iquote -isysroot @var{dir} -isystem @var{dir} -nocpp
-nostdinc
-undef
}
@@ -312,7 +312,7 @@ JIAND, etc...). For a complete list of intrinsics see the
full documentation.
Obsolete flag. The purpose of this option was to
enable legacy math intrinsics such as COTAN and degree-valued trigonometric
functions (e.g. TAND, ATAND, etc...) for compatability with older code. This
-option is no longer operable. The trigonometric functions are now either
+option is no longer operable. The trigonometric functions are now either
part of Fortran 2023 or GNU extensions.
@opindex fdec-static
@@ -341,7 +341,7 @@ following the final comma.
@cindex symbol names
@cindex character set
@item -fdollar-ok
-Allow @samp{$} as a valid non-first character in a symbol name. Symbols
+Allow @samp{$} as a valid non-first character in a symbol name. Symbols
that start with @samp{$} are rejected since it is unclear which rules to
apply to implicit typing as different vendors implement different rules.
Using @samp{$} in @code{IMPLICIT} statements is also rejected.
@@ -606,7 +606,10 @@ beyond the relevant language standard, and warnings are
given for the
Fortran 77 features that are permitted but obsolescent in later
standards. The deprecated option @samp{-std=f2008ts} acts as an alias for
@samp{-std=f2018}. It is only present for backwards compatibility with
-earlier gfortran versions and should not be used any more.
+earlier gfortran versions and should not be used any more. @samp{-std=f202y}
+acts as an alias for @samp{-std=f2023} and enables proposed features for
+testing Fortran 202y. As the Fortran 202y standard develops, implementation
+might change or the experimental new features might be removed.
@opindex ftest-forall-temp
@item -ftest-forall-temp
@@ -718,7 +721,7 @@ Like @option{-dD}, but emit only the macro names, not their
expansions.
@cindex debugging, preprocessor
@item -dU
Like @option{dD} except that only macros that are expanded, or whose
-definedness is tested in preprocessor directives, are output; the
+definedness is tested in preprocessor directives, are output; the
output is delayed until the use or test of the macro; and @code{'#undef'}
directives are also output for macros tested but undefined at the time.
@@ -908,7 +911,7 @@ with a @option{-D} option.
Errors are diagnostic messages that report that the GNU Fortran compiler
cannot compile the relevant piece of source code. The compiler will
continue to process the program in an attempt to report further errors
-to aid in debugging, but will not produce any compiled output.
+to aid in debugging, but will not produce any compiled output.
Warnings are diagnostic messages that report constructions which
are not inherently erroneous but which are risky or suggest there is
@@ -1027,7 +1030,7 @@ avoid such temporaries.
@opindex Wc-binding-type
@cindex warning, C binding type
@item -Wc-binding-type
-Warn if the a variable might not be C interoperable. In particular, warn if
+Warn if the a variable might not be C interoperable. In particular, warn if
the variable has been declared using an intrinsic type with default kind
instead of using a kind parameter defined for C interoperability in the
intrinsic @code{ISO_C_Binding} module. This option is implied by
@@ -1050,7 +1053,7 @@ error.
@cindex warnings, conversion
@cindex conversion
@item -Wconversion
-Warn about implicit conversions that are likely to change the value of
+Warn about implicit conversions that are likely to change the value of
the expression after conversion. Implied by @option{-Wall}.
@opindex Wconversion-extra
@@ -1191,7 +1194,7 @@ the desired intrinsic/procedure. This option is implied
by @option{-Wall}.
@cindex warnings, use statements
@cindex intrinsic
@item -Wuse-without-only
-Warn if a @code{USE} statement has no @code{ONLY} qualifier and
+Warn if a @code{USE} statement has no @code{ONLY} qualifier and
thus implicitly imports all public entities of the used module.
@opindex Wunused-dummy-argument
@@ -1436,8 +1439,8 @@ they are not in the default location expected by the
compiler.
@cindex options, linking
@cindex linking, static
-These options come into play when the compiler links object files into an
-executable output file. They are meaningless if the compiler is not doing
+These options come into play when the compiler links object files into an
+executable output file. They are meaningless if the compiler is not doing
a link step.
@table @gcctabopt
@@ -1609,7 +1612,7 @@ referenced in it. Does not affect common blocks. (Some
Fortran compilers
provide this option under the name @option{-static} or @option{-save}.)
The default, which is @option{-fautomatic}, uses the stack for local
variables smaller than the value given by @option{-fmax-stack-var-size}.
-Use the option @option{-frecursive} to use no static memory.
+Use the option @option{-frecursive} to use no static memory.
Local variables or arrays having an explicit @code{SAVE} attribute are
silently ignored unless the @option{-pedantic} option is added.
@@ -1880,7 +1883,7 @@ Deprecated alias for @option{-fcheck=array-temps}.
@opindex fmax-array-constructor
@item -fmax-array-constructor=@var{n}
-This option can be used to increase the upper limit permitted in
+This option can be used to increase the upper limit permitted in
array constructors. The code below requires this option to expand
the array at compile time.
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 00a16ed167af..f2589a45cae6 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -7,12 +7,12 @@
; 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/>.
@@ -930,6 +930,10 @@ std=f2023
Fortran
Conform to the ISO Fortran 2023 standard.
+std=f202y
+Fortran
+Enable experimental Fortran 202y features.
+
std=f95
Fortran
Conform to the ISO Fortran 95 standard.
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 773f2a0b049f..9e786dd94213 100644
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -23,6 +23,7 @@ along with GCC; see the file COPYING3. If not see
Nevertheless, some features available in F2018 are prohibited in F2023.
Please remember to keep those definitions in sync with
gfortran.texi. */
+#define GFC_STD_F202Y (1<<14) /* Enable proposed F202y features. */
#define GFC_STD_UNSIGNED (1<<14) /* Not really a standard, but
better for error handling. */
#define GFC_STD_F2023_DEL (1<<13) /* Prohibited in F2023. */
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 3a993ede880b..2b3ed4f4cf53 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -1925,7 +1925,29 @@ gfc_match_associate (void)
gfc_association_list* a;
/* Match the next association. */
- if (gfc_match (" %n =>", newAssoc->name) != MATCH_YES)
+ if (gfc_match (" %n ", newAssoc->name) != MATCH_YES)
+ {
+ gfc_error ("Expected associate name at %C");
+ goto assocListError;
+ }
+
+ /* Required for an assumed rank target. */
+ if (gfc_peek_char () == '(')
+ {
+ newAssoc->ar = gfc_get_array_ref ();
+ if (gfc_match_array_ref (newAssoc->ar, NULL, 0, 0) != MATCH_YES)
+ {
+ gfc_error ("Bad bounds remapping list at %C");
+ goto assocListError;
+ }
+ }
+
+ if (newAssoc->ar && !(gfc_option.allow_std & GFC_STD_F202Y))
+ gfc_error_now ("The bounds remapping list at %C is an experimental "
+ "F202y feature. Use std=f202y to enable");
+
+ /* Match the next association. */
+ if (gfc_match (" =>", newAssoc->name) != MATCH_YES)
{
gfc_error ("Expected association at %C");
goto assocListError;
@@ -1969,6 +1991,35 @@ gfc_match_associate (void)
goto assocListError;
}
+ if (newAssoc->target->expr_type == EXPR_VARIABLE
+ && newAssoc->target->symtree->n.sym->as
+ && newAssoc->target->symtree->n.sym->as->type == AS_ASSUMED_RANK)
+ {
+ bool bounds_remapping_list = true;
+ if (!newAssoc->ar)
+ bounds_remapping_list = false;
+ else
+ for (int dim = 0; dim < newAssoc->ar->dimen; dim++)
+ if (!newAssoc->ar->start[dim] || !newAssoc->ar->end[dim]
+ || newAssoc->ar->stride[dim] != NULL)
+ bounds_remapping_list = false;
+
+ if (!bounds_remapping_list)
+ {
+ gfc_error ("The associate name %s with an assumed rank "
+ "target at %L must have a bounds remapping list "
+ "(list of lbound:ubound for each dimension)",
+ newAssoc->name, &newAssoc->target->where);
+ goto assocListError;
+ }
+
+ if (!newAssoc->target->symtree->n.sym->attr.contiguous)
+ {
+ gfc_error ("The assumed rank target at %C must be contiguous");
+ goto assocListError;
+ }
+ }
+
/* The `variable' field is left blank for now; because the target is not
yet resolved, we can't use gfc_has_vector_subscript to determine it
for now. This is set during resolution. */
diff --git a/gcc/fortran/options.cc b/gcc/fortran/options.cc
index a55f1f36f3f9..0004df9278b8 100644
--- a/gcc/fortran/options.cc
+++ b/gcc/fortran/options.cc
@@ -156,7 +156,7 @@ gfc_init_options (unsigned int decoded_options_count,
gfc_option.flag_preprocessed = 0;
gfc_option.flag_d_lines = -1;
set_init_local_zero (0);
-
+
gfc_option.fpe = 0;
/* All except GFC_FPE_INEXACT. */
gfc_option.fpe_summary = GFC_FPE_INVALID | GFC_FPE_DENORMAL
@@ -383,7 +383,7 @@ gfc_post_options (const char **pfilename)
{
gfc_current_form = FORM_FREE;
main_input_filename = filename;
- gfc_warning_now (0, "Reading file %qs as free form",
+ gfc_warning_now (0, "Reading file %qs as free form",
(filename[0] == '\0') ? "<stdin>" : filename);
}
}
@@ -647,7 +647,7 @@ gfc_handle_runtime_check_option (const char *arg)
GFC_RTCHECK_RECURSION, GFC_RTCHECK_DO,
GFC_RTCHECK_POINTER, GFC_RTCHECK_MEM,
GFC_RTCHECK_BITS, 0 };
-
+
while (*arg)
{
while (*arg == ',')
@@ -708,7 +708,7 @@ gfc_handle_option (size_t scode, const char *arg,
HOST_WIDE_INT value,
case OPT_fcheck_array_temporaries:
SET_BITFLAG (gfc_option.rtcheck, value, GFC_RTCHECK_ARRAY_TEMPS);
break;
-
+
case OPT_fd_lines_as_code:
gfc_option.flag_d_lines = 1;
break;
@@ -845,6 +845,15 @@ gfc_handle_option (size_t scode, const char *arg,
HOST_WIDE_INT value,
warn_tabs = 1;
break;
+ case OPT_std_f202y:
+ gfc_option.allow_std = GFC_STD_OPT_F23 | GFC_STD_F202Y;
+ gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F2008_OBS
+ | GFC_STD_F2018_OBS;
+ gfc_option.max_identifier_length = 63;
+ warn_ampersand = 1;
+ warn_tabs = 1;
+ break;
+
case OPT_std_gnu:
set_default_std_flags ();
break;
@@ -883,10 +892,10 @@ gfc_handle_option (size_t scode, const char *arg,
HOST_WIDE_INT value,
}
- Fortran_handle_option_auto (&global_options, &global_options_set,
- scode, arg, value,
- gfc_option_lang_mask (), kind,
- loc, handlers, global_dc);
+ Fortran_handle_option_auto (&global_options, &global_options_set,
+ scode, arg, value,
+ gfc_option_lang_mask (), kind,
+ loc, handlers, global_dc);
return result;
}
@@ -933,7 +942,7 @@ gfc_get_option_string (void)
result = XCNEWVEC (char, len);
- pos = 0;
+ pos = 0;
for (j = 1; j < save_decoded_options_count; j++)
{
switch (save_decoded_options[j].opt_index)
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 1821871819bc..d2fe22d0edc6 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5285,15 +5285,25 @@ parse_associate (void)
if ((!CLASS_DATA (sym)->as && (rank != 0 || corank != 0))
|| (CLASS_DATA (sym)->as
&& (CLASS_DATA (sym)->as->rank != rank
- || CLASS_DATA (sym)->as->corank != corank)))
+ || CLASS_DATA (sym)->as->corank != corank))
+ || rank == -1)
{
/* Don't just (re-)set the attr and as in the sym.ts,
because this modifies the target's attr and as. Copy the
data and do a build_class_symbol. */
symbol_attribute attr = CLASS_DATA (target)->attr;
gfc_typespec type;
-
- if (rank || corank)
+ if (rank == -1 && a->ar)
+ {
+ as = gfc_get_array_spec ();
+ as->rank = a->ar->dimen;
+ as->corank = 0;
+ as->type = AS_DEFERRED;
+ attr.dimension = rank ? 1 : 0;
+ attr.codimension = as->corank ? 1 : 0;
+ sym->assoc->variable = true;
+ }
+ else if (rank || corank)
{
as = gfc_get_array_spec ();
as->type = AS_DEFERRED;
@@ -5319,6 +5329,16 @@ parse_associate (void)
else
sym->attr.class_ok = 1;
}
+ else if (rank == -1 && a->ar)
+ {
+ sym->as = gfc_get_array_spec ();
+ sym->as->rank = a->ar->dimen;
+ sym->as->corank = a->ar->codimen;
+ sym->as->type = AS_DEFERRED;
+ sym->attr.dimension = 1;
+ sym->attr.codimension = sym->as->corank ? 1 : 0;
+ sym->attr.pointer = 1;
+ }
else if ((!sym->as && (rank != 0 || corank != 0))
|| (sym->as
&& (sym->as->rank != rank || sym->as->corank != corank)))
@@ -5336,6 +5356,7 @@ parse_associate (void)
sym->attr.codimension = 1;
}
}
+ gfc_commit_symbols ();
}
accept_statement (ST_ASSOCIATE);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index b93ee56fb357..e57f631eff42 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2276,6 +2276,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag,
bool sub_flag,
}
}
else if (sym->ts.type == BT_CLASS
+ && !(sym->assoc && sym->assoc->ar)
&& tgt_expr
&& tgt_expr->expr_type == EXPR_VARIABLE
&& sym->ts.u.derived != tgt_expr->ts.u.derived)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index ce4bf036c545..c96523e4ad58 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5204,6 +5204,7 @@ find_array_spec (gfc_expr *e)
}
ref->u.ar.as = as;
+ if (ref->u.ar.dimen == -1) ref->u.ar.dimen = as->rank;
as = NULL;
break;
@@ -5808,7 +5809,8 @@ gfc_expression_rank (gfc_expr *e)
break;
}
}
- if (last_arr_ref && last_arr_ref->u.ar.as)
+ if (last_arr_ref && last_arr_ref->u.ar.as
+ && last_arr_ref->u.ar.as->rank != -1)
{
for (i = last_arr_ref->u.ar.as->rank;
i < last_arr_ref->u.ar.as->rank + last_arr_ref->u.ar.as->corank; ++i)
@@ -5952,12 +5954,14 @@ resolve_variable (gfc_expr *e)
&& CLASS_DATA (sym)->as
&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
|| (sym->ts.type != BT_CLASS && sym->as
- && sym->as->type == AS_ASSUMED_RANK))
- && !sym->attr.select_rank_temporary)
+ && sym->as->type == AS_ASSUMED_RANK))
+ && !sym->attr.select_rank_temporary
+ && !(sym->assoc && sym->assoc->ar))
{
if (!actual_arg
&& !(cs_base && cs_base->current
- && cs_base->current->op == EXEC_SELECT_RANK))
+ && (cs_base->current->op == EXEC_SELECT_RANK
+ || sym->attr.target)))
{
gfc_error ("Assumed-rank variable %s at %L may only be used as "
"actual argument", sym->name, &e->where);
@@ -6001,6 +6005,7 @@ resolve_variable (gfc_expr *e)
&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
|| (sym->ts.type != BT_CLASS && sym->as
&& sym->as->type == AS_ASSUMED_RANK))
+ && !(sym->assoc && sym->assoc->ar)
&& e->ref
&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
&& e->ref->next == NULL))
@@ -6117,6 +6122,7 @@ resolve_variable (gfc_expr *e)
newref->type = REF_ARRAY;
newref->u.ar.type = AR_FULL;
newref->u.ar.dimen = 0;
+
/* Because this is an associate var and the first ref either is a ref to
the _data component or not, no traversal of the ref chain is
needed. The array ref needs to be inserted after the _data ref,
@@ -9558,6 +9564,22 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
if (resolve_target && !gfc_resolve_expr (target))
return;
+ if (sym->assoc->ar)
+ {
+ int dim;
+ gfc_array_ref *ar = sym->assoc->ar;
+ for (dim = 0; dim < sym->assoc->ar->dimen; dim++)
+ {
+ if (!(ar->start[dim] && gfc_resolve_expr (ar->start[dim])
+ && ar->start[dim]->ts.type == BT_INTEGER)
+ || !(ar->end[dim] && gfc_resolve_expr (ar->end[dim])
+ && ar->end[dim]->ts.type == BT_INTEGER))
+ gfc_error ("(F202y)Missing or invalid bound in ASSOCIATE rank "
+ "remapping of associate name %s at %L",
+ sym->name, &sym->declared_at);
+ }
+ }
+
/* For variable targets, we get some attributes from the target. */
if (target->expr_type == EXPR_VARIABLE)
{
@@ -9747,7 +9769,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
if (target->ts.type == BT_CLASS)
gfc_fix_class_refs (target);
- if ((target->rank != 0 || target->corank != 0)
+ if ((target->rank > 0 || target->corank > 0)
&& !sym->attr.select_rank_temporary)
{
gfc_array_spec *as;
@@ -16746,7 +16768,9 @@ resolve_symbol (gfc_symbol *sym)
if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
&& !sym->attr.select_type_temporary
&& !(cs_base && cs_base->current
- && cs_base->current->op == EXEC_SELECT_RANK))
+ && (cs_base->current->op == EXEC_SELECT_RANK
+ || ((gfc_option.allow_std & GFC_STD_F202Y)
+ && cs_base->current->op == EXEC_BLOCK))))
{
gfc_error ("Assumed-rank array at %L must be a dummy argument",
&sym->declared_at);
diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc
index 904b00080705..48e4258d10d2 100644
--- a/gcc/fortran/st.cc
+++ b/gcc/fortran/st.cc
@@ -335,6 +335,22 @@ gfc_free_association_list (gfc_association_list* assoc)
if (!assoc)
return;
+ if (assoc->ar)
+ {
+ for (int i = 0; i < assoc->ar->dimen; i++)
+ {
+ if (assoc->ar->start[i]
+ && assoc->ar->start[i]->ts.type == BT_INTEGER)
+ gfc_free_expr (assoc->ar->start[i]);
+ if (assoc->ar->end[i]
+ && assoc->ar->end[i]->ts.type == BT_INTEGER)
+ gfc_free_expr (assoc->ar->end[i]);
+ if (assoc->ar->stride[i]
+ && assoc->ar->stride[i]->ts.type == BT_INTEGER)
+ gfc_free_expr (assoc->ar->stride[i]);
+ }
+ }
+
gfc_free_association_list (assoc->next);
free (assoc);
}
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index dbf7bc880a40..ec7728cb11a7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5045,9 +5045,12 @@ done:
se.descriptor_only = 1;
gfc_conv_expr (&se, arg);
/* This is a bare variable, so there is no preliminary
- or cleanup code. */
- gcc_assert (se.pre.head == NULL_TREE
- && se.post.head == NULL_TREE);
+ or cleanup code unless -std=f202y and bounds checking
+ is on. */
+ if (!((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ && (gfc_option.allow_std & GFC_STD_F202Y)))
+ gcc_assert (se.pre.head == NULL_TREE
+ && se.post.head == NULL_TREE);
rank = gfc_conv_descriptor_rank (se.expr);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 735ab3a21e77..16feff495270 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -3253,6 +3253,31 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
se->expr = gfc_conv_descriptor_data_get (se->expr);
}
+ /* F202Y: Runtime warning that an assumed rank object is associated
+ with an assumed size object. */
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ && (gfc_option.allow_std & GFC_STD_F202Y)
+ && expr->rank == -1 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
+ {
+ tree dim, lower, upper, cond;
+ char *msg;
+
+ dim = fold_convert (signed_char_type_node,
+ gfc_conv_descriptor_rank (se->expr));
+ dim = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
+ dim, build_int_cst (signed_char_type_node, 1));
+ lower = gfc_conv_descriptor_lbound_get (se->expr, dim);
+ upper = gfc_conv_descriptor_ubound_get (se->expr, dim);
+
+ msg = xasprintf ("Assumed rank object %s is associated with an "
+ "assumed size object", sym->name);
+ cond = fold_build2_loc (input_location, LT_EXPR,
+ logical_type_node, upper, lower);
+ gfc_trans_runtime_check (false, true, cond, &se->pre,
+ &gfc_current_locus, msg);
+ free (msg);
+ }
+
/* Some expressions leak through that haven't been fixed up. */
if (IS_INFERRED_TYPE (expr) && expr->ref)
gfc_fixup_inferred_type_refs (expr);
@@ -10830,20 +10855,26 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
/* Copy offset but adjust it such that it would correspond
to a lbound of zero. */
- offs = gfc_conv_descriptor_offset_get (rse.expr);
- for (dim = 0; dim < expr2->rank; ++dim)
+ if (expr2->rank == -1)
+ gfc_conv_descriptor_offset_set (&block, desc,
+ gfc_index_zero_node);
+ else
{
- stride = gfc_conv_descriptor_stride_get (rse.expr,
- gfc_rank_cst[dim]);
- lbound = gfc_conv_descriptor_lbound_get (rse.expr,
- gfc_rank_cst[dim]);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, stride, lbound);
- offs = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, offs, tmp);
+ offs = gfc_conv_descriptor_offset_get (rse.expr);
+ for (dim = 0; dim < expr2->rank; ++dim)
+ {
+ stride = gfc_conv_descriptor_stride_get (rse.expr,
+ gfc_rank_cst[dim]);
+ lbound = gfc_conv_descriptor_lbound_get (rse.expr,
+ gfc_rank_cst[dim]);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride,
+ lbound);
+ offs = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ }
+ gfc_conv_descriptor_offset_set (&block, desc, offs);
}
- gfc_conv_descriptor_offset_set (&block, desc, offs);
-
/* Set the bounds as declared for the LHS and calculate strides as
well as another offset update accordingly. */
stride = gfc_conv_descriptor_stride_get (rse.expr,
@@ -10855,6 +10886,13 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
+ if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
+ || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
+ gfc_resolve_expr (remap->u.ar.start[dim]);
+ if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
+ || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
+ gfc_resolve_expr (remap->u.ar.end[dim]);
+
/* Convert declared bounds. */
gfc_init_se (&lower_se, NULL);
gfc_init_se (&upper_se, NULL);
@@ -10930,7 +10968,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
/* If rank remapping was done, check with -fcheck=bounds that
the target is at least as large as the pointer. */
- if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
+ if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ && expr2->rank != -1)
{
tree lsize, rsize;
tree fault;
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 81d9740b5655..e1a84f228282 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1908,7 +1908,53 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp);
}
+
/* Now all the other kinds of associate variable. */
+
+ /* First we do the F202y ASSOCIATE construct with an assumed rank selector.
+ Since this requires rank remapping, the simplest implementation builds an
+ array reference, using the array ref attached to the association_list,
+ followed by gfc_trans_pointer_assignment. */
+ else if (e->rank == -1 && sym->assoc->ar)
+ {
+ gfc_array_ref *ar;
+ gfc_expr *expr1 = gfc_lval_expr_from_sym (sym);
+ stmtblock_t init;
+ gfc_init_block (&init);
+
+ /* Build the array reference and add to expr1. */
+ gfc_free_ref_list (expr1->ref);
+ expr1->ref = gfc_get_ref();
+ expr1->ref->type = REF_ARRAY;
+ ar = gfc_copy_array_ref (sym->assoc->ar);
+ expr1->ref->u.ar = *ar;
+ expr1->ref->u.ar.type = AR_SECTION;
+
+ /* For class objects, insert the _data component reference. Since the
+ associate-name is a pointer, it needs a target, which is created using
+ its typespec. If unlimited polymorphic, the _len field will be filled
+ by the pointer assignment. */
+ if (expr1->ts.type == BT_CLASS)
+ {
+ need_len_assign = false;
+ gfc_ref *ref;
+ gfc_find_component (expr1->ts.u.derived, "_data", true, true, &ref);
+ ref->next = expr1->ref;
+ expr1->ref = ref;
+ expr1->rank = CLASS_DATA (sym)->as->rank;
+ tmp = gfc_create_var (gfc_typenode_for_spec (&sym->ts), "class");
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ gfc_add_modify (&init, sym->backend_decl, tmp);
+ }
+
+ /* Do the pointer assignment and clean up. */
+ gfc_expr *expr2 = gfc_copy_expr (e);
+ gfc_add_expr_to_block (&init,
+ gfc_trans_pointer_assignment (expr1, expr2));
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL);
+ gfc_free_expr (expr1);
+ gfc_free_expr (expr2);
+ }
else if ((sym->attr.dimension || sym->attr.codimension) && !class_target
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{
@@ -2077,8 +2123,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
- /* Set the offset. */
desc = gfc_class_data_get (se.expr);
+
+ /* Set the offset. */
offset = gfc_index_zero_node;
for (n = 0; n < e->rank; n++)
{
@@ -2088,9 +2135,11 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
gfc_conv_descriptor_stride_get (desc, dim),
gfc_conv_descriptor_lbound_get (desc,
dim));
offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- offset, tmp);
+ gfc_array_index_type,
+ offset, tmp);
}
+ gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
+
if (need_len_assign)
{
if (e->symtree
@@ -2118,7 +2167,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
/* Length assignment done, prevent adding it again below. */
need_len_assign = false;
}
- gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
}
else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
&& CLASS_DATA (e)->attr.dimension)
diff --git a/gcc/testsuite/gfortran.dg/associate_3.f03
b/gcc/testsuite/gfortran.dg/associate_3.f03
index dfd5a99500e4..7f690f3a75b3 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 000000000000..5890af59bfb2
--- /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 000000000000..bca715e7acac
--- /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 <pa...@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 000000000000..74ade73a6a88
--- /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 <pa...@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 000000000000..0fb5b0278770
--- /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 <pa...@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
