{
int i;
symbol_attribute *attr;
-
+
if (as == NULL)
return true;
attr = &sym->attr;
if (gfc_submodule_procedure(attr))
return true;
-
+
if (as->rank
&& !gfc_add_dimension (&sym->attr, sym->name, error_loc))
return false;
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
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))
{
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)
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;
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
&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)
&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;
@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
-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
}
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
@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.
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
@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.
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
@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
@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
@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
@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
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.
@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.
; 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/>.
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.
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. */
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;
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. */
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
{
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);
}
}
GFC_RTCHECK_RECURSION, GFC_RTCHECK_DO,
GFC_RTCHECK_POINTER, GFC_RTCHECK_MEM,
GFC_RTCHECK_BITS, 0 };
-
+
while (*arg)
{
while (*arg == ',')
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;
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;
}
- 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;
}
result = XCNEWVEC (char, len);
- pos = 0;
+ pos = 0;
for (j = 1; j < save_decoded_options_count; j++)
{
switch (save_decoded_options[j].opt_index)
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;
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)))
sym->attr.codimension = 1;
}
}
+ gfc_commit_symbols ();
}
accept_statement (ST_ASSOCIATE);
}
}
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)
}
ref->u.ar.as = as;
+ if (ref->u.ar.dimen == -1) ref->u.ar.dimen = as->rank;
as = NULL;
break;
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)
&& 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);
&& 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))
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,
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)
{
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;
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);
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);
}
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,
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);
/* 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,
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);
/* 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;
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))
{
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++)
{
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
/* 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)
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'" }
--- /dev/null
+# 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
--- /dev/null
+! { dg-do run }
+! { dg-options "-fcheck=bounds" }
+!
+! Test Reinhold Bader's F202y proposal (J3 DIN4) "Generic processing of assumed
+! rank objects". The present gfortran implementation includes pointer assignment
+! and ASSOCIATE, with rank remapping of the var or associate-name, and RESHAPE.
+! J3 document 24-136r1.txt, by Malcolm Cohen, considers further possibilities.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+ real :: x(2,2,2)
+ real, parameter :: xp(*) = [1,2,3,4,5,6,7,8]
+ x = reshape (xp, [2,2,2])
+ call my_sub (x)
+ if (any (reshape (x, [8]) .ne. xp(8:1:-1))) stop 1
+ call my_assumed_size_target (x)
+contains
+ subroutine my_sub (arg)
+ real, target, contiguous :: arg(..)
+ real, allocatable :: y(:)
+ real, pointer :: argp(:,:)
+ integer :: i
+
+ if (size (arg) .lt. 0) return
+
+ if (size (arg) .ne. 8) stop 10
+
+! Check reshape
+ y = reshape (arg, [size (arg)])
+ if (any (y .ne. xp)) stop 20
+
+! Check pointer assignment
+ argp(1:2,1: size(arg)/2) => arg
+ if (size (argp) .ne. size (x)) stop 30
+ if (any ((argp) .ne. reshape (x, [2, size (x)/2]))) stop 31
+
+! Check ASSOCIATE
+ i = size (arg)
+ associate (a(1:2,1:i/2) => arg)
+ if (any (a .ne. argp)) stop 40
+ end associate
+
+ associate (a(1:size(arg)) => arg)
+ if (any (a .ne. xp)) stop 41
+ a = a(8:1:-1)
+ end associate
+ end
+
+ subroutine my_assumed_size_target (arg)
+ real :: arg(2, 2, *)
+ call my_sub (arg)
+ end
+end
+! { dg-output "Fortran runtime warning: Assumed rank object arg is associated with an assumed size object" }
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f2023 -Wsurprising" }
+!
+! Test Reinhold Bader's F202y proposal (J3 DIN4) "Generic processing of assumed
+! rank objects". The present gfortran implementation includes pointer assignment
+! and ASSOCIATE, with rank remapping of the var or associate-name, and RESHAPE.
+! J3 document 24-136r1.txt, by Malcolm Cohen, considers further possibilities.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+ real :: x(2,2,2)
+ real, parameter :: xp(*) = [1,2,3,4,5,6,7,8]
+ x = reshape (xp, [2,2,2])
+ call my_sub (x)
+ if (any (reshape (x, [8]) .ne. xp(8:1:-1))) stop 1
+ call my_assumed_size_target (x)
+contains
+ subroutine my_sub (arg)
+ real, target, contiguous :: arg(..)
+ real, allocatable :: y(:)
+ real, pointer :: argp(:,:)
+ integer :: i
+
+ if (size (arg) .lt. 0) return
+
+ if (size (arg) .ne. 8) stop 10
+
+! Check reshape
+ y = reshape (arg, [size (arg)]) ! { dg-error "experimental F202y feature" }
+ if (any (y .ne. xp)) stop 20
+
+! Check pointer assignment
+ argp(1:2,1: size(arg)/2) => arg ! { dg-error "experimental F202y feature" }
+ if (size (argp) .ne. size (x)) stop 30
+ if (any ((argp) .ne. reshape (x, [2, size (x)/2]))) stop 31
+
+! Check ASSOCIATE
+ i = size (arg)
+ associate (a(1:2,1:i/2) => arg) ! { dg-error "experimental F202y feature" }
+ if (any (a .ne. argp)) stop 40
+ end associate
+
+ associate (a(1:size(arg)) => arg) ! { dg-error "experimental F202y feature" }
+ if (any (a .ne. xp)) stop 41
+ a = a(8:1:-1)
+ end associate
+ end
+
+ subroutine my_assumed_size_target (arg)
+ real :: arg(2, 2, *)
+ call my_sub (arg) ! { dg-warning "to an assumed-rank dummy" }
+ end
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-std=f202y -Wsurprising" }
+!
+! Test Reinhold Bader's F202y proposal "Generic processing of assumed rank objects".
+! Tests class assumed rank objects.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+ type :: t1
+ integer :: i
+ end type
+ type, extends(t1) :: t2
+ integer :: j
+ end type
+
+ class(t1), allocatable :: x(:,:)
+ type(t2), parameter :: xp(*) = [t2(t1(1),2),t2(t1(3),4),t2(t1(5),6),t2(t1(7),8)]
+ x = reshape (xp, [2,2])
+ call my_sub1 (x)
+ if (any (x(2:1:-1,2:1:-1)%i .ne. reshape (xp%i, [2,2]))) stop 1
+ call my_sub2 (x)
+ if (any (x(2:1:-1,2:1:-1)%i .ne. reshape (xp%i, [2,2]))) stop 2
+ deallocate (x)
+contains
+ subroutine my_sub1 (class_arg)
+ class(t1), contiguous, target :: class_arg(..)
+ class(t1), pointer :: cp(:)
+ integer :: cp_sz
+ integer :: lb(1)
+ integer :: ub(1)
+ integer :: slb = 2
+
+ cp_sz = size (class_arg)
+ cp(slb:slb+cp_sz-1) => class_arg
+ if (any (cp%i .ne. xp%i)) stop 3
+ if (size (cp) .ne. cp_sz) stop 4
+ if (ubound (cp, 1) .ne. slb+cp_sz-1) stop 5
+
+ associate (ca(slb:slb+cp_sz-1) => class_arg)
+ lb = lbound (ca)
+ ub = ubound (ca)
+ if (size (ca) .ne. cp_sz) stop 6
+ if (ubound (ca, 1) .ne. slb+cp_sz-1) stop 7
+ select type (ca)
+ type is (t2)
+ ca = ca(ub(1):lb(1):-1)
+ class default
+ end select
+ end associate
+ end
+
+ subroutine my_sub2 (class_arg)
+ class(*), contiguous, target :: class_arg(..)
+ class(*), pointer :: cp(:, :)
+ integer :: cp_sz
+ cp_sz = size (class_arg)
+ cp(1:cp_sz/2, 1:cp_sz/2) => class_arg
+ call check (cp, cp_sz)
+ associate (ca(2:3,1:2) => class_arg)
+ select type (ca)
+ type is (t2)
+ ca = ca(3:2:-1,2:1:-1)
+ class default
+ end select
+ end associate
+ end
+
+ subroutine check (arg, sz)
+ class(*), intent(inOUT) :: arg(:, :)
+ integer :: sz
+ integer :: lb(2)
+ integer :: ub(2)
+ lb = lbound(arg)
+ ub = ubound(arg)
+ select type (s => arg)
+ type is (t2)
+ s = s(ub(1):lb(1):-1,ub(2):lb(1):-1)
+ if (any (reshape (s(lb(1):ub(1),lb(2):ub(2))%j, [sz]) &
+ .ne. xp%j)) stop 8
+
+ class default
+ stop 9
+ end select
+ end
+end
projects / thirdparty / gcc.git / commitdiff
