[flang-commits] [flang] 31fb52f - [flang] Apply double precision KindCode in specific proc interface

[Jean Perier via flang-commits]

Author: Jean Perier
Date: 2021-08-30T08:59:58+02:00
New Revision: 31fb52f8749ee43385cd7a9c8064c3adf58b2596

URL: https://github.com/llvm/llvm-project/commit/31fb52f8749ee43385cd7a9c8064c3adf58b2596
DIFF: https://github.com/llvm/llvm-project/commit/31fb52f8749ee43385cd7a9c8064c3adf58b2596.diff

LOG: [flang] Apply double precision KindCode in specific proc interface

The double precision KindCode was ignored when building the interface
of specific intrinsic procedures leading to bad semantics checks.

Differential Revision: https://reviews.llvm.org/D108828

Added: 
    flang/test/Semantics/call20.f90

Modified: 
    flang/lib/Evaluate/intrinsics.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index ae9e7c4599869..374d540549c5d 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2353,7 +2353,11 @@ DynamicType IntrinsicProcTable::Implementation::GetSpecificType(
   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
index 0000000000000..2ce7b1ced2f63
--- /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