diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index ea33034f47c0a16..69ae69bb35fc008 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -2036,11 +2036,16 @@ std::optional IntrinsicInterface::Match( if (!sameArg) { sameArg = arg; } - // Check both ways so that a CLASS(*) actuals to - // MOVE_ALLOC and EOSHIFT both work. auto sameType{sameArg->GetType().value()}; - argOk = sameType.IsTkLenCompatibleWith(*type) || - type->IsTkLenCompatibleWith(sameType); + if (name == "move_alloc"s) { + // second argument can be more general + argOk = type->IsTkLenCompatibleWith(sameType); + } else if (name == "merge"s) { + argOk = type->IsTkLenCompatibleWith(sameType) && + sameType.IsTkLenCompatibleWith(*type); + } else { + argOk = sameType.IsTkLenCompatibleWith(*type); + } } break; case KindCode::sameKind: if (!sameArg) { diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index cb95db89ca08e62..c4562727f09b3f4 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -9746,7 +9746,7 @@ void ResolveNamesVisitor::ResolveSpecificationParts(ProgramTree &node) { }, node.stmt()); Walk(node.spec()); - bool inDeviceSubprogram = false; + bool inDeviceSubprogram{false}; // If this is a function, convert result to an object. This is to prevent the // result from being converted later to a function symbol if it is called // inside the function. diff --git a/flang/test/Semantics/bug124976.f90 b/flang/test/Semantics/bug124976.f90 new file mode 100644 index 000000000000000..29c21d4ead84751 --- /dev/null +++ b/flang/test/Semantics/bug124976.f90 @@ -0,0 +1,33 @@ +!RUN: %python %S/test_errors.py %s %flang_fc1 +program main + type base + integer :: x = 1 + end type + type, extends(base) :: child + integer :: y = 2 + end type + class(child), allocatable :: c1(:), c2(:,:) + class(base), allocatable :: b1(:), b2(:,:) + logical var(1) + common /blk/ var + allocate(c1(2), c2(2,2), b1(2), b2(2,2)) + !ERROR: Actual argument for 'pad=' has bad type or kind 'CLASS(base)' + c2 = reshape(c1, shape(c2), pad=b1) + b2 = reshape(b1, shape(b2), pad=c1) ! ok + !ERROR: Actual argument for 'to=' has bad type or kind 'CLASS(child)' + call move_alloc(b1, c1) + call move_alloc(c1, b1) ! ok + !ERROR: Actual argument for 'boundary=' has bad type or kind 'CLASS(base)' + c1 = eoshift(c1, 1, b1(1)) + c1 = eoshift(c1, 1, c2(1,1)) ! ok + b1 = eoshift(b1, 1, c1(1)) ! ok + !ERROR: Actual argument for 'fsource=' has bad type or kind 'CLASS(child)' + b1 = merge(b1, c1, var(1)) + !ERROR: Actual argument for 'fsource=' has bad type or kind 'CLASS(base)' + b1 = merge(c1, b1, var(1)) + b1 = merge(b1, b1, var(1)) ! ok + !ERROR: Actual argument for 'vector=' has bad type or kind 'CLASS(base)' + c1 = pack(c1, var, b1) + c1 = pack(c1, var, c1) ! ok + b1 = pack(b1, var, c1) ! ok +end