Hi All, The moment I saw the DIN4 proposal for "Generic processing of assumed rank objects", I thought that this was a highly intuitive and implementable proposal. I implemented a test version in June and had some correspondence with Reinhold Bader about it shortly before he passed away.
Malcolm Cohen wrote J3/24-136r1 in response to this and I have posted a comment in PR116733 addressing the the extent to which the attached patch addresses his remarks. Before this patch goes through the approval process, we have to consider how experimental F202y features can be carried forward. I was badly bitten by failing to synchronise the array descriptor reform branch to the extent that I gave up on it and adopted the simplified reform that is now in place. Given the likely timescale before the full adoption of the F202y standard, this is a considerable risk for experimental features, given the variability of active maintainers: What I propose is the following: (i) For audit purposes, I have opened PR116732, which should be blocked by PRs for each experimental F202y feature; (ii) These PRs should represent a complete audit trail for each feature; and (iii) All such experimental features should be enabled on mainline by --std=f202y, which is equivalent to -std=f2023+f202y. The attached patch enables pointer assignment and associate, both with rank remapping, plus the reshape intrinsics. which was not part of the DIN4 proposal. The ChangeLog entries do a pretty complete job of describing the patch. Regtests correctly. OK for mainline? Paul
diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index 1fa61ebfe2a..3f724852db9 100644
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -866,7 +866,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;
@@ -875,7 +875,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;
@@ -2454,7 +2454,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 81c641e2322..9e5b141518c 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -4357,9 +4357,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))
{
@@ -4372,6 +4381,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 ia 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 37c28691f41..57890472d04 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3020,6 +3020,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 b592fe4f6c7..dbcbed8bf30 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 0a6be215825..d95f35145b5 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 1225a0f967d..de638a34df3 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
}
@@ -311,7 +311,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 @code{fdec-static}
@@ -340,7 +340,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.
@@ -605,7 +605,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 @code{ftest-forall-temp}
@item -ftest-forall-temp
@@ -717,7 +720,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.
@@ -907,7 +910,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
@@ -1026,7 +1029,7 @@ avoid such temporaries.
@opindex @code{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
@@ -1049,7 +1052,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 @code{Wconversion-extra}
@@ -1190,7 +1193,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 @code{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 @code{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 f5fbe47121c..e3f0f29bbc7 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/>.
@@ -903,6 +903,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 895629d6f80..5cec975dc7d 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_F2023_DEL (1<<13) /* Prohibited in F2023. */
#define GFC_STD_F2023 (1<<12) /* New in F2023. */
#define GFC_STD_F2018_DEL (1<<11) /* Deleted in F2018. */
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 0cd78a57a2f..81610b93345 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -1920,7 +1920,31 @@ 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)
+ {
+ /* "Expected associate name at %C" would be better.
+ Change associate_3.f03 to match. */
+ 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;
@@ -1964,6 +1988,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 d8c5c8e62fc..ce33b3806d3 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);
}
}
@@ -472,7 +472,7 @@ gfc_post_options (const char **pfilename)
/* Implement -fno-automatic as -fmax-stack-var-size=0. */
if (!flag_automatic)
flag_max_stack_var_size = 0;
-
+
/* If the user did not specify an inline matmul limit, inline up to the BLAS
limit or up to 30 if no external BLAS is specified. */
@@ -624,7 +624,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 == ',')
@@ -685,7 +685,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;
@@ -822,6 +822,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;
@@ -857,10 +866,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;
}
@@ -907,7 +916,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 c506e18233e..9eaa8f30f92 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5315,6 +5315,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)))
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index ebe449e7119..512042f56b4 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5807,7 +5807,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)
@@ -5956,7 +5957,8 @@ resolve_variable (gfc_expr *e)
{
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);
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 8c35926436d..e7cd44620af 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -4843,9 +4843,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 07e28a9f7a8..aa0ee1b0164 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -3242,6 +3242,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);
@@ -10759,20 +10784,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,
@@ -10784,6 +10815,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);
@@ -10859,7 +10897,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 86c54970475..450c11c06d7 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1910,6 +1910,20 @@ 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. */
+ else if (e->rank == -1 && sym->attr.pointer && sym->assoc->ar)
+ {
+ gfc_expr *expr1 = gfc_lval_expr_from_sym (sym);
+ gfc_free_ref_list (expr1->ref);
+ expr1->ref = gfc_get_ref();
+ expr1->ref->type = REF_ARRAY;
+ expr1->ref->u.ar = *sym->assoc->ar;
+ expr1->ref->u.ar.type = AR_SECTION;
+ gfc_expr *expr2 = gfc_copy_expr (e);
+ tmp = gfc_trans_pointer_assignment (expr1, expr2);
+ gfc_add_init_cleanup (block, tmp, 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))
{
diff --git a/gcc/testsuite/gfortran.dg/associate_3.f03 b/gcc/testsuite/gfortran.dg/associate_3.f03
index dfd5a99500e..7f690f3a75b 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 00000000000..737a78937a7
--- /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 "-Werror -std=f2023"
+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} ] ] "" "-Werror"
+
+# 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 00000000000..aa6f2cee6c4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/f202y/generic_assumed_rank_1.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+! { dg-options "-std=f202y -Wsurprising -fcheck=bounds" }
+!
+! Test Reinhold Bader's F202y proposal "Generic processing of assumed rank objects".
+!
+! 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) ! { dg-warning "to an assumed-rank dummy" }
+ 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 00000000000..57af12f2891
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/f202y/generic_assumed_rank_2.f90
@@ -0,0 +1,50 @@
+! { dg-do compile }
+! { dg-options "-Wsurprising" }
+!
+! Test Reinhold Bader's F202y proposal "Generic processing of assumed rank objects".
+!
+! 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
Change.Logs
Description: Binary data
