public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-8400] Fortran: passing of optional dummies to elemental procedures [PR113377]
@ 2024-01-24 19:28 Harald Anlauf
0 siblings, 0 replies; only message in thread
From: Harald Anlauf @ 2024-01-24 19:28 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:186ae6d2cb93ad2e07117cff7e11def21fe285ae
commit r14-8400-g186ae6d2cb93ad2e07117cff7e11def21fe285ae
Author: Harald Anlauf <anlauf@gmx.de>
Date: Wed Jan 24 20:27:36 2024 +0100
Fortran: passing of optional dummies to elemental procedures [PR113377]
gcc/fortran/ChangeLog:
PR fortran/113377
* trans-expr.cc (conv_dummy_value): New.
(gfc_conv_procedure_call): Factor code for handling dummy arguments
with the VALUE attribute in the scalar case into conv_dummy_value().
Reuse and adjust for calling elemental procedures.
gcc/testsuite/ChangeLog:
PR fortran/113377
* gfortran.dg/optional_absent_10.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 195 +++++++++++---------
gcc/testsuite/gfortran.dg/optional_absent_10.f90 | 219 +++++++++++++++++++++++
2 files changed, 330 insertions(+), 84 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 128add47516..3dc521fab9a 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6075,6 +6075,105 @@ conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
}
+/* Helper function for the handling of (currently) scalar dummy variables
+ with the VALUE attribute. Argument parmse should already be set up. */
+static void
+conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
+ vec<tree, va_gc> *& optionalargs)
+{
+ tree tmp;
+
+ gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
+
+ /* Absent actual argument for optional scalar dummy. */
+ if (e == NULL && fsym->attr.optional && !fsym->attr.dimension)
+ {
+ /* For scalar arguments with VALUE attribute which are passed by
+ value, pass "0" and a hidden argument for the optional status. */
+ if (fsym->ts.type == BT_CHARACTER)
+ {
+ /* Pass a NULL pointer for an absent CHARACTER arg and a length of
+ zero. */
+ parmse->expr = null_pointer_node;
+ parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
+ }
+ else
+ parmse->expr = fold_convert (gfc_sym_type (fsym),
+ integer_zero_node);
+ vec_safe_push (optionalargs, boolean_false_node);
+
+ return;
+ }
+
+ /* gfortran argument passing conventions:
+ actual arguments to CHARACTER(len=1),VALUE
+ dummy arguments are actually passed by value.
+ Strings are truncated to length 1. */
+ if (gfc_length_one_character_type_p (&fsym->ts))
+ {
+ if (e->expr_type == EXPR_CONSTANT
+ && e->value.character.length > 1)
+ {
+ e->value.character.length = 1;
+ gfc_conv_expr (parmse, e);
+ }
+
+ tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
+ gfc_conv_string_parameter (parmse);
+ parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
+ e->ts.kind);
+ /* Truncate resulting string to length 1. */
+ parmse->string_length = slen1;
+ }
+
+ if (fsym->attr.optional
+ && fsym->ts.type != BT_CLASS
+ && fsym->ts.type != BT_DERIVED)
+ {
+ /* F2018:15.5.2.12 Argument presence and
+ restrictions on arguments not present. */
+ if (e->expr_type == EXPR_VARIABLE
+ && e->rank == 0
+ && (gfc_expr_attr (e).allocatable
+ || gfc_expr_attr (e).pointer))
+ {
+ gfc_se argse;
+ tree cond;
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
+ gfc_conv_expr (&argse, e);
+ cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ argse.expr, cond);
+ vec_safe_push (optionalargs,
+ fold_convert (boolean_type_node, cond));
+ /* Create "conditional temporary". */
+ conv_cond_temp (parmse, e, cond);
+ }
+ else if (e->expr_type != EXPR_VARIABLE
+ || !e->symtree->n.sym->attr.optional
+ || (e->ref != NULL && e->ref->type != REF_ARRAY))
+ vec_safe_push (optionalargs, boolean_true_node);
+ else
+ {
+ tmp = gfc_conv_expr_present (e->symtree->n.sym);
+ if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
+ parmse->expr
+ = fold_build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse->expr),
+ tmp, parmse->expr,
+ fold_convert (TREE_TYPE (parmse->expr),
+ integer_zero_node));
+
+ vec_safe_push (optionalargs,
+ fold_convert (boolean_type_node, tmp));
+ }
+ }
+}
+
+
+
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers.
@@ -6279,19 +6378,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& !fsym->attr.dimension && fsym->ts.type != BT_CLASS
&& !gfc_bt_struct (sym->ts.type))
{
- if (fsym->ts.type == BT_CHARACTER)
- {
- /* Pass a NULL pointer for an absent CHARACTER arg
- and a length of zero. */
- parmse.expr = null_pointer_node;
- parmse.string_length
- = build_int_cst (gfc_charlen_type_node,
- 0);
- }
- else
- parmse.expr = fold_convert (gfc_sym_type (fsym),
- integer_zero_node);
- vec_safe_push (optionalargs, boolean_false_node);
+ conv_dummy_value (&parmse, e, fsym, optionalargs);
}
else
{
@@ -6392,12 +6479,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
}
+ /* Scalar dummy arguments of intrinsic type with VALUE attribute. */
+ if (fsym
+ && fsym->attr.value
+ && fsym->ts.type != BT_DERIVED
+ && fsym->ts.type != BT_CLASS)
+ conv_dummy_value (&parmse, e, fsym, optionalargs);
+
/* If we are passing an absent array as optional dummy to an
elemental procedure, make sure that we pass NULL when the data
pointer is NULL. We need this extra conditional because of
scalarization which passes arrays elements to the procedure,
ignoring the fact that the array can be absent/unallocated/... */
- if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
+ else if (ss->info->can_be_null_ref
+ && ss->info->type != GFC_SS_REFERENCE)
{
tree descriptor_data;
@@ -6487,76 +6582,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else
{
- gfc_conv_expr (&parmse, e);
-
- /* ABI: actual arguments to CHARACTER(len=1),VALUE
- dummy arguments are actually passed by value.
- Strings are truncated to length 1. */
- if (gfc_length_one_character_type_p (&fsym->ts))
- {
- if (e->expr_type == EXPR_CONSTANT
- && e->value.character.length > 1)
- {
- e->value.character.length = 1;
- gfc_conv_expr (&parmse, e);
- }
-
- tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
- gfc_conv_string_parameter (&parmse);
- parmse.expr
- = gfc_string_to_single_character (slen1,
- parmse.expr,
- e->ts.kind);
- /* Truncate resulting string to length 1. */
- parmse.string_length = slen1;
- }
-
- if (fsym->attr.optional
- && fsym->ts.type != BT_CLASS
- && fsym->ts.type != BT_DERIVED)
- {
- /* F2018:15.5.2.12 Argument presence and
- restrictions on arguments not present. */
- if (e->expr_type == EXPR_VARIABLE
- && (gfc_expr_attr (e).allocatable
- || gfc_expr_attr (e).pointer))
- {
- gfc_se argse;
- tree cond;
- gfc_init_se (&argse, NULL);
- argse.want_pointer = 1;
- gfc_conv_expr (&argse, e);
- cond = fold_convert (TREE_TYPE (argse.expr),
- null_pointer_node);
- cond = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node,
- argse.expr, cond);
- vec_safe_push (optionalargs,
- fold_convert (boolean_type_node,
- cond));
- /* Create "conditional temporary". */
- conv_cond_temp (&parmse, e, cond);
- }
- else if (e->expr_type != EXPR_VARIABLE
- || !e->symtree->n.sym->attr.optional
- || e->ref != NULL)
- vec_safe_push (optionalargs, boolean_true_node);
- else
- {
- tmp = gfc_conv_expr_present (e->symtree->n.sym);
- if (!e->symtree->n.sym->attr.value)
- parmse.expr
- = fold_build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse.expr),
- tmp, parmse.expr,
- fold_convert (TREE_TYPE (parmse.expr),
- integer_zero_node));
-
- vec_safe_push (optionalargs,
- fold_convert (boolean_type_node,
- tmp));
- }
- }
+ gfc_conv_expr (&parmse, e);
+ conv_dummy_value (&parmse, e, fsym, optionalargs);
}
}
diff --git a/gcc/testsuite/gfortran.dg/optional_absent_10.f90 b/gcc/testsuite/gfortran.dg/optional_absent_10.f90
new file mode 100644
index 00000000000..acdabbdf164
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_10.f90
@@ -0,0 +1,219 @@
+! { dg-do run }
+! PR fortran/113377
+!
+! Test passing of missing optional arguments of intrinsic type
+! to scalar dummies of elemental subroutines
+
+module m_char
+ implicit none
+contains
+ subroutine test_char ()
+ character :: k(7) = "#"
+ character(4) :: c(7) = "*"
+ call one (k)
+ call one_val (k)
+ call one_ij (k)
+ call one_jj (k)
+ call one_j4 (k)
+ call three (c)
+ call three_val (c)
+ call three_ij (c)
+ call three_jj (c)
+ call three_j4 (c)
+ end subroutine test_char
+
+ subroutine one (i, j)
+ character, intent(in) :: i(7)
+ character, intent(in), optional :: j
+ character, allocatable :: aa
+ character, pointer :: pp => NULL()
+ if (present (j)) stop 1
+ call two (i, j)
+ call two_val (i, j)
+ call two (i, aa)
+ call two (i, pp)
+ call two_val (i, aa)
+ call two_val (i, pp)
+ end
+
+ subroutine one_val (i, j)
+ character, intent(in) :: i(7)
+ character, value, optional :: j
+ if (present (j)) stop 2
+ call two (i, j)
+ call two_val (i, j)
+ end
+
+ subroutine one_ij (i, j)
+ character, intent(in) :: i(7)
+ character, intent(in), optional :: j(7)
+ if (present (j)) stop 3
+ call two (i, j)
+ call two_val (i, j)
+ end
+
+ subroutine one_jj (i, j)
+ character, intent(in) :: i(7)
+ character, intent(in), optional :: j(:)
+ if (present (j)) stop 4
+ call two (i, j)
+ call two_val (i, j)
+ end
+
+ subroutine one_j4 (i, j)
+ character, intent(in) :: i(:)
+ character, intent(in), optional :: j(7)
+ if (present (j)) stop 5
+ call two (i, j)
+ call two_val (i, j)
+ end
+
+ elemental subroutine two (i, j)
+ character, intent(in) :: i
+ character, intent(in), optional :: j
+ if (present (j)) error stop 11
+ end
+
+ elemental subroutine two_val (i, j)
+ character, intent(in) :: i
+ character, value, optional :: j
+ if (present (j)) error stop 12
+ end
+
+ subroutine three (i, j)
+ character(4), intent(in) :: i(7)
+ character(4), intent(in), optional :: j
+ character(4), allocatable :: aa
+ character(4), pointer :: pp => NULL()
+ if (present (j)) stop 6
+ call four (i, j)
+ call four_val (i, j)
+ call four (i, aa)
+ call four (i, pp)
+ call four_val (i, aa)
+ call four_val (i, pp)
+ end
+
+ subroutine three_val (i, j)
+ character(4), intent(in) :: i(7)
+ character(4), value, optional :: j
+ if (present (j)) stop 7
+ call four (i, j)
+ call four_val (i, j)
+ end
+
+ subroutine three_ij (i, j)
+ character(4), intent(in) :: i(7)
+ character(4), intent(in), optional :: j(7)
+ if (present (j)) stop 8
+ call four (i, j)
+ call four_val (i, j)
+ end
+
+ subroutine three_jj (i, j)
+ character(4), intent(in) :: i(7)
+ character(4), intent(in), optional :: j(:)
+ if (present (j)) stop 9
+ call four (i, j)
+ call four_val (i, j)
+ end
+
+ subroutine three_j4 (i, j)
+ character(4), intent(in) :: i(:)
+ character(4), intent(in), optional :: j(7)
+ if (present (j)) stop 10
+ call four (i, j)
+ call four_val (i, j)
+ end
+
+ elemental subroutine four (i, j)
+ character(4), intent(in) :: i
+ character(4), intent(in), optional :: j
+ if (present (j)) error stop 13
+ end
+
+ elemental subroutine four_val (i, j)
+ character(4), intent(in) :: i
+ character(4), value, optional :: j
+ if (present (j)) error stop 14
+ end
+end
+
+module m_int
+ implicit none
+contains
+ subroutine test_int ()
+ integer :: k(4) = 1
+ call one (k)
+ call one_val (k)
+ call one_ij (k)
+ call one_jj (k)
+ call one_j4 (k)
+ end
+
+ subroutine one (i, j)
+ integer, intent(in) :: i(4)
+ integer, intent(in), optional :: j
+ integer, allocatable :: aa
+ integer, pointer :: pp => NULL()
+ if (present (j)) stop 21
+ call two (i, j)
+ call two_val (i, j)
+ call two (i, aa)
+ call two (i, pp)
+ call two_val (i, aa)
+ call two_val (i, pp)
+ end
+
+ subroutine one_val (i, j)
+ integer, intent(in) :: i(4)
+ integer, value, optional :: j
+ if (present (j)) stop 22
+ call two (i, j)
+ call two_val (i, j)
+ end
+
+ subroutine one_ij (i, j)
+ integer, intent(in) :: i(4)
+ integer, intent(in), optional :: j(4)
+ if (present (j)) stop 23
+ call two (i, j)
+ call two_val (i, j)
+ end
+
+ subroutine one_jj (i, j)
+ integer, intent(in) :: i(4)
+ integer, intent(in), optional :: j(:)
+ if (present (j)) stop 24
+ call two (i, j)
+ call two_val (i, j)
+ end
+
+ subroutine one_j4 (i, j)
+ integer, intent(in) :: i(:)
+ integer, intent(in), optional :: j(4)
+ if (present (j)) stop 25
+ call two (i, j)
+ call two_val (i, j)
+ end
+
+ elemental subroutine two (i, j)
+ integer, intent(in) :: i
+ integer, intent(in), optional :: j
+ if (present (j)) error stop 31
+ end
+
+ elemental subroutine two_val (i, j)
+ integer, intent(in) :: i
+ integer, value, optional :: j
+ if (present (j)) error stop 32
+ end
+end
+
+program p
+ use m_int
+ use m_char
+ implicit none
+ call test_int ()
+ call test_char ()
+end
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2024-01-24 19:28 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-01-24 19:28 [gcc r14-8400] Fortran: passing of optional dummies to elemental procedures [PR113377] Harald Anlauf
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).