[PATCH] fortran: [PR49802] Allow VALUE attribute on assumed-length CHARACTER and array dummies
Jerry D <[email protected]>
| Newsgroups | gmane.comp.gcc.patches,gmane.comp.gcc.fortran |
|---|---|
| Message-ID | <[email protected]> |
This is the next one up on my list. This bug has been around since July of 2011.
As stated in the PR, I rolled the two patches submitted there into one patch and
started testing and digging on this. I had to do a lot of editing and messaging
on this. There are several more test cases.
See the attached diff.
Regression tested numerous times. Comments welcome.
OK for mainline?
Regards,
Jerry
---
fortran: [PR49802] Allow VALUE attribute on assumed-length CHARACTER and
array dummies
Fortran 2003 prohibited VALUE on CHARACTER dummies of length other than
one (C528) and on any array dummy (C527). Fortran 2008 relaxed both
restrictions with C557, prohibiting only assumed-size arrays, coarrays,
and entities with a coarray ultimate component. gfortran still rejected
both cases; this patch implements the Fortran 2008 rules under
gfc_notify_std, so -std=f2003 still rejects them, and consolidates the
C-interop length checks into one "must have length one" condition.
VALUE dummies of these kinds are still passed by reference (trans-types.cc),
since VALUE now means copy-in-only semantics rather than pass-by-value of
the raw data. trans-expr.cc makes the copy: a caller-side VLA copy for
non-constant-length CHARACTER dummies, and a private deep array copy via
gfc_conv_subref_array_arg for array dummies, with no write-back to the
actual argument. A scalar actual argument sequence associated with an
explicit-shape VALUE array dummy (F2023, 15.5.2.12) is copied by the new
conv_seq_assoc_value_arg. Neither copy is made when the actual argument
is an absent optional one; fixing this exposed two latent bugs in the
pass_optional path of gfc_conv_subref_array_arg.
PR fortran/49802
gcc/fortran/ChangeLog:
* resolve.cc: Allow character(len=*) VALUE and a specified but
non-constant length under Fortran 2008; consolidate the
C-interop length checks into a single "must have length one"
check ordered ahead of the Fortran 2008 allowance. Allow VALUE
on assumed-shape and explicit-shape array dummies under Fortran
2008 (C557); reject it on assumed-size arrays, on array dummies
of a BIND(C) procedure, and, as not yet implemented, on
polymorphic array dummies.
* symbol.cc (gfc_check_conflict): Remove the conflict between
VALUE and DIMENSION; only VALUE and CODIMENSION remain mutually
exclusive.
* trans.h (gfc_conv_subref_array_arg): Add DEEP_COPY argument.
* trans-expr.cc (gfc_conv_subref_array_arg): Take DEEP_COPY and
pass it on to gfc_trans_scalar_assign; deallocate the allocatable
components of the temporary after the call. Dereference the
descriptor when setting the pointer for an optional argument that
is not also checked for contiguity, and pass the string length
back to the caller's gfc_se.
(has_value_array_dummy): New function.
(conv_seq_assoc_value_arg): New function. Copy the element
sequence declared by a VALUE array dummy when the actual argument
is a sequence associated scalar.
(conv_dummy_value): For assumed-length or non-constant-length
CHARACTER VALUE dummies, make a caller-side copy and pass its
address; scale the copy size by the size of the character kind;
suppress the copy and pass a null pointer and a zero length when
the actual argument is an absent optional one.
(gfc_conv_procedure_call): Request an interface mapping when a
dummy is an explicit-shape VALUE array. Call
conv_seq_assoc_value_arg for a scalar actual argument passed to a
VALUE array dummy. For a VALUE array dummy, pass a private deep
copy of the actual argument via gfc_conv_subref_array_arg with
INTENT_IN, giving it the symbol of the actual argument so that an
absent optional one suppresses the copy.
* trans-types.cc (gfc_sym_type): Use byref=1 for assumed-length
or non-constant-length VALUE character dummies and for VALUE
array dummies, so the ABI still passes by reference.
gcc/testsuite/ChangeLog:
* gfortran.dg/value_3.f90: Remove now-invalid expectation that
an explicit-shape array dummy with VALUE conflicts with
DIMENSION; this combination is permitted (F2008, C557).
* gfortran.dg/value_5.f90: Compile under -std=f2003 so the
Fortran 2008 assumed-length VALUE relaxation is exercised as a
rejection, and update the C-interop error expectation to match
the consolidated diagnostic.
* gfortran.dg/value_6.f90: New test - run test for correctness
with assumed-length VALUE character dummies.
* gfortran.dg/value_7.f90: New test - compile/error test for
-std=f2003 rejection.
* gfortran.dg/value_11.f90: New test - run test for correctness
with a non-constant specified-length VALUE character dummy.
* gfortran.dg/value_12.f90: New test - run test for VALUE on
assumed-shape, explicit-shape, and non-contiguous array actuals.
* gfortran.dg/value_13.f90: New test - compile test rejecting
VALUE on an assumed-size array dummy under -std=f2008.
* gfortran.dg/value_14.f90: New test - run test for a VALUE
character dummy of a kind wider than one byte.
* gfortran.dg/value_15.f90: New test - run test for a scalar
actual argument sequence associated with a VALUE array dummy.
* gfortran.dg/value_16.f90: New test - run test for the deep copy
of a VALUE array dummy with allocatable components.
* gfortran.dg/value_17.f90: New test - compile test rejecting
VALUE array dummies in a BIND(C) procedure and polymorphic VALUE
array dummies.
* gfortran.dg/value_18.f90: New test - run test for an absent
optional actual argument passed to an optional VALUE dummy.
* gfortran.dg/assumed_rank_11.f90: Update expected diagnostic
for VALUE on an assumed-rank dummy.
* gfortran.dg/c-interop/c535a-2.f90: Likewise.
---
pr49802.diff
(text/x-patch, 44.3 KB)
commit 772f8878be71fa2384069c4b5971f5edbc7e6da5 Author: Jerry DeLisle <[email protected]> Date: Fri Jun 12 10:27:40 2026 -0700 fortran: [PR49802] Allow VALUE attribute on assumed-length CHARACTER and array dummies Fortran 2003 prohibited VALUE on CHARACTER dummies of length other than one (C528) and on any array dummy (C527). Fortran 2008 relaxed both restrictions with C557, prohibiting only assumed-size arrays, coarrays, and entities with a coarray ultimate component. gfortran still rejected both cases; this patch implements the Fortran 2008 rules under gfc_notify_std, so -std=f2003 still rejects them, and consolidates the C-interop length checks into one "must have length one" condition. VALUE dummies of these kinds are still passed by reference (trans-types.cc), since VALUE now means copy-in-only semantics rather than pass-by-value of the raw data. trans-expr.cc makes the copy: a caller-side VLA copy for non-constant-length CHARACTER dummies, and a private deep array copy via gfc_conv_subref_array_arg for array dummies, with no write-back to the actual argument. A scalar actual argument sequence associated with an explicit-shape VALUE array dummy (F2023, 15.5.2.12) is copied by the new conv_seq_assoc_value_arg. Neither copy is made when the actual argument is an absent optional one; fixing this exposed two latent bugs in the pass_optional path of gfc_conv_subref_array_arg. PR fortran/49802 gcc/fortran/ChangeLog: * resolve.cc: Allow character(len=*) VALUE and a specified but non-constant length under Fortran 2008; consolidate the C-interop length checks into a single "must have length one" check ordered ahead of the Fortran 2008 allowance. Allow VALUE on assumed-shape and explicit-shape array dummies under Fortran 2008 (C557); reject it on assumed-size arrays, on array dummies of a BIND(C) procedure, and, as not yet implemented, on polymorphic array dummies. * symbol.cc (gfc_check_conflict): Remove the conflict between VALUE and DIMENSION; only VALUE and CODIMENSION remain mutually exclusive. * trans.h (gfc_conv_subref_array_arg): Add DEEP_COPY argument. * trans-expr.cc (gfc_conv_subref_array_arg): Take DEEP_COPY and pass it on to gfc_trans_scalar_assign; deallocate the allocatable components of the temporary after the call. Dereference the descriptor when setting the pointer for an optional argument that is not also checked for contiguity, and pass the string length back to the caller's gfc_se. (has_value_array_dummy): New function. (conv_seq_assoc_value_arg): New function. Copy the element sequence declared by a VALUE array dummy when the actual argument is a sequence associated scalar. (conv_dummy_value): For assumed-length or non-constant-length CHARACTER VALUE dummies, make a caller-side copy and pass its address; scale the copy size by the size of the character kind; suppress the copy and pass a null pointer and a zero length when the actual argument is an absent optional one. (gfc_conv_procedure_call): Request an interface mapping when a dummy is an explicit-shape VALUE array. Call conv_seq_assoc_value_arg for a scalar actual argument passed to a VALUE array dummy. For a VALUE array dummy, pass a private deep copy of the actual argument via gfc_conv_subref_array_arg with INTENT_IN, giving it the symbol of the actual argument so that an absent optional one suppresses the copy. * trans-types.cc (gfc_sym_type): Use byref=1 for assumed-length or non-constant-length VALUE character dummies and for VALUE array dummies, so the ABI still passes by reference. gcc/testsuite/ChangeLog: * gfortran.dg/value_3.f90: Remove now-invalid expectation that an explicit-shape array dummy with VALUE conflicts with DIMENSION; this combination is permitted (F2008, C557). * gfortran.dg/value_5.f90: Compile under -std=f2003 so the Fortran 2008 assumed-length VALUE relaxation is exercised as a rejection, and update the C-interop error expectation to match the consolidated diagnostic. * gfortran.dg/value_6.f90: New test - run test for correctness with assumed-length VALUE character dummies. * gfortran.dg/value_7.f90: New test - compile/error test for -std=f2003 rejection. * gfortran.dg/value_11.f90: New test - run test for correctness with a non-constant specified-length VALUE character dummy. * gfortran.dg/value_12.f90: New test - run test for VALUE on assumed-shape, explicit-shape, and non-contiguous array actuals. * gfortran.dg/value_13.f90: New test - compile test rejecting VALUE on an assumed-size array dummy under -std=f2008. * gfortran.dg/value_14.f90: New test - run test for a VALUE character dummy of a kind wider than one byte. * gfortran.dg/value_15.f90: New test - run test for a scalar actual argument sequence associated with a VALUE array dummy. * gfortran.dg/value_16.f90: New test - run test for the deep copy of a VALUE array dummy with allocatable components. * gfortran.dg/value_17.f90: New test - compile test rejecting VALUE array dummies in a BIND(C) procedure and polymorphic VALUE array dummies. * gfortran.dg/value_18.f90: New test - run test for an absent optional actual argument passed to an optional VALUE dummy. * gfortran.dg/assumed_rank_11.f90: Update expected diagnostic for VALUE on an assumed-rank dummy. * gfortran.dg/c-interop/c535a-2.f90: Likewise. diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 484397da5f8..625dd2310fb 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -18867,6 +18867,42 @@ skip_interfaces: "CODIMENSION attribute", &sym->declared_at); return; } + + /* F2008, C557 (F2018, C862; F2023, C867). Assumed-shape and + explicit-shape array dummies may have the VALUE attribute, but + assumed-size arrays may not. */ + if (as->type == AS_ASSUMED_SIZE && sym->attr.value) + { + gfc_error ("Assumed-size array %qs at %L may not have the VALUE " + "attribute", sym->name, &sym->declared_at); + return; + } + else if (sym->attr.value && sym->attr.dummy + && (as->type == AS_EXPLICIT || as->type == AS_ASSUMED_SHAPE)) + { + if (!gfc_notify_std (GFC_STD_F2008, "Array dummy argument %qs at " + "%L with VALUE attribute", sym->name, + &sym->declared_at)) + return; + + /* F2023, 18.3.6 (4): only a scalar VALUE dummy is interoperable + with a formal parameter of the C prototype. */ + if (sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c) + { + gfc_error ("Array dummy argument %qs at %L with VALUE attribute " + "not allowed in BIND(C) procedure %qs", sym->name, + &sym->declared_at, sym->ns->proc_name->name); + return; + } + + if (sym->ts.type == BT_CLASS) + { + gfc_error ("Sorry, polymorphic array dummy argument %qs at %L " + "with VALUE attribute is not yet implemented", + sym->name, &sym->declared_at); + return; + } + } } /* Make sure symbols with known intent or optional are really dummy @@ -18890,7 +18926,7 @@ skip_interfaces: if (sym->attr.value && sym->ts.type == BT_CHARACTER) { gfc_charlen *cl = sym->ts.u.cl; - if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) + if (!cl) { gfc_error ("Character dummy variable %qs at %L with VALUE " "attribute must have constant length", @@ -18898,14 +18934,32 @@ skip_interfaces: return; } + /* C interoperable character dummies must have length one. */ if (sym->ts.is_c_interop - && mpz_cmp_si (cl->length->value.integer, 1) != 0) + && (!cl->length + || cl->length->expr_type != EXPR_CONSTANT + || mpz_cmp_si (cl->length->value.integer, 1) != 0)) { gfc_error ("C interoperable character dummy variable %qs at %L " "with VALUE attribute must have length one", sym->name, &sym->declared_at); return; } + + /* Assumed-length character dummy with VALUE, valid since F2008. */ + if (!cl->length + && !gfc_notify_std (GFC_STD_F2008, "Assumed-length character " + "dummy variable %qs at %L with VALUE attribute", + sym->name, &sym->declared_at)) + return; + + /* Likewise for a specified but non-constant length. */ + if (cl->length && cl->length->expr_type != EXPR_CONSTANT + && !gfc_notify_std (GFC_STD_F2008, "Character dummy variable " + "%qs at %L with VALUE attribute and " + "non-constant length", + sym->name, &sym->declared_at)) + return; } if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 36e1262fff5..7b52b7aef98 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -694,7 +694,6 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (value, subroutine) conf (value, function) conf (value, volatile_) - conf (value, dimension) conf (value, codimension) conf (value, external) diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 7656f9784dd..50f53478a85 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -5556,7 +5556,8 @@ void gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77, sym_intent intent, bool formal_ptr, const gfc_symbol *fsym, const char *proc_name, - gfc_symbol *sym, bool check_contiguous) + gfc_symbol *sym, bool check_contiguous, + bool deep_copy) { gfc_se lse; gfc_se rse; @@ -5668,7 +5669,7 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77, if (intent != INTENT_OUT) { - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, deep_copy, false); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); gfc_trans_scalarizing_loops (&loop, &body); @@ -5800,6 +5801,19 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77, class_array_fcn: + /* A deep copy allocated fresh components for the temporary; free them + again once the call has returned, before the temporary itself goes. + Only INTENT_IN is supported, as writing the temporary back would leave + the actual argument holding the freed component pointers. */ + gcc_assert (!deep_copy || intent == INTENT_IN); + if (deep_copy && expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.alloc_comp) + { + tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, parmse->expr, + dimen); + gfc_add_expr_to_block (&parmse->post, tmp); + } + gfc_add_block_to_block (&parmse->post, &loop.post); gfc_cleanup_loop (&loop); @@ -5965,8 +5979,11 @@ class_array_fcn: } else { - /* pointer = pramse->expr; . */ - gfc_add_modify (&parmse->pre, pointer, parmse->expr); + /* pointer = parmse->expr; . */ + tmp = (GFC_DESCRIPTOR_TYPE_P (type) + ? build_fold_indirect_ref_loc (input_location, parmse->expr) + : parmse->expr); + gfc_add_modify (&parmse->pre, pointer, tmp); pre_stmts = gfc_finish_block (&parmse->pre); } @@ -6048,6 +6065,7 @@ class_array_fcn: gcc_assert (!pass_optional); } se->expr = pointer; + se->string_length = parmse->string_length; } return; @@ -6699,6 +6717,207 @@ gfc_const_length_character_type_p (gfc_typespec *ts) } +/* Returns true if FORMAL contains an explicit-shape array dummy with the + VALUE attribute. The bounds of such a dummy may have to be evaluated + on the caller side, which needs an interface mapping. */ + +static bool +has_value_array_dummy (gfc_formal_arglist *formal) +{ + for (; formal; formal = formal->next) + if (formal->sym && formal->sym->attr.value && formal->sym->attr.dimension + && formal->sym->as && formal->sym->as->type == AS_EXPLICIT) + return true; + + return false; +} + + +/* Sequence association (F2023, 15.5.2.12) of a scalar actual argument E with + an explicit-shape array dummy FSYM that has the VALUE attribute. Copy as + many elements as the dummy declares into a temporary and pass that. + MAPPING supplies the caller-side values of any dummy arguments appearing + in the bounds or the character length of FSYM. */ + +static void +conv_seq_assoc_value_arg (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym, + gfc_interface_mapping *mapping) +{ + tree nelems, eltype, eltsize, tmpvar, src, tmp; + gfc_se se; + int n; + + gcc_assert (fsym->as && fsym->as->type == AS_EXPLICIT); + + /* Address of the first element of the actual argument's sequence. */ + gfc_init_se (&se, NULL); + if (e->ts.type == BT_CHARACTER) + { + gfc_conv_expr (&se, e); + gfc_conv_string_parameter (&se); + /* The hidden length argument is that of the actual argument, as it + is for a dummy that does not have the VALUE attribute. */ + parmse->string_length = se.string_length; + } + else + gfc_conv_expr_reference (&se, e); + gfc_add_block_to_block (&parmse->pre, &se.pre); + gfc_add_block_to_block (&parmse->post, &se.post); + src = se.expr; + + /* Number of elements of the dummy. */ + nelems = gfc_index_one_node; + for (n = 0; n < fsym->as->rank; n++) + { + tree lbound, ubound, extent; + + gfc_init_se (&se, NULL); + gfc_apply_interface_mapping (mapping, &se, fsym->as->upper[n]); + gfc_add_block_to_block (&parmse->pre, &se.pre); + gfc_add_block_to_block (&parmse->post, &se.post); + ubound = fold_convert (gfc_array_index_type, se.expr); + + if (fsym->as->lower[n]) + { + gfc_init_se (&se, NULL); + gfc_apply_interface_mapping (mapping, &se, fsym->as->lower[n]); + gfc_add_block_to_block (&parmse->pre, &se.pre); + gfc_add_block_to_block (&parmse->post, &se.post); + lbound = fold_convert (gfc_array_index_type, se.expr); + } + else + lbound = gfc_index_one_node; + + extent = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + extent = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, extent, + gfc_index_one_node); + extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, + extent, gfc_index_zero_node); + nelems = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, nelems, extent); + } + nelems = gfc_evaluate_now (nelems, &parmse->pre); + + /* Element type and size of the dummy. For characters the element + sequence is grouped by the character length of the dummy. */ + if (fsym->ts.type == BT_CHARACTER) + { + tree len; + + if (fsym->ts.u.cl->length) + { + gfc_init_se (&se, NULL); + gfc_apply_interface_mapping (mapping, &se, fsym->ts.u.cl->length); + gfc_add_block_to_block (&parmse->pre, &se.pre); + gfc_add_block_to_block (&parmse->post, &se.post); + len = fold_convert (gfc_charlen_type_node, se.expr); + } + else + len = fold_convert (gfc_charlen_type_node, parmse->string_length); + + eltype = gfc_get_character_type_len (fsym->ts.kind, len); + eltsize = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + fold_convert (size_type_node, len), + fold_convert (size_type_node, + TYPE_SIZE_UNIT (gfc_get_char_type + (fsym->ts.kind)))); + } + else + { + eltype = gfc_typenode_for_spec (&fsym->ts); + eltsize = fold_convert (size_type_node, TYPE_SIZE_UNIT (eltype)); + } + + /* The temporary holding the copy. Allocate at least one element so that + a zero-sized dummy does not produce a degenerate array type. */ + tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, + nelems, gfc_index_one_node); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + tmp = build_array_type (eltype, build_range_type (gfc_array_index_type, + gfc_index_zero_node, tmp)); + tmpvar = gfc_create_var (tmp, "seq_copy"); + gfc_add_expr_to_block (&parmse->pre, + fold_build1_loc (input_location, DECL_EXPR, tmp, + tmpvar)); + + tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + fold_convert (size_type_node, nelems), eltsize); + tmp = gfc_build_memcpy_call (fold_convert (pvoid_type_node, + gfc_build_addr_expr (NULL_TREE, + tmpvar)), + fold_convert (pvoid_type_node, src), tmp); + gfc_add_expr_to_block (&parmse->pre, tmp); + + /* The memcpy also copied the component pointers of a derived type, which + would leave the temporary sharing the actual argument's allocatable + components. Give the copy components of its own and free them again + once the call has returned. */ + if (fsym->ts.type == BT_DERIVED && fsym->ts.u.derived->attr.alloc_comp) + { + tree srcp = fold_convert (build_pointer_type (eltype), src); + + for (n = 0; n < 2; n++) + { + stmtblock_t loop_block, body; + tree idx, exit_label, delt; + + idx = gfc_create_var (gfc_array_index_type, "idx"); + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + + gfc_start_block (&loop_block); + gfc_add_modify (&loop_block, idx, gfc_index_zero_node); + + gfc_start_block (&body); + tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, + idx, nelems); + tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, exit_label), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&body, tmp); + + delt = gfc_build_array_ref (tmpvar, idx, NULL_TREE); + if (n == 0) + { + tree off = fold_build2_loc (input_location, MULT_EXPR, sizetype, + fold_convert (sizetype, idx), eltsize); + tree selt + = build_fold_indirect_ref_loc (input_location, + fold_build_pointer_plus_loc + (input_location, srcp, off)); + tmp = gfc_copy_alloc_comp (fsym->ts.u.derived, selt, delt, 0, 0); + } + else + tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived, delt, 0); + gfc_add_expr_to_block (&body, tmp); + + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + idx, gfc_index_one_node); + gfc_add_modify (&body, idx, tmp); + + gfc_add_expr_to_block (&loop_block, + build1_v (LOOP_EXPR, gfc_finish_block (&body))); + gfc_add_expr_to_block (&loop_block, build1_v (LABEL_EXPR, exit_label)); + + tmp = gfc_finish_block (&loop_block); + if (n == 0) + gfc_add_expr_to_block (&parmse->pre, tmp); + else + gfc_add_expr_to_block (&parmse->post, tmp); + } + } + + if (fsym->ts.type == BT_CHARACTER) + parmse->expr + = gfc_build_addr_expr (build_pointer_type (gfc_get_char_type + (fsym->ts.kind)), tmpvar); + else + parmse->expr = gfc_build_addr_expr (build_pointer_type (eltype), tmpvar); +} + + /* Helper function for the handling of (currently) scalar dummy variables with the VALUE attribute. Argument parmse should already be set up. */ static void @@ -6754,6 +6973,59 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym, return; } + /* Assumed-length or non-constant-length CHARACTER VALUE dummy: copy + the actual argument and pass the copy. */ + if (fsym->ts.type == BT_CHARACTER + && (!fsym->ts.u.cl || !fsym->ts.u.cl->length + || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT)) + { + /* An optional actual argument that is absent has nothing to copy + from; pass a null pointer and a length of zero instead. */ + tree present = NULL_TREE; + if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional) + present = gfc_conv_expr_present (e->symtree->n.sym); + + gfc_conv_string_parameter (parmse); + tree len = fold_convert (gfc_charlen_type_node, parmse->string_length); + if (present) + { + len = fold_build3_loc (input_location, COND_EXPR, + gfc_charlen_type_node, present, len, + build_zero_cst (gfc_charlen_type_node)); + len = gfc_evaluate_now (len, &parmse->pre); + parmse->string_length = len; + } + tree chartype = gfc_get_character_type_len (fsym->ts.kind, len); + tree val_copy = gfc_create_var (chartype, "val_copy"); + tmp = fold_build1_loc (input_location, DECL_EXPR, chartype, val_copy); + gfc_add_expr_to_block (&parmse->pre, tmp); + /* The copy size is in bytes, not in characters. */ + tree bytes + = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + fold_convert (size_type_node, len), + fold_convert (size_type_node, + TYPE_SIZE_UNIT (gfc_get_char_type + (fsym->ts.kind)))); + tmp = gfc_build_memcpy_call ( + fold_convert (pvoid_type_node, + gfc_build_addr_expr (NULL_TREE, val_copy)), + fold_convert (pvoid_type_node, parmse->expr), bytes); + if (present) + tmp = build3_v (COND_EXPR, present, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&parmse->pre, tmp); + parmse->expr = fold_convert ( + build_pointer_type (gfc_get_char_type (fsym->ts.kind)), + gfc_build_addr_expr (NULL_TREE, val_copy)); + if (present) + parmse->expr = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (parmse->expr), present, + parmse->expr, + fold_convert (TREE_TYPE (parmse->expr), + null_pointer_node)); + } + /* Truncate a too long constant character actual argument. */ if (gfc_const_length_character_type_p (&fsym->ts) && e->expr_type == EXPR_CONSTANT @@ -7049,7 +7321,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length && sym->ts.u.cl->length->expr_type - != EXPR_CONSTANT); + != EXPR_CONSTANT) || + has_value_array_dummy (formal); } else { @@ -7058,7 +7331,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, (comp->ts.type == BT_CHARACTER && comp->ts.u.cl->length && comp->ts.u.cl->length->expr_type - != EXPR_CONSTANT); + != EXPR_CONSTANT) || + has_value_array_dummy (formal); } base_object = NULL_TREE; @@ -7384,6 +7658,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Implement F2018, 18.3.6, list item (5), bullet point 2. */ gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym); + else if (fsym && fsym->attr.value && fsym->attr.dimension) + /* Scalar actual argument sequence associated with a VALUE + array dummy. */ + conv_seq_assoc_value_arg (&parmse, e, fsym, &mapping); + else if (fsym && fsym->attr.value) { if (fsym->ts.type == BT_CHARACTER @@ -7983,6 +8262,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Implement F2018, 18.3.6, list item (5), bullet point 2. */ gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym); + else if (fsym && fsym->attr.value && fsym->attr.dimension + && e->rank != -1) + /* VALUE array dummy: pass a private copy of the actual + argument. The symbol passed is that of the actual + argument, so that the copy is suppressed. A null + pointer passed when an optional actual argument is absent. */ + gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, INTENT_IN, + false, fsym, sym->name, + e->expr_type == EXPR_VARIABLE + ? e->symtree->n.sym : NULL, + false, true); + else if (e->expr_type == EXPR_VARIABLE && is_subref_array (e) && !(fsym && fsym->attr.pointer)) diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index ea4395c67dd..04786b83746 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -2521,7 +2521,12 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c) else type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension); - if (sym->attr.dummy && !sym->attr.function && !sym->attr.value + if (sym->attr.dummy && !sym->attr.function + && (!sym->attr.value + || sym->attr.dimension + || (sym->ts.type == BT_CHARACTER + && (!sym->ts.u.cl || !sym->ts.u.cl->length + || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT))) && !sym->pass_as_value) byref = 1; else diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 0bdee5820fd..7b28ecfce47 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -564,7 +564,8 @@ void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool, const gfc_symbol *fsym = NULL, const char *proc_name = NULL, gfc_symbol *sym = NULL, - bool check_contiguous = false); + bool check_contiguous = false, + bool deep_copy = false); void gfc_conv_is_contiguous_expr (gfc_se *, gfc_expr *); diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_11.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_11.f90 index 46dffd0740b..ed87ca73ee7 100644 --- a/gcc/testsuite/gfortran.dg/assumed_rank_11.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_rank_11.f90 @@ -42,11 +42,11 @@ subroutine orig(X) ! { dg-error "may not have the VALUE or CODIMENSION attribute integer :: x(..)[*] end -subroutine val1(X) - integer, value :: x(..) ! { dg-error "VALUE attribute conflicts with DIMENSION attribute" } +subroutine val1(X) ! { dg-error "may not have the VALUE or CODIMENSION attribute" } + integer, value :: x(..) end -subroutine val2(X) +subroutine val2(X) ! { dg-error "may not have the VALUE or CODIMENSION attribute" } integer, value :: x - dimension :: x(..) ! { dg-error "VALUE attribute conflicts with DIMENSION attribute" } + dimension :: x(..) end diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535a-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535a-2.f90 index 816e69124ce..742c0f878a5 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/c535a-2.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/c535a-2.f90 @@ -71,8 +71,8 @@ subroutine s2 (b) ! { dg-error "has no IMPLICIT type" } integer, codimension[*] :: b(..) ! { dg-error "assumed-rank array" } end subroutine -subroutine s5 (e) ! { dg-error "has no IMPLICIT type" } +subroutine s5 (e) ! { dg-error "may not have the VALUE or CODIMENSION attribute" } implicit none - integer, value :: e(..) ! { dg-error "VALUE attribute conflicts with DIMENSION" } + integer, value :: e(..) end subroutine diff --git a/gcc/testsuite/gfortran.dg/value_11.f90 b/gcc/testsuite/gfortran.dg/value_11.f90 new file mode 100644 index 00000000000..6056095892b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_11.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! character(len=n), value with a non-constant specified length (n is a +! dummy argument) was rejected with "must have constant length". Verify +! that it compiles and that VALUE semantics hold. + +program test + implicit none + call sub_char1_n ("abc", 3) +contains + subroutine sub_char1_n (x, n) + integer, intent(in) :: n + character(len=n), value :: x + x(1:1) = "1" + if (x(1:1) /= "1") error stop 23 + end subroutine sub_char1_n +end program test diff --git a/gcc/testsuite/gfortran.dg/value_12.f90 b/gcc/testsuite/gfortran.dg/value_12.f90 new file mode 100644 index 00000000000..7f42e346f64 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_12.f90 @@ -0,0 +1,68 @@ +! { dg-do run } +! VALUE was rejected outright for array dummy arguments ("VALUE +! attribute conflicts with DIMENSION attribute"), even though F2018 +! C862 only prohibits VALUE for assumed-size arrays (and coarrays). +! Verify that assumed-shape, explicit-shape, and +! non-contiguous array actuals are passed by VALUE correctly: the +! callee gets a private copy, and modifications do not propagate back +! to the actual argument, including for PARAMETER actuals. + +program test + implicit none + integer, parameter :: p(5) = [1,2,3,4,5] + character(len=*), parameter :: c1(2) = [ "abc", "def" ] + integer :: a(10), i + + a = [(i, i=1,10)] + + call sub_int_assumed_shape (p) + if (any (p /= [1,2,3,4,5])) stop 1 + + call sub_int_noncontig (a(1:10:2)) + if (any (a /= [(i, i=1,10)])) stop 2 + + call sub_int_explicit (p) + if (any (p /= [1,2,3,4,5])) stop 3 + + call sub_opt_array (p) + call sub_opt_array () + + call sub_char_assumed_shape (c1) + if (c1(1) /= "abc") stop 4 + +contains + + subroutine sub_int_assumed_shape (x) + integer, value :: x(:) + x = x + 100 + if (any (x /= [101,102,103,104,105])) stop 11 + end subroutine + + subroutine sub_int_noncontig (x) + integer, value :: x(:) + x = -1 + if (any (x /= -1)) stop 12 + end subroutine + + subroutine sub_int_explicit (x) + integer, value :: x(5) + x(1) = -99 + if (x(1) /= -99) stop 13 + end subroutine + + subroutine sub_opt_array (x) + integer, value, optional :: x(:) + if (present (x)) then + if (any (x /= [1,2,3,4,5])) stop 14 + x = -1 + end if + end subroutine + + subroutine sub_char_assumed_shape (x) + character(len=*), value :: x(:) + if (len (x) /= 3) stop 15 + x(1)(1:1) = "1" + if (x(1)(1:1) /= "1") stop 16 + end subroutine + +end program test diff --git a/gcc/testsuite/gfortran.dg/value_13.f90 b/gcc/testsuite/gfortran.dg/value_13.f90 new file mode 100644 index 00000000000..9388fe1f671 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_13.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! PR fortran/49802 +! Assumed-shape and explicit-shape array dummies may have the VALUE +! attribute since Fortran 2008 (F2008, C557), but assumed-size arrays +! may not. + +subroutine foo (x) + integer, value :: x(:) ! assumed-shape: OK +end subroutine + +subroutine bar (x) + integer, value :: x(10) ! explicit-shape: OK +end subroutine + +subroutine baz (x) ! { dg-error "may not have the VALUE attribute" } + integer, value :: x(*) +end subroutine diff --git a/gcc/testsuite/gfortran.dg/value_14.f90 b/gcc/testsuite/gfortran.dg/value_14.f90 new file mode 100644 index 00000000000..8736b0bdc38 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_14.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! PR fortran/49802 +! The caller-side copy made for an assumed-length CHARACTER VALUE dummy +! copied a number of bytes equal to the character count, which is wrong +! for a character kind wider than one byte. + +program test + implicit none + character(kind=4,len=10) :: s4 + character(kind=1,len=10) :: s1 + + s4 = 4_"abcdefghij" + call by_value_k4 (s4) + if (s4 /= 4_"abcdefghij") stop 1 + + s1 = "abcdefghij" + call by_value_k1 (s1) + if (s1 /= "abcdefghij") stop 2 + +contains + + subroutine by_value_k4 (y) + character(kind=4,len=*), value :: y + if (len (y) /= 10) stop 3 + if (y /= 4_"abcdefghij") stop 4 + y = 4_"ZZZZZZZZZZ" + end subroutine + + subroutine by_value_k1 (y) + character(kind=1,len=*), value :: y + if (y /= "abcdefghij") stop 5 + y = "ZZZZZZZZZZ" + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/value_15.f90 b/gcc/testsuite/gfortran.dg/value_15.f90 new file mode 100644 index 00000000000..7daeb05204a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_15.f90 @@ -0,0 +1,67 @@ +! { dg-do run } +! PR fortran/49802 +! Sequence association (F2023, 15.5.2.12) of a scalar actual argument +! with an explicit-shape array dummy that has the VALUE attribute used +! to ICE in conv_dummy_value. The dummy receives a private copy of as +! many elements as it declares. + +program test + implicit none + integer :: a(20), i + character(len=12) :: s + + a = [(i, i=1,20)] + s = "abcdefghijkl" + + call const_bound (a(3)) + if (any (a /= [(i, i=1,20)])) stop 1 + + call dummy_bound (4, a(3)) + if (any (a /= [(i, i=1,20)])) stop 2 + + call rank_two (a(5)) + if (any (a /= [(i, i=1,20)])) stop 3 + + call char_elems (s) + if (s /= "abcdefghijkl") stop 4 + + call char_dummy_len (3, s) + if (s /= "abcdefghijkl") stop 5 + +contains + + subroutine const_bound (x) + integer, value :: x(5) + if (any (x /= [3,4,5,6,7])) stop 11 + x = -1 + end subroutine + + subroutine dummy_bound (n, x) + integer, intent(in) :: n + integer, value :: x(n) + if (size (x) /= 4) stop 21 + if (any (x /= [3,4,5,6])) stop 22 + x = -1 + end subroutine + + subroutine rank_two (x) + integer, value :: x(2,3) + if (any (reshape (x, [6]) /= [5,6,7,8,9,10])) stop 31 + x = -1 + end subroutine + + subroutine char_elems (x) + character(len=3), value :: x(4) + if (x(1) /= "abc" .or. x(4) /= "jkl") stop 41 + x = "ZZZ" + end subroutine + + subroutine char_dummy_len (n, x) + integer, intent(in) :: n + character(len=n), value :: x(4) + if (len (x) /= 3) stop 51 + if (x(1) /= "abc" .or. x(4) /= "jkl") stop 52 + x = "ZZZ" + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/value_16.f90 b/gcc/testsuite/gfortran.dg/value_16.f90 new file mode 100644 index 00000000000..93730c84b0a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_16.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! PR fortran/49802 +! A VALUE array dummy of a derived type with allocatable components was +! given a shallow copy, so the callee reached the actual argument's data +! through the shared component pointers. The copy must be deep. + +program test + implicit none + type :: inner + integer, allocatable :: d(:) + end type + type :: outer + type(inner), allocatable :: b(:) + character(:), allocatable :: nm + end type + type(outer) :: v(2) + integer :: k + + do k = 1, 2 + allocate (v(k)%b(2)) + allocate (v(k)%b(1)%d(2), source=[k,k]) + allocate (v(k)%b(2)%d(2), source=[10*k,10*k]) + v(k)%nm = "orig" + end do + + call explicit_shape (v) + if (any (v(1)%b(1)%d /= [1,1])) stop 1 + if (v(1)%nm /= "orig") stop 2 + + call assumed_shape (v) + if (any (v(2)%b(2)%d /= [20,20])) stop 3 + if (v(2)%nm /= "orig") stop 4 + + call opt (v) + call opt () + if (v(1)%nm /= "orig") stop 5 + + call seq_assoc (v(1)) + if (any (v(1)%b(1)%d /= [1,1])) stop 6 + if (any (v(2)%b(1)%d /= [2,2])) stop 7 + +contains + + subroutine seq_assoc (x) + type(outer), value :: x(2) + x(1)%b(1)%d = [-1,-1] + x(2)%b(1)%d = [-9,-9] + if (any (x(1)%b(1)%d /= [-1,-1])) stop 61 + end subroutine + + subroutine explicit_shape (x) + type(outer), value :: x(2) + x(1)%b(1)%d = [-1,-1] + x(1)%nm = "changed" + if (any (x(1)%b(1)%d /= [-1,-1])) stop 11 + end subroutine + + subroutine assumed_shape (x) + type(outer), value :: x(:) + x(2)%b(2)%d = [-9,-9] + x(2)%nm = "changed" + if (x(2)%nm /= "changed") stop 21 + end subroutine + + subroutine opt (x) + type(outer), value, optional :: x(:) + if (present (x)) x(1)%nm = "changed" + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/value_17.f90 b/gcc/testsuite/gfortran.dg/value_17.f90 new file mode 100644 index 00000000000..8cafc556bbc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_17.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! PR fortran/49802 +! Only a scalar VALUE dummy is interoperable with a formal parameter of +! the C prototype (F2023, 18.3.6 (4)), so an array VALUE dummy is not +! allowed in a BIND(C) procedure. A polymorphic array VALUE dummy is +! not yet implemented; it used to ICE. + +module m + use iso_c_binding + implicit none + type :: t + integer :: i = 0 + end type +contains + + subroutine bindc_expl (x) bind(c) ! { dg-error "not allowed in BIND\\(C\\) procedure" } + integer(c_int), value :: x(3) + end subroutine + + subroutine bindc_ashape (x) bind(c) ! { dg-error "not allowed in BIND\\(C\\) procedure" } + integer(c_int), value :: x(:) + end subroutine + + subroutine poly (x) ! { dg-error "not yet implemented" } + class(t), value :: x(:) + end subroutine + +end module diff --git a/gcc/testsuite/gfortran.dg/value_18.f90 b/gcc/testsuite/gfortran.dg/value_18.f90 new file mode 100644 index 00000000000..967794cbe8e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_18.f90 @@ -0,0 +1,150 @@ +! { dg-do run } +! PR fortran/49802 +! An absent OPTIONAL actual argument passed to an OPTIONAL dummy with the +! VALUE attribute used to segfault: the private copy made for the dummy +! dereferenced the actual argument unconditionally. Both the array copy +! and the copy made for a character dummy of assumed or non-constant +! length must be suppressed when the actual argument is absent. + +module m + implicit none +contains + + subroutine take_as (x, present_x) + integer, value, optional :: x(:) + logical, intent(in) :: present_x + if (present (x) .neqv. present_x) stop 1 + if (present (x)) then + if (size (x) /= 3) stop 2 + if (any (x /= [1, 2, 3])) stop 3 + x = -1 + if (any (x /= -1)) stop 4 + end if + end subroutine take_as + + subroutine take_es (n, x, present_x) + integer, intent(in) :: n + integer, value, optional :: x(n) + logical, intent(in) :: present_x + if (present (x) .neqv. present_x) stop 5 + if (present (x)) then + if (size (x) /= n) stop 6 + if (x(1) /= 1) stop 7 + x = 0 + if (any (x /= 0)) stop 8 + end if + end subroutine take_es + + subroutine take_cs (s, present_s) + character(len=*), value, optional :: s + logical, intent(in) :: present_s + if (present (s) .neqv. present_s) stop 9 + if (present (s)) then + if (s /= 'payload') stop 10 + s = repeat ('Z', len (s)) + if (s /= repeat ('Z', len (s))) stop 11 + end if + end subroutine take_cs + + subroutine take_ca (s, present_s) + character(len=*), value, optional :: s(:) + logical, intent(in) :: present_s + if (present (s) .neqv. present_s) stop 12 + if (present (s)) then + if (size (s) /= 2) stop 13 + if (any (s /= ['ab', 'cd'])) stop 14 + s = 'ZZ' + if (any (s /= 'ZZ')) stop 15 + end if + end subroutine take_ca + + ! Relay an optional dummy on to the optional VALUE dummy. This is what + ! puts a descriptor of an absent argument into the argument list. + + subroutine relay_as (x, present_x) + integer, optional :: x(:) + logical, intent(in) :: present_x + call take_as (x, present_x) + end subroutine relay_as + + subroutine relay_es (n, x, present_x) + integer, intent(in) :: n + integer, optional :: x(n) + logical, intent(in) :: present_x + call take_es (n, x, present_x) + end subroutine relay_es + + ! A non-constant length is needed here: with len=* the length of an + ! absent actual argument is zero and the copy reads nothing. + subroutine relay_cs (n, s, present_s) + integer, intent(in) :: n + character(len=n), optional :: s + logical, intent(in) :: present_s + call take_cs (s, present_s) + end subroutine relay_cs + + subroutine relay_ca (s, present_s) + character(len=*), optional :: s(:) + logical, intent(in) :: present_s + call take_ca (s, present_s) + end subroutine relay_ca + + ! An optional VALUE dummy relayed on to another optional VALUE dummy. + + subroutine relay_asv (x, present_x) + integer, value, optional :: x(:) + logical, intent(in) :: present_x + call take_as (x, present_x) + end subroutine relay_asv + + subroutine relay_csv (n, s, present_s) + integer, intent(in) :: n + character(len=n), value, optional :: s + logical, intent(in) :: present_s + call take_cs (s, present_s) + end subroutine relay_csv + +end module m + +program test + use m + implicit none + integer :: v(3) + character(len=7) :: s + character(len=2) :: a(2) + + v = [1, 2, 3] + s = 'payload' + a = ['ab', 'cd'] + + ! Directly, with and without the actual argument. + call take_as (v, .true.) + call take_as (present_x = .false.) + call take_es (3, v, .true.) + call take_es (3, present_x = .false.) + call take_cs (s, .true.) + call take_cs (present_s = .false.) + call take_ca (a, .true.) + call take_ca (present_s = .false.) + + ! Relayed through an optional dummy. + call relay_as (v, .true.) + call relay_as (present_x = .false.) + call relay_es (3, v, .true.) + call relay_es (3, present_x = .false.) + call relay_cs (7, s, .true.) + call relay_cs (7, present_s = .false.) + call relay_ca (a, .true.) + call relay_ca (present_s = .false.) + + ! Relayed through an optional VALUE dummy. + call relay_asv (v, .true.) + call relay_asv (present_x = .false.) + call relay_csv (7, s, .true.) + call relay_csv (7, present_s = .false.) + + ! None of the copies may write back to the actual arguments. + if (any (v /= [1, 2, 3])) stop 16 + if (s /= 'payload') stop 17 + if (any (a /= ['ab', 'cd'])) stop 18 +end program test diff --git a/gcc/testsuite/gfortran.dg/value_3.f90 b/gcc/testsuite/gfortran.dg/value_3.f90 index c5d2d1f27df..0a5308cb88e 100644 --- a/gcc/testsuite/gfortran.dg/value_3.f90 +++ b/gcc/testsuite/gfortran.dg/value_3.f90 @@ -1,8 +1,14 @@ ! { dg-do compile } +! { dg-options "-std=f2003" } ! Tests the constraints in the patch for PR29642, which requested the ! implementation of the F2003 VALUE attribute for gfortran. ! -! Contributed by Paul Thomas <[email protected]> +! Compiled as -std=f2003 because Fortran 2008 relaxed C527 to allow the +! VALUE attribute on explicit-shape and assumed-shape array dummies +! (F2008, C557); bar_1 below exercises the resulting -std=f2003 +! rejection. The acceptance case is covered separately by value_12.f90. +! +! Contributed by Paul Thomas <[email protected]> ! program test_value integer(8) :: i = 42, j ! { dg-error "not a dummy" } @@ -10,10 +16,10 @@ program test_value value :: j contains - subroutine bar_1 (i) + subroutine bar_1 (i) ! { dg-error "Fortran 2008: Array dummy argument" } integer(8) :: i dimension i(8) - value :: i ! { dg-error "conflicts with DIMENSION" } + value :: i i = 0 end subroutine bar_1 diff --git a/gcc/testsuite/gfortran.dg/value_5.f90 b/gcc/testsuite/gfortran.dg/value_5.f90 index 4b0dcefb340..9060bbe2193 100644 --- a/gcc/testsuite/gfortran.dg/value_5.f90 +++ b/gcc/testsuite/gfortran.dg/value_5.f90 @@ -1,9 +1,15 @@ ! { dg-do compile } +! { dg-options "-std=f2003" } ! Length of character dummy variable with VALUE attribute: ! - must be initialization expression or omitted ! - C interoperable: must be initialization expression of length one ! or omitted ! +! Compiled as -std=f2003 because Fortran 2008 relaxed C558 to allow +! assumed-length character dummies with the VALUE attribute; that case +! (foo4) and its rejection under -std=f2003 are exercised separately in +! value_6.f90 and value_7.f90. +! ! Contributed by Tobias Burnus program x implicit none @@ -36,7 +42,7 @@ contains value :: a end subroutine foo3 - subroutine foo4(a) ! { dg-error "VALUE attribute must have constant length" } + subroutine foo4(a) ! { dg-error "Assumed-length character" } character(*) :: a value :: a end subroutine foo4 @@ -60,7 +66,7 @@ contains value :: a end subroutine bar3 - subroutine bar4(a) ! { dg-error "VALUE attribute must have constant length" } + subroutine bar4(a) ! { dg-error "VALUE attribute must have length one" } use iso_c_binding, only: c_char character(kind=c_char,len=*) :: a value :: a diff --git a/gcc/testsuite/gfortran.dg/value_6.f90 b/gcc/testsuite/gfortran.dg/value_6.f90 new file mode 100644 index 00000000000..b3187253a9e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_6.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! character(len=*), value was rejected by gfortran despite being valid +! from Fortran 2008 onwards. Verify that it compiles and that VALUE +! semantics are correct: modifications to the dummy do not affect the +! actual argument, and len() returns the actual argument's length. + +program test + implicit none + character(len=10) :: str + + str = "123456789" + call by_value (str) + if (str /= "123456789") stop 1 + +contains + + subroutine by_value (y) + character(len=*), value :: y + if (len (y) /= 10) stop 2 + if (y /= "123456789 ") stop 3 + y = "abcdefghij" + if (y /= "abcdefghij") stop 4 + ! str is accessible via host association; VALUE must not let + ! the assignment to y propagate back. + if (str /= "123456789") stop 5 + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/value_7.f90 b/gcc/testsuite/gfortran.dg/value_7.f90 new file mode 100644 index 00000000000..5e88fab2199 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_7.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Fortran 2003 C558 prohibited assumed-length character with VALUE. +! Verify that -std=f2003 rejects it. + +subroutine sub (y) ! { dg-error "Assumed-length character" } + character(len=*), value :: y +end subroutine