Hi All, Thanks to Thomas and Andre for the reviews. I believe that I have addressed all of the concerns in the attached and will commit this afternoon if there are no objections.
Best regards
Paul
On Tue, 24 Sept 2024 at 09:45, Andre Vehreschild <ve...@gmx.de> wrote:
> Hi Paul,
>
> in addition to Thomas' remarks (which I second to), I have the following:
>
> > 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. "
>
> Is it not a convention to write Fortran intrinsics function names all
> uppercase? I.e. RESHAPE when the function is meant just to make it clear
> like in
> the message above on C_LOC and PRESENT (lines 268--270).
>
> > + "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
> "
>
> Here, too?
>
> > + "must be contiguous", &a->expr->where);
> > + ok = false;
> > + }
> > }
> >
> > return ok;
>
> <snipp>
>
> > 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. */
>
> That's an odd comment. Sounds to me like a remark to your self.
>
> > + 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 ();
>
> This is not freeed in case of an error and may result in a memory leak,
> right?
>
> > + 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;
>
> <snipp>
>
> > 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
>
> <snipp>
>
> > @@ -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]);
> > +
>
> Can't these resolves be done during resolve-stage? I have had some serious
> trouble with late resolves, therefore asking.
>
> > /* Convert declared bounds. */
> > gfc_init_se (&lower_se, NULL);
> > gfc_init_se (&upper_se, NULL);
>
> <snipp>
>
> > 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);
>
> What if sym.ts.type == BT_CLASS? I doubt this works in this case...
>
> > + 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))
> > {
>
> <snipp>
>
> > 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
>
> <snipp>
>
> > +global gfortran_test_path
> > +global gfortran_aux_module_flags
> > +set gfortran_test_path $srcdir/$subdir
> > +set gfortran_aux_module_flags "-Werror -std=f2023"
>
> I would have bet, that it should be -std=f202y ...
>
> I mean, the directory says so. I get why you don't do it, but it is soooo
> counter-intuitive to me. I would put my f202y tests in here and would then
> be
> wondering why they don't work out of the box.
>
> <snipp>
>
> I hope those comments help at least a little bit. When you addressed them
> (in
> which way ever), the patch is ok for mainline from my side.
>
> Regards and thanks for the work,
> Andre
>
> On Mon, 23 Sep 2024 16:15:05 +0200
> Thomas Koenig <tkoe...@netcologne.de> wrote:
>
> > Am 23.09.24 um 11:02 schrieb Paul Richard Thomas:
> > > 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.
> >
> > I think your approaches are sound.
> >
> > > 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:
> > >
> >
> > That is correct. We (well, Nicolas) also saw the bit rot on the
> > native coarray branch.
> >
> > > 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;
> >
> > I have added PR 116025 to this.
> >
> > > (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.
> >
> > As far as the -funsigned patch goes: I would like to keep the option
> > itself, but also enable it with -std=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?
> >
> > As a general remark: What we currently have are extensions, and we
> > should try to describe them so a user who is not familiar with the
> > J3 documents or our PRs and commit messages should be able to use
> > the features. I am certainly not there yet with the work on UNSIGNED,
> > but we should work on that so the documentation is fairly complete
> > when gcc15 is released.
> >
> > As for the patch itself: It looks good do me in principle. It still
> > needs some test cases (or did git omit these from your patch?
> > I've been bitten by that :-). One typo:
> >
> > + gfc_error ("The data-target at %L ia an assumed rank object and
> > so the "
> >
> > s/ia/is/
> >
> > So, OK in principle with reasonable test coverage, but if you could hold
> > for a few days before committing so others can also comment, that would
> > be good.
> >
> > Best regards
> >
> > Thomas
> >
>
>
> --
> Andre Vehreschild * Email: vehre ad gmx dot de
>
diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index 773c5b72c85..6dedaed3d4d 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 65bb9f11815..b3e0bf1fd91 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 9e81a81686c..a55646d5604 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 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 c6fb0a6de45..114f1b6c045 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 a9ac87d3a32..fc6a8c6d07f 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 00a16ed167a..f2589a45cae 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 773f2a0b049..bb71c313246 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<<15) /* 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 3a993ede880..2b3ed4f4cf5 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 a55f1f36f3f..0004df9278b 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 1821871819b..d2fe22d0edc 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 b93ee56fb35..e57f631eff4 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 ce4bf036c54..c96523e4ad5 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 904b0008070..48e4258d10d 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 dbf7bc880a4..ec7728cb11a 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 735ab3a21e7..16feff49527 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 81d9740b565..e1a84f22828 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/m2/gm2-compiler/M2MetaError.mod b/gcc/m2/gm2-compiler/M2MetaError.mod
index e9f3127925c..14df6457d64 100644
--- a/gcc/m2/gm2-compiler/M2MetaError.mod
+++ b/gcc/m2/gm2-compiler/M2MetaError.mod
@@ -1684,7 +1684,7 @@ END copySym ;
(*
- op := {'!'|'a'|'c'|'d'|'k'|'q'|'t'|'p'|'n'|'s'|'u'|
+ op := {'!'|'a'|'c'|'d'|'k'|'n'|'p'|'q'|'s'|'t'|'u'|
'A'|'B'|'C'|'D'|'E'|'F'|'G'|'H'|'K'|'M'|'N'|
'O'|'P'|'Q'|'R'|'S'|'T'|'U'|'V'|'W'|'X'|'Y'|'Z'} then =:
*)
@@ -1707,11 +1707,11 @@ BEGIN
'd': doDesc (eb, sym, bol) |
'k': unquotedKeyword (eb) ;
DEC (eb.ini) |
- 'q': doQualified (eb, sym, bol) |
- 't': doType (eb, sym, bol) |
- 'p': popColor (eb) |
'n': doNumber (eb, sym, bol) |
+ 'p': popColor (eb) |
+ 'q': doQualified (eb, sym, bol) |
's': doSkipType (eb, sym, bol) |
+ 't': doType (eb, sym, bol) |
'u': eb.quotes := FALSE |
'A': eb.type := aborta ;
seenAbort := TRUE |
diff --git a/gcc/m2/gm2-compiler/P2SymBuild.def b/gcc/m2/gm2-compiler/P2SymBuild.def
index 45b52f7f02d..ae736886e8a 100644
--- a/gcc/m2/gm2-compiler/P2SymBuild.def
+++ b/gcc/m2/gm2-compiler/P2SymBuild.def
@@ -21,15 +21,6 @@ along with GNU Modula-2; see the file COPYING3. If not see
DEFINITION MODULE P2SymBuild ;
-(*
- Title : P2SymBuild
- Author : Gaius Mulley
- Date : 24/6/87
- LastEdit : Sat Dec 9 11:10:57 EST 1989
- System : UNIX (GNU Modula-2)
- Description: pass 2 symbol creation.
-*)
-
(*
BlockStart - tokno is the module/procedure/implementation/definition token
diff --git a/gcc/m2/gm2-compiler/P2SymBuild.mod b/gcc/m2/gm2-compiler/P2SymBuild.mod
index 9edb911949e..2196b584eb5 100644
--- a/gcc/m2/gm2-compiler/P2SymBuild.mod
+++ b/gcc/m2/gm2-compiler/P2SymBuild.mod
@@ -2055,7 +2055,7 @@ PROCEDURE GetComparison (left, right: CARDINAL) : String ;
BEGIN
IF left < right
THEN
- RETURN InitString ('less')
+ RETURN InitString ('fewer')
ELSIF left > right
THEN
RETURN InitString ('more')
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..5890af59bfb
--- /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 00000000000..bca715e7aca
--- /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 00000000000..74ade73a6a8
--- /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 00000000000..0fb5b027877
--- /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
Change.Logs
Description: Binary data
