[PATCH] Fortran: passing of allocatable/pointer arguments to OPTIONAL+VALUE [PR92887]
Dear all,
I've dusted off and cleaned up a previous attempt to fix the handling
of allocatable or pointer actual arguments to OPTIONAL+VALUE dummies.
The standard says that a non-allocated / non-associated actual argument
in that case shall be treated as non-present.
However, gfortran's calling conventions demand that the presence status
for OPTIONAL+VALUE is passed as a hidden argument, while we need to
pass something on the stack which has the right type. The solution
is to conditionally create a temporary when needed.
Testcase checked with NAG.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
Thanks,
Harald
From 6927612d97a8e7360e651bb081745fc7659a4c4b Mon Sep 17 00:00:00 2001
From: Harald Anlauf
Date: Wed, 1 Nov 2023 22:55:36 +0100
Subject: [PATCH] Fortran: passing of allocatable/pointer arguments to
OPTIONAL+VALUE [PR92887]
gcc/fortran/ChangeLog:
PR fortran/92887
* trans-expr.cc (conv_cond_temp): Helper function for creation of a
conditional temporary.
(gfc_conv_procedure_call): Handle passing of allocatable or pointer
actual argument to dummy with OPTIONAL + VALUE attribute. Actual
arguments that are not allocated or associated are treated as not
present.
gcc/testsuite/ChangeLog:
PR fortran/92887
* gfortran.dg/value_optional_1.f90: New test.
---
gcc/fortran/trans-expr.cc | 50 ++-
.../gfortran.dg/value_optional_1.f90 | 83 +++
2 files changed, 130 insertions(+), 3 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/value_optional_1.f90
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 1b8be081a17..1c06ecb3c28 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6030,6 +6030,28 @@ post_call:
}
+/* Create "conditional temporary" to handle scalar dummy variables with the
+ OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
+ as fallback. Only instances of intrinsic basic type are supported. */
+
+void
+conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
+{
+ tree temp;
+ gcc_assert (e->ts.type != BT_DERIVED && e->ts.type != BT_CLASS);
+ gcc_assert (e->rank == 0);
+ temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
+ TREE_STATIC (temp) = 1;
+ TREE_CONSTANT (temp) = 1;
+ TREE_READONLY (temp) = 1;
+ DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
+ parmse->expr = fold_build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse->expr),
+ cond, parmse->expr, temp);
+ parmse->expr = gfc_evaluate_now (parmse->expr, >pre);
+}
+
+
/* 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.
@@ -6470,9 +6492,31 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& fsym->ts.type != BT_CLASS
&& fsym->ts.type != BT_DERIVED)
{
- if (e->expr_type != EXPR_VARIABLE
- || !e->symtree->n.sym->attr.optional
- || e->ref != NULL)
+ /* 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 (, NULL);
+ argse.want_pointer = 1;
+ gfc_conv_expr (, 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 (, 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
{
diff --git a/gcc/testsuite/gfortran.dg/value_optional_1.f90 b/gcc/testsuite/gfortran.dg/value_optional_1.f90
new file mode 100644
index 000..2f95316de52
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/value_optional_1.f90
@@ -0,0 +1,83 @@
+! { dg-do run }
+! PR fortran/92887
+!
+! Test passing nullified/disassociated pointer or unalloc allocatable
+! to OPTIONAL + VALUE
+
+program p
+ implicit none !(type, external)
+ integer, allocatable :: aa
+ real, pointer :: pp
+ character,allocatable :: ca
+ character,pointer :: cp
+ complex, allocatable :: za
+ complex, pointer :: zp
+ type t
+ integer, allocatable :: aa
+ real, pointer :: pp => NULL()
+ complex, allocatable :: za
+ end type t
+ type(t) :: tt
+ nullify (pp, cp, zp)
+ call sub (aa, pp, ca, cp, za)
+ call sub (tt% aa, tt% pp, z=tt% za)
+ allocate (aa, pp, ca, cp, za, zp, tt% za)
+ aa = 1; pp = 2.; ca = "c"; cp = "d"; za = 3.; zp = 4.; tt% za = 4.
+ call ref
Re: [Patch, fortran] PR98498 - Interp request: defined operators and unlimited polymorphic
Hi Paul,
Am 01.11.23 um 19:02 schrieb Paul Richard Thomas:
The interpretation request came in a long time ago but I only just got
around to implementing it.
The updated text from the standard is in the comment. Now I am writing
this, I think that I should perhaps use switch(op)/case rather than using
if/else if and depending on the order of the gfc_intrinsic_op enum being
maintained. Thoughts?
the logic is likely harder to parse with if/else than with
switch(op)/case. However, I do not think that the order of
the enum will ever be changed, as the module format relies
on that very order.
The testcase runs fine with both mainline and nagfor. I think that
compile-only with counts of star-eq and star_not should suffice.
I found other cases that are rejected even with your patch,
but which are accepted by nagfor. Example:
print *, ('a' == c)
Nagfor prints F at runtime as expected, as it correctly resolves
this to star_eq. Further examples can be easily constructed.
Can you have a look?
Thanks,
Harald
Regtests with no regressions. OK for mainline?
Paul
Fortran: Defined operators with unlimited polymorphic args [PR98498]
2023-11-01 Paul Thomas
gcc/fortran
PR fortran/98498
* interface.cc (upoly_ok): New function.
(gfc_extend_expr): Use new function to ensure that defined
operators using unlimited polymorphic formal arguments do not
override their intrinsic uses.
gcc/testsuite/
PR fortran/98498
* gfortran.dg/interface_50.f90: New test.
[Patch, fortran] PR98498 - Interp request: defined operators and unlimited polymorphic
The interpretation request came in a long time ago but I only just got
around to implementing it.
The updated text from the standard is in the comment. Now I am writing
this, I think that I should perhaps use switch(op)/case rather than using
if/else if and depending on the order of the gfc_intrinsic_op enum being
maintained. Thoughts?
The testcase runs fine with both mainline and nagfor. I think that
compile-only with counts of star-eq and star_not should suffice.
Regtests with no regressions. OK for mainline?
Paul
Fortran: Defined operators with unlimited polymorphic args [PR98498]
2023-11-01 Paul Thomas
gcc/fortran
PR fortran/98498
* interface.cc (upoly_ok): New function.
(gfc_extend_expr): Use new function to ensure that defined
operators using unlimited polymorphic formal arguments do not
override their intrinsic uses.
gcc/testsuite/
PR fortran/98498
* gfortran.dg/interface_50.f90: New test.
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 8c4571e0aa6..ba7fb5dfea5 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -4616,6 +4616,35 @@ build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
}
+/* Check if the type of an actual argument is OK to use with an
+ unlimited polymorphic formal argument in a defined operation. */
+
+static bool
+upoly_ok (bt type, gfc_intrinsic_op op)
+{
+ bool ok = false;
+ if (type == BT_DERIVED || type == BT_CLASS)
+ok = true;
+ else if ((op >= INTRINSIC_UPLUS && op <= INTRINSIC_POWER)
+ && (type == BT_LOGICAL || type == BT_CHARACTER))
+ok = true;
+ else if ((op == INTRINSIC_CONCAT) && (type != BT_CHARACTER))
+ok = true;
+ else if ((op >= INTRINSIC_GT && op <= INTRINSIC_LE)
+ && (type == BT_COMPLEX))
+ok = true;
+ else if ((op >= INTRINSIC_GT_OS) && (op <= INTRINSIC_LE_OS)
+ && (type == BT_COMPLEX))
+ok = true;
+ else if ((op >= INTRINSIC_AND) && (op <= INTRINSIC_NEQV)
+ && (type != BT_LOGICAL))
+ok = true;
+ else if ((op == INTRINSIC_NOT) && (type != BT_LOGICAL))
+ok = true;
+ return ok;
+}
+
+
/* This subroutine is called when an expression is being resolved.
The expression node in question is either a user defined operator
or an intrinsic operator with arguments that aren't compatible
@@ -4737,6 +4766,24 @@ gfc_extend_expr (gfc_expr *e)
if (sym != NULL)
break;
}
+
+ /* F2018(15.4.3.4.2): "If the operator is an intrinsic-operator (R608),
+ the number of dummy arguments shall be consistent with the intrinsic
+ uses of that operator, and the types, kind type parameters, or ranks
+ of the dummy arguments shall differ from those required for the
+ intrinsic operation (10.1.5)." ie. the use of unlimited polymorphic
+ formal arguments must not override the intrinsic uses. */
+ if (sym && (UNLIMITED_POLY (sym->formal->sym)
+ || (sym->formal->next
+ && UNLIMITED_POLY (sym->formal->next->sym
+ {
+ bool arg2 = (actual->next != NULL);
+ bool a1ok = upoly_ok (actual->expr->ts.type, e->value.op.op);
+ bool a2ok = arg2 && upoly_ok (actual->next->expr->ts.type,
+ e->value.op.op);
+ if ((!arg2 && !a1ok) || (arg2 && (!a1ok && !a2ok)))
+ sym = NULL;
+ }
}
/* TODO: Do an ambiguity-check and error if multiple matching interfaces are
! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! Tests the fix for PR98498, which was subject to an interpretation request
! as to whether or not the interface operator overrode the intrinsic use.
! (See PR for correspondence)
!
! Contributed by Paul Thomas
!
MODULE mytypes
IMPLICIT none
TYPE pvar
character(len=20) :: name
integer :: level
end TYPE pvar
interface operator (==)
module procedure star_eq
end interface
interface operator (.not.)
module procedure star_not
end interface
contains
function star_eq(a, b)
implicit none
class(*), intent(in) :: a, b
logical :: star_eq
select type (a)
type is (pvar)
select type (b)
type is (pvar)
if((a%level .eq. b%level) .and. (a%name .eq. b%name)) then
star_eq = .true.
else
star_eq = .false.
end if
type is (integer)
star_eq = (a%level == b)
end select
class default
star_eq = .false.
end select
end function star_eq
function star_not (a)
implicit none
class(*), intent(in) :: a
type(pvar) :: star_not
select type (a)
type is (pvar)
star_not = a
star_not%level = -star_not%level
type is (real)
star_not = pvar ("real", -int(a))
class default
star_not = pvar ("noname", 0)
end select
end function
end MODULE mytypes
program test_eq
use mytypes
implicit none
type(pvar) x, y
integer :: i = 4
real :: r = 2.0
! Check that intrinsic use of .not. and == is not overridden.
if (.not.(i == 2*int (r))) stop 1
if (r == 1.0) stop 2
! Test defined
RE: [PATCH v4] libgfortran: Replace mutex with rwlock
> > > > Hi Lipeng, > > > > >>> Sure, as your comments, in the patch V6, I added 3 test cases with > > >>> OpenMP to test different cases in concurrency respectively: > > >>> 1. find and create unit very frequently to stress read lock and write > > >>> lock. > > >>> 2. only access the unit which exist in cache to stress read lock. > > >>> 3. access the same unit in concurrency. > > >>> For the third test case, it also help to find a bug: When unit > > >>> can't be found in cache nor unit list in read phase, then threads > > >>> will try to acquire write lock to insert the same unit, this will > > >>> cause duplicate key > > >> error. > > >>> To fix this bug, I get the unit from unit list once again before > > >>> insert in write > > >> lock. > > >>> More details you can refer the patch v6. > > >>> > > >> > > >> Could you help to review this update? I really appreciate your > > >> assistance. > > >> > > > > > Could you help to review this update? Any concern will be appreciated. > > > > Fortran parts are OK (I think I wrote that already), we need somebody > > for the non-Fortran parts. > > > Hi Thomas, > > Thanks for your response. Very appreciate for your patience and help. > > > Jakub, could you maybe take a look? > > > > Best regards > > > > Thomas > > Hi Jakub, > > Can you help to take a look at the change for libgcc part that added several > rwlock macros in libgcc/gthr-posix.h? > Hi Jakub, Could you help to review this, any comment will be greatly appreciated. > Best Regards, > Lipeng Zhu
