@@ -1001,8 +1001,8 @@ class IsContiguousHelper
10011001 } else {
10021002 return Base::operator ()(ultimate); // use expr
10031003 }
1004- } else if (semantics::IsPointer (ultimate) ||
1005- semantics::IsAssumedShape (ultimate) || IsAssumedRank (ultimate)) {
1004+ } else if (semantics::IsPointer (ultimate) || IsAssumedShape (ultimate) ||
1005+ IsAssumedRank (ultimate)) {
10061006 return std::nullopt ;
10071007 } else if (ultimate.has <semantics::ObjectEntityDetails>()) {
10081008 return true ;
@@ -1446,4 +1446,133 @@ std::optional<parser::Message> CheckStatementFunction(
14461446 return StmtFunctionChecker{sf, context}(expr);
14471447}
14481448
1449+ std::pair<bool , bool > MayNeedCopyInOut (
1450+ const ActualArgument &actual, FoldingContext &fc) {
1451+ bool mayNeedCopyIn{false };
1452+ bool mayNeedCopyOut{false };
1453+ if (actual.isAlternateReturn ()) {
1454+ return {mayNeedCopyIn, mayNeedCopyOut};
1455+ }
1456+ if (!evaluate::IsVariable (actual)) {
1457+ // Actual argument expressions that aren’t variables are copy-in, but
1458+ // not copy-out.
1459+ mayNeedCopyIn = true ;
1460+ } else if (bool actualIsArray{actual.Rank () > 0 };
1461+ actualIsArray && !IsSimplyContiguous (actual, fc)) {
1462+ // Actual arguments that are variables are copy-in when non-contiguous.
1463+ // They are copy-out when don't have vector subscripts
1464+ mayNeedCopyIn = true ;
1465+ if (!HasVectorSubscript (actual)) {
1466+ mayNeedCopyOut = true ;
1467+ }
1468+ } else if (ExtractCoarrayRef (actual)) {
1469+ // Coindexed actual args need copy-in and copy-out
1470+ mayNeedCopyIn = true ;
1471+ mayNeedCopyOut = true ;
1472+ }
1473+
1474+ return {mayNeedCopyIn, mayNeedCopyOut};
1475+ }
1476+
1477+ std::pair<bool , bool > MayNeedCopyInOut (const ActualArgument &actual,
1478+ const characteristics::DummyArgument &dummy, FoldingContext &fc) {
1479+ bool mayNeedCopyIn{false };
1480+ bool mayNeedCopyOut{false };
1481+ if (actual.isAlternateReturn ()) {
1482+ return {mayNeedCopyIn, mayNeedCopyOut};
1483+ }
1484+ if (!evaluate::IsVariable (actual)) {
1485+ // Actual argument expressions that aren’t variables are copy-in, but
1486+ // not copy-out.
1487+ mayNeedCopyIn = true ;
1488+ return {mayNeedCopyIn, mayNeedCopyOut};
1489+ }
1490+ const auto *dummyObj{std::get_if<characteristics::DummyDataObject>(&dummy.u )};
1491+ if (!dummyObj) {
1492+ // Only DummyDataObject has the information we need
1493+ return {mayNeedCopyIn, mayNeedCopyOut};
1494+ }
1495+ // Pass by value, always copy-in, never copy-out
1496+ bool dummyIsValue{
1497+ dummyObj->attrs .test (characteristics::DummyDataObject::Attr::Value)};
1498+ if (dummyIsValue) {
1499+ mayNeedCopyIn = true ;
1500+ return {mayNeedCopyIn, mayNeedCopyOut};
1501+ }
1502+ // All the checks below are for arrays
1503+
1504+ bool actualIsAssumedRank{evaluate::IsAssumedRank (actual)};
1505+ bool actualIsArray{actualIsAssumedRank || actual.Rank () > 0 };
1506+ bool dummyIsAssumedRank{dummyObj->type .attrs ().test (
1507+ characteristics::TypeAndShape::Attr::AssumedRank)};
1508+ bool dummyIsArray{dummyIsAssumedRank || dummyObj->type .Rank () > 0 };
1509+ bool treatDummyScalarAsArray{dummyObj->type .Rank () == 0 &&
1510+ dummyObj->ignoreTKR .test (common::IgnoreTKR::Rank)};
1511+ if (!actualIsArray || !(dummyIsArray || treatDummyScalarAsArray)) {
1512+ return {mayNeedCopyIn, mayNeedCopyOut};
1513+ }
1514+
1515+ bool dummyIntentIn{dummyObj->intent == common::Intent::In};
1516+ bool dummyIntentOut{dummyObj->intent == common::Intent::Out};
1517+ auto setCopyIn = [&]() {
1518+ if (!dummyIntentOut) {
1519+ // INTENT(OUT) dummy args never need copy-in
1520+ mayNeedCopyIn = true ;
1521+ }
1522+ };
1523+ auto setCopyOut = [&]() {
1524+ if (!dummyIntentIn) {
1525+ // INTENT(IN) dummy args never need copy-out
1526+ mayNeedCopyOut = true ;
1527+ }
1528+ };
1529+
1530+ // Check actual contiguity, unless dummy doesn't care
1531+ bool actualTreatAsContiguous{
1532+ dummyObj->ignoreTKR .test (common::IgnoreTKR::Contiguous) ||
1533+ IsSimplyContiguous (actual, fc)};
1534+ bool actualHasVectorSubscript{HasVectorSubscript (actual)};
1535+ bool dummyIsExplicitShape{dummyObj->type .IsExplicitShape ()};
1536+ bool dummyIsAssumedSize{dummyObj->type .attrs ().test (
1537+ characteristics::TypeAndShape::Attr::AssumedSize)};
1538+ bool dummyIsPolymorphic{dummyObj->type .type ().IsPolymorphic ()};
1539+ // Explicit shape and assumed size arrays must be contiguous
1540+ bool dummyNeedsContiguity{dummyIsExplicitShape || dummyIsAssumedSize ||
1541+ // Polymorphic dummy is descriptor based, so should be able to handle
1542+ // discontigunity.
1543+ (treatDummyScalarAsArray && !dummyIsPolymorphic) ||
1544+ dummyObj->attrs .test (characteristics::DummyDataObject::Attr::Contiguous)};
1545+ if (!actualTreatAsContiguous && dummyNeedsContiguity) {
1546+ setCopyIn ();
1547+ // Cannot do copy-out for vector subscripts: there could be repeated
1548+ // indices, for example
1549+ if (!actualHasVectorSubscript) {
1550+ setCopyOut ();
1551+ }
1552+ return {mayNeedCopyIn, mayNeedCopyOut};
1553+ }
1554+
1555+ bool dummyIsAssumedShape{dummyObj->type .attrs ().test (
1556+ characteristics::TypeAndShape::Attr::AssumedShape)};
1557+ bool actualIsAssumedShape{IsAssumedShape (actual)};
1558+ if ((actualIsAssumedRank && dummyIsAssumedRank) ||
1559+ (actualIsAssumedShape && dummyIsAssumedShape)) {
1560+ // Assumed-rank and assumed-shape arrays are represented by descriptors,
1561+ // so don't need to do polymorphic check.
1562+ } else if (!dummyObj->ignoreTKR .test (common::IgnoreTKR::Type)) {
1563+ // flang supports limited cases of passing polymorphic to non-polimorphic.
1564+ // These cases require temporary of non-polymorphic type. (For example,
1565+ // the actual argument could be polymorphic array of child type,
1566+ // while the dummy argument could be non-polymorphic array of parent type.)
1567+ auto actualType{characteristics::TypeAndShape::Characterize (actual, fc)};
1568+ bool actualIsPolymorphic{actualType->type ().IsPolymorphic ()};
1569+ if (actualIsPolymorphic && !dummyIsPolymorphic) {
1570+ setCopyIn ();
1571+ setCopyOut ();
1572+ }
1573+ }
1574+
1575+ return {mayNeedCopyIn, mayNeedCopyOut};
1576+ }
1577+
14491578} // namespace Fortran::evaluate
0 commit comments