[flang] Fix bug resolving internal and module functions

When analyzing a function call in an expression we weren't properly
recognizing a ProcedureDesignator that was the name of an internal
or module function, i.e. a symbol with SubprogramDetails.

The fix is to add IsProcedure to identify symbols that correspond
to procedures. IsFunction and GetType also need to be extended to
handle this case.

Fixes flang-compiler/f18#391.

Original-commit: flang-compiler/f18@f165f8d38ce0cefd16e0f35644e8fdcbe92ed6de
Reviewed-on: https://github.com/flang-compiler/f18/pull/417
Tree-same-pre-rewrite: false

diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc
index 5dccd71183b050df95b88173a893b3bdfb3d86e8..751e4fb8ef501e8575319f42983854c97146b614 100644 (file)
--- a/flang/lib/semantics/expression.cc
+++ b/flang/lib/semantics/expression.cc
@@ -1443,15 +1443,14 @@ auto ExpressionAnalyzer::Procedure(const parser::ProcedureDesignator &pd,
   return std::visit(
       common::visitors{
           [&](const parser::Name &n) -> std::optional<CallAndArguments> {
-            if (n.symbol == nullptr) {
+            const Symbol *symbol{n.symbol};
+            if (symbol == nullptr) {
               Say("TODO INTERNAL no symbol for procedure designator name '%s'"_err_en_US,
                   n.ToString().data());
               return std::nullopt;
             }
-            const Symbol &ultimate{n.symbol->GetUltimate()};
-            if (const auto *proc{
-                    ultimate.detailsIf<semantics::ProcEntityDetails>()}) {
-              if (proc->HasExplicitInterface()) {
+            if (IsProcedure(*symbol)) {
+              if (symbol->HasExplicitInterface()) {
                 // TODO: check actual arguments vs. interface
               } else {
                 CallCharacteristics cc{n.source};
@@ -1468,7 +1467,7 @@ auto ExpressionAnalyzer::Procedure(const parser::ProcedureDesignator &pd,
                 }
               }
               return {CallAndArguments{
-                  ProcedureDesignator{*n.symbol}, std::move(arguments)}};
+                  ProcedureDesignator{*symbol}, std::move(arguments)}};
             } else {
               Say(n.source, "not a procedure"_err_en_US);
               return std::nullopt;

diff --git a/flang/lib/semantics/symbol.h b/flang/lib/semantics/symbol.h
index d22ce14f2da664560a466164070ac86503a59b04..756d97dcbe822ef0a4c87e4d92d2e6af72020f5b 100644 (file)
--- a/flang/lib/semantics/symbol.h
+++ b/flang/lib/semantics/symbol.h
@@ -497,6 +497,9 @@ public:
             [](const EntityDetails &x) { return x.type(); },
             [](const ObjectEntityDetails &x) { return x.type(); },
             [](const AssocEntityDetails &x) { return x.type(); },
+            [](const SubprogramDetails &x) {
+              return x.isFunction() ? x.result().GetType() : nullptr;
+            },
             [](const ProcEntityDetails &x) { return x.interface().type(); },
             [](const TypeParamDetails &x) { return x.type(); },
             [](const UseDetails &x) { return x.symbol().GetType(); },

diff --git a/flang/lib/semantics/tools.cc b/flang/lib/semantics/tools.cc
index 152b294aae8d7a3a9c4e972afa9f98ed9f812ce6..462aee1135a2a2b2f9bbae63dd4ab44d27a66e66 100644 (file)
--- a/flang/lib/semantics/tools.cc
+++ b/flang/lib/semantics/tools.cc
@@ -154,15 +154,20 @@ bool IsProcName(const Symbol &symbol) {
 }
 
 bool IsFunction(const Symbol &symbol) {
-  if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
-    return procDetails->interface().type() != nullptr ||
-        (procDetails->interface().symbol() != nullptr &&
-            IsFunction(*procDetails->interface().symbol()));
-  } else if (const auto *subprogram{symbol.detailsIf<SubprogramDetails>()}) {
-    return subprogram->isFunction();
-  } else {
-    return false;
-  }
+  return std::visit(
+      common::visitors{
+          [](const SubprogramDetails &x) { return x.isFunction(); },
+          [&](const SubprogramNameDetails &x) {
+            return symbol.test(Symbol::Flag::Function);
+          },
+          [](const ProcEntityDetails &x) {
+            const auto &ifc{x.interface()};
+            return ifc.type() || (ifc.symbol() && IsFunction(*ifc.symbol()));
+          },
+          [](const UseDetails &x) { return IsFunction(x.symbol()); },
+          [](const auto &) { return false; },
+      },
+      symbol.details());
 }
 
 bool IsPureFunction(const Symbol &symbol) {
@@ -177,6 +182,18 @@ bool IsPureFunction(const Scope &scope) {
   }
 }
 
+bool IsProcedure(const Symbol &symbol) {
+  return std::visit(
+      common::visitors{
+          [](const SubprogramDetails &) { return true; },
+          [](const SubprogramNameDetails &) { return true; },
+          [](const ProcEntityDetails &x) { return true; },
+          [](const UseDetails &x) { return IsProcedure(x.symbol()); },
+          [](const auto &) { return false; },
+      },
+      symbol.details());
+}
+
 static const Symbol *FindPointerComponent(
     const Scope &scope, std::set<const Scope *> &visited) {
   if (scope.kind() != Scope::Kind::DerivedType) {

diff --git a/flang/lib/semantics/tools.h b/flang/lib/semantics/tools.h
index 73bebb38d58df3d83bd94ae6a12f3ead3d25d993..c632ffeb3310afe396a7929b3e64b8b2239a29d5 100644 (file)
--- a/flang/lib/semantics/tools.h
+++ b/flang/lib/semantics/tools.h
@@ -59,6 +59,7 @@ bool IsPointerDummy(const Symbol &);
 bool IsFunction(const Symbol &);
 bool IsPureFunction(const Symbol &);
 bool IsPureFunction(const Scope &);
+bool IsProcedure(const Symbol &);
 bool IsProcName(const Symbol &symbol);  // proc-name
 bool IsVariableName(const Symbol &symbol);  // variable-name
 bool IsAllocatable(const Symbol &);

diff --git a/flang/test/semantics/if_construct01.f90 b/flang/test/semantics/if_construct01.f90
index 175c258762876343cc278bdc64c7ec170eb42652..0a9ae81c46aab02e7f2406450404ff7eab856b39 100644 (file)
--- a/flang/test/semantics/if_construct01.f90
+++ b/flang/test/semantics/if_construct01.f90
@@ -54,4 +54,12 @@ else if(a > b) then
   a = 14
 end if
 
+if (f()) then
+  a = 15
+end if
+
+contains
+  logical function f()
+    f = .true.
+  end
 end

diff --git a/flang/test/semantics/if_construct02.f90 b/flang/test/semantics/if_construct02.f90
index ef6f5adee36425ce263b3c450a71247a50f922f2..a2cab5c79862317feb8e970749af931a0217a8d5 100644 (file)
--- a/flang/test/semantics/if_construct02.f90
+++ b/flang/test/semantics/if_construct02.f90
@@ -123,4 +123,13 @@ else if( I ) then
   a = 14
 end if
 
+!ERROR: Must have LOGICAL type, but is REAL(4)
+if (f()) then
+  a = 15
+end if
+
+contains
+  real function f()
+    f = 1.0
+  end
 end

diff --git a/flang/test/semantics/procinterface01.f90 b/flang/test/semantics/procinterface01.f90
index 2dca54bb33798f6fa7d4afc89f71a490aa0fd0ef..ee772304c40a2ca09179dcb49e46dc1f234ec2cd 100644 (file)
--- a/flang/test/semantics/procinterface01.f90
+++ b/flang/test/semantics/procinterface01.f90
@@ -49,23 +49,23 @@ module module1
 
  !DEF: /module1/derived1 PUBLIC DerivedType
  type :: derived1
-  !DEF: /module1/abstract1 ELEMENTAL, PUBLIC Subprogram
+  !DEF: /module1/abstract1 ELEMENTAL, PUBLIC Subprogram REAL(4)
   !DEF: /module1/derived1/p1 NOPASS, POINTER ProcEntity
-  !DEF: /module1/nested1 ELEMENTAL, PUBLIC Subprogram
+  !DEF: /module1/nested1 ELEMENTAL, PUBLIC Subprogram REAL(4)
   procedure(abstract1), pointer, nopass :: p1 => nested1
-  !DEF: /module1/explicit1 ELEMENTAL, EXTERNAL, PUBLIC Subprogram
+  !DEF: /module1/explicit1 ELEMENTAL, EXTERNAL, PUBLIC Subprogram REAL(4)
   !DEF: /module1/derived1/p2 NOPASS, POINTER ProcEntity
   !REF: /module1/nested1
   procedure(explicit1), pointer, nopass :: p2 => nested1
-  !DEF: /module1/logical EXTERNAL, PUBLIC Subprogram
+  !DEF: /module1/logical EXTERNAL, PUBLIC Subprogram INTEGER(4)
   !DEF: /module1/derived1/p3 NOPASS, POINTER ProcEntity
-  !DEF: /module1/nested2 PUBLIC Subprogram
+  !DEF: /module1/nested2 PUBLIC Subprogram INTEGER(4)
   procedure(logical), pointer, nopass :: p3 => nested2
   !DEF: /module1/derived1/p4 NOPASS, POINTER ProcEntity LOGICAL(4)
-  !DEF: /module1/nested3 PUBLIC Subprogram
+  !DEF: /module1/nested3 PUBLIC Subprogram LOGICAL(4)
   procedure(type(logical(kind=4))), pointer, nopass :: p4 => nested3
   !DEF: /module1/derived1/p5 NOPASS, POINTER ProcEntity COMPLEX(4)
-  !DEF: /module1/nested4 PUBLIC Subprogram
+  !DEF: /module1/nested4 PUBLIC Subprogram COMPLEX(4)
   procedure(type(complex)), pointer, nopass :: p5 => nested4
   !DEF: /module1/derived1/p6 NOPASS, POINTER ProcEntity
   !REF: /module1/nested1
@@ -75,9 +75,9 @@ module module1
   procedure(sin), pointer, nopass :: p6 => nested1
   !DEF: /module1/derived1/p7 NOPASS, POINTER ProcEntity
   procedure(sin), pointer, nopass :: p7 => cos
-  !DEF: /module1/tan EXTERNAL, PUBLIC Subprogram
+  !DEF: /module1/tan EXTERNAL, PUBLIC Subprogram CHARACTER(1_4,1)
   !DEF: /module1/derived1/p8 NOPASS, POINTER ProcEntity
-  !DEF: /module1/nested5 PUBLIC Subprogram
+  !DEF: /module1/nested5 PUBLIC Subprogram CHARACTER(1_8,1)
   procedure(tan), pointer, nopass :: p8 => nested5
  end type derived1
 

diff --git a/flang/test/semantics/symbol01.f90 b/flang/test/semantics/symbol01.f90
index 49704bdd79ee7d309306976b576a054f67667ca5..e4d21a6e0626c7425b5e7383b541a3b1f3d529be 100644 (file)
--- a/flang/test/semantics/symbol01.f90
+++ b/flang/test/semantics/symbol01.f90
@@ -1,4 +1,4 @@
-! Copyright (c) 2018, NVIDIA CORPORATION.  All rights reserved.
+! Copyright (c) 2018-2019, NVIDIA CORPORATION.  All rights reserved.
 !
 ! Licensed under the Apache License, Version 2.0 (the "License");
 ! you may not use this file except in compliance with the License.
@@ -16,7 +16,7 @@
 
 !DEF: /m Module
 module m
- !DEF: /m/f PRIVATE, PURE, RECURSIVE Subprogram
+ !DEF: /m/f PRIVATE, PURE, RECURSIVE Subprogram REAL(4)
  private :: f
 contains
  !DEF: /m/s BIND(C), PUBLIC, PURE Subprogram