diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -2353,7 +2353,11 @@ const CategorySet &set{pattern.categorySet}; CHECK(set.count() == 1); TypeCategory category{set.LeastElement().value()}; - return DynamicType{category, defaults_.GetDefaultKind(category)}; + if (pattern.kindCode == KindCode::doublePrecision) { + return DynamicType{category, defaults_.doublePrecisionKind()}; + } else { + return DynamicType{category, defaults_.GetDefaultKind(category)}; + } } IntrinsicProcTable::~IntrinsicProcTable() = default; diff --git a/flang/test/Semantics/call20.f90 b/flang/test/Semantics/call20.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/call20.f90 @@ -0,0 +1,39 @@ +! RUN: %S/test_errors.sh %s %t %flang_fc1 +! REQUIRES: shell + +! Test that the interface of specific intrinsics passed as dummy arguments +! are correctly validated against actual arguments explicit interface. + + intrinsic :: abs, dabs + interface + subroutine foo(f) + interface + function f(x) + real :: f + real, intent(in) :: x + end function + end interface + end subroutine + + subroutine foo2(f) + interface + function f(x) + double precision :: f + double precision, intent(in) :: x + end function + end interface + end subroutine + end interface + + ! OK + call foo(abs) + + ! OK + call foo2(dabs) + + !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f=' + call foo(dabs) + + !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f=' + call foo2(abs) +end