@@ -917,8 +917,8 @@ class IsContiguousHelper
917917 } else {
918918 return Base::operator ()(ultimate); // use expr
919919 }
920- } else if (semantics::IsPointer (ultimate) ||
921- semantics::IsAssumedShape (ultimate) || IsAssumedRank (ultimate)) {
920+ } else if (semantics::IsPointer (ultimate) || IsAssumedShape (ultimate) ||
921+ IsAssumedRank (ultimate)) {
922922 return std::nullopt ;
923923 } else if (ultimate.has <semantics::ObjectEntityDetails>()) {
924924 return true ;
@@ -1198,9 +1198,21 @@ std::optional<bool> IsContiguous(const A &x, FoldingContext &context,
11981198 }
11991199}
12001200
1201+ std::optional<bool > IsContiguous (const ActualArgument &actual,
1202+ FoldingContext &fc, bool namedConstantSectionsAreContiguous,
1203+ bool firstDimensionStride1) {
1204+ auto *expr{actual.UnwrapExpr ()};
1205+ return expr &&
1206+ IsContiguous (
1207+ *expr, fc, namedConstantSectionsAreContiguous, firstDimensionStride1);
1208+ }
1209+
12011210template std::optional<bool > IsContiguous (const Expr<SomeType> &,
12021211 FoldingContext &, bool namedConstantSectionsAreContiguous,
12031212 bool firstDimensionStride1);
1213+ template std::optional<bool > IsContiguous (const ActualArgument &,
1214+ FoldingContext &, bool namedConstantSectionsAreContiguous,
1215+ bool firstDimensionStride1);
12041216template std::optional<bool > IsContiguous (const ArrayRef &, FoldingContext &,
12051217 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
12061218template std::optional<bool > IsContiguous (const Substring &, FoldingContext &,
@@ -1350,4 +1362,177 @@ std::optional<parser::Message> CheckStatementFunction(
13501362 return StmtFunctionChecker{sf, context}(expr);
13511363}
13521364
1365+ // Helper class for checking differences between actual and dummy arguments
1366+ class CopyInOutExplicitInterface {
1367+ public:
1368+ explicit CopyInOutExplicitInterface (FoldingContext &fc,
1369+ const ActualArgument &actual,
1370+ const characteristics::DummyDataObject &dummyObj)
1371+ : fc_{fc}, actual_{actual}, dummyObj_{dummyObj} {}
1372+
1373+ // Returns true, if actual and dummy have different contiguity requirements
1374+ bool HaveContiguityDifferences () const {
1375+ // Check actual contiguity, unless dummy doesn't care
1376+ bool dummyTreatAsArray{dummyObj_.ignoreTKR .test (common::IgnoreTKR::Rank)};
1377+ bool actualTreatAsContiguous{
1378+ dummyObj_.ignoreTKR .test (common::IgnoreTKR::Contiguous) ||
1379+ IsSimplyContiguous (actual_, fc_)};
1380+ bool dummyIsExplicitShape{dummyObj_.type .IsExplicitShape ()};
1381+ bool dummyIsAssumedSize{dummyObj_.type .attrs ().test (
1382+ characteristics::TypeAndShape::Attr::AssumedSize)};
1383+ bool dummyIsPolymorphic{dummyObj_.type .type ().IsPolymorphic ()};
1384+ // type(*) with IGNORE_TKR(tkr) is often used to interface with C "void*".
1385+ // Since the other languages don't know about Fortran's discontiguity
1386+ // handling, such cases should require contiguity.
1387+ bool dummyIsVoidStar{dummyObj_.type .type ().IsAssumedType () &&
1388+ dummyObj_.ignoreTKR .test (common::IgnoreTKR::Type) &&
1389+ dummyObj_.ignoreTKR .test (common::IgnoreTKR::Rank) &&
1390+ dummyObj_.ignoreTKR .test (common::IgnoreTKR::Kind)};
1391+ // Explicit shape and assumed size arrays must be contiguous
1392+ bool dummyNeedsContiguity{dummyIsExplicitShape || dummyIsAssumedSize ||
1393+ (dummyTreatAsArray && !dummyIsPolymorphic) || dummyIsVoidStar ||
1394+ dummyObj_.attrs .test (
1395+ characteristics::DummyDataObject::Attr::Contiguous)};
1396+ return !actualTreatAsContiguous && dummyNeedsContiguity;
1397+ }
1398+
1399+ // Returns true, if actual and dummy have polymorphic differences
1400+ bool HavePolymorphicDifferences () const {
1401+ bool dummyIsAssumedRank{dummyObj_.type .attrs ().test (
1402+ characteristics::TypeAndShape::Attr::AssumedRank)};
1403+ bool actualIsAssumedRank{semantics::IsAssumedRank (actual_)};
1404+ bool dummyIsAssumedShape{dummyObj_.type .attrs ().test (
1405+ characteristics::TypeAndShape::Attr::AssumedShape)};
1406+ bool actualIsAssumedShape{semantics::IsAssumedShape (actual_)};
1407+ if ((actualIsAssumedRank && dummyIsAssumedRank) ||
1408+ (actualIsAssumedShape && dummyIsAssumedShape)) {
1409+ // Assumed-rank and assumed-shape arrays are represented by descriptors,
1410+ // so don't need to do polymorphic check.
1411+ } else if (!dummyObj_.ignoreTKR .test (common::IgnoreTKR::Type)) {
1412+ // flang supports limited cases of passing polymorphic to non-polimorphic.
1413+ // These cases require temporary of non-polymorphic type. (For example,
1414+ // the actual argument could be polymorphic array of child type,
1415+ // while the dummy argument could be non-polymorphic array of parent
1416+ // type.)
1417+ bool dummyIsPolymorphic{dummyObj_.type .type ().IsPolymorphic ()};
1418+ auto actualType{
1419+ characteristics::TypeAndShape::Characterize (actual_, fc_)};
1420+ bool actualIsPolymorphic{
1421+ actualType && actualType->type ().IsPolymorphic ()};
1422+ if (actualIsPolymorphic && !dummyIsPolymorphic) {
1423+ return true ;
1424+ }
1425+ }
1426+ return false ;
1427+ }
1428+
1429+ bool HaveArrayOrAssumedRankArgs () const {
1430+ bool dummyTreatAsArray{dummyObj_.ignoreTKR .test (common::IgnoreTKR::Rank)};
1431+ return IsArrayOrAssumedRank (actual_) &&
1432+ (IsArrayOrAssumedRank (dummyObj_) || dummyTreatAsArray);
1433+ }
1434+
1435+ bool PassByValue () const {
1436+ return dummyObj_.attrs .test (characteristics::DummyDataObject::Attr::Value);
1437+ }
1438+
1439+ bool HaveCoarrayDifferences () const {
1440+ return ExtractCoarrayRef (actual_) && dummyObj_.type .corank () == 0 ;
1441+ }
1442+
1443+ bool HasIntentOut () const { return dummyObj_.intent == common::Intent::Out; }
1444+
1445+ bool HasIntentIn () const { return dummyObj_.intent == common::Intent::In; }
1446+
1447+ static bool IsArrayOrAssumedRank (const ActualArgument &actual) {
1448+ return semantics::IsAssumedRank (actual) || actual.Rank () > 0 ;
1449+ }
1450+
1451+ static bool IsArrayOrAssumedRank (
1452+ const characteristics::DummyDataObject &dummy) {
1453+ return dummy.type .attrs ().test (
1454+ characteristics::TypeAndShape::Attr::AssumedRank) ||
1455+ dummy.type .Rank () > 0 ;
1456+ }
1457+
1458+ private:
1459+ FoldingContext &fc_;
1460+ const ActualArgument &actual_;
1461+ const characteristics::DummyDataObject &dummyObj_;
1462+ };
1463+
1464+ // If forCopyOut is false, returns if a particular actual/dummy argument
1465+ // combination may need a temporary creation with copy-in operation. If
1466+ // forCopyOut is true, returns the same for copy-out operation. For
1467+ // procedures with explicit interface, it's expected that "dummy" is not null.
1468+ // For procedures with implicit interface dummy may be null.
1469+ //
1470+ // Note that these copy-in and copy-out checks are done from the caller's
1471+ // perspective, meaning that for copy-in the caller need to do the copy
1472+ // before calling the callee. Similarly, for copy-out the caller is expected
1473+ // to do the copy after the callee returns.
1474+ bool MayNeedCopy (const ActualArgument *actual,
1475+ const characteristics::DummyArgument *dummy, FoldingContext &fc,
1476+ bool forCopyOut) {
1477+ if (!actual) {
1478+ return false ;
1479+ }
1480+ if (actual->isAlternateReturn ()) {
1481+ return false ;
1482+ }
1483+ const auto *dummyObj{dummy
1484+ ? std::get_if<characteristics::DummyDataObject>(&dummy->u )
1485+ : nullptr };
1486+ const bool forCopyIn = !forCopyOut;
1487+ if (!evaluate::IsVariable (*actual)) {
1488+ // Actual argument expressions that aren’t variables are copy-in, but
1489+ // not copy-out.
1490+ return forCopyIn;
1491+ }
1492+ if (dummyObj) { // Explict interface
1493+ CopyInOutExplicitInterface check{fc, *actual, *dummyObj};
1494+ if (forCopyOut && check.HasIntentIn ()) {
1495+ // INTENT(IN) dummy args never need copy-out
1496+ return false ;
1497+ }
1498+ if (forCopyIn && check.HasIntentOut ()) {
1499+ // INTENT(OUT) dummy args never need copy-in
1500+ return false ;
1501+ }
1502+ if (check.PassByValue ()) {
1503+ // Pass by value, always copy-in, never copy-out
1504+ return forCopyIn;
1505+ }
1506+ if (check.HaveCoarrayDifferences ()) {
1507+ return true ;
1508+ }
1509+ // Note: contiguity and polymorphic checks deal with array or assumed rank
1510+ // arguments
1511+ if (!check.HaveArrayOrAssumedRankArgs ()) {
1512+ return false ;
1513+ }
1514+ if (check.HaveContiguityDifferences ()) {
1515+ return true ;
1516+ }
1517+ if (check.HavePolymorphicDifferences ()) {
1518+ return true ;
1519+ }
1520+ } else { // Implicit interface
1521+ if (ExtractCoarrayRef (*actual)) {
1522+ // Coindexed actual args may need copy-in and copy-out with implicit
1523+ // interface
1524+ return true ;
1525+ }
1526+ if (!IsSimplyContiguous (*actual, fc)) {
1527+ // Copy-in: actual arguments that are variables are copy-in when
1528+ // non-contiguous.
1529+ // Copy-out: vector subscripts could refer to duplicate elements, can't
1530+ // copy out.
1531+ return !(forCopyOut && HasVectorSubscript (*actual));
1532+ }
1533+ }
1534+ // For everything else, no copy-in or copy-out
1535+ return false ;
1536+ }
1537+
13531538} // namespace Fortran::evaluate
0 commit comments