[flang] snapshot of work in progress

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

diff --git a/flang/lib/evaluate/call.h b/flang/lib/evaluate/call.h
index d8a683f..8f0ea85 100644 (file)
--- a/flang/lib/evaluate/call.h
+++ b/flang/lib/evaluate/call.h
@@ -75,7 +75,7 @@ struct SpecificIntrinsic {
 
   IntrinsicProcedure name;
   bool isRestrictedSpecific{false};  // if true, can only call it
-  std::optional<DynamicType> type;  // absent if and only if subroutine call
+  std::optional<DynamicType> type;  // absent if subroutine call or NULL()
   int rank{0};
   semantics::Attrs attrs;  // ELEMENTAL, POINTER
 };

diff --git a/flang/lib/evaluate/intrinsics.cc b/flang/lib/evaluate/intrinsics.cc
index ab76dc8..6f9be43 100644 (file)
--- a/flang/lib/evaluate/intrinsics.cc
+++ b/flang/lib/evaluate/intrinsics.cc
@@ -1256,7 +1256,6 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
     if (arguments.size() == 0) {
       return std::make_optional<SpecificCall>(
           SpecificIntrinsic{"null"s}, std::move(arguments));
-      // TODO pmk work in progress - fold into NullPointer (where?)
     } else if (arguments.size() > 1) {
       genericErrors.Say("too many arguments to NULL()"_err_en_US);
     } else if (arguments[0].has_value() && arguments[0]->keyword.has_value() &&

diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc
index b1d127b..72eaa61 100644 (file)
--- a/flang/lib/semantics/expression.cc
+++ b/flang/lib/semantics/expression.cc
@@ -1473,14 +1473,32 @@ static MaybeExpr AnalyzeExpr(ExpressionAnalysisContext &context,
       }
       unavailable.insert(symbol->name());
       if (MaybeExpr value{AnalyzeExpr(context, expr)}) {
-        // TODO pmk: C7104, C7105 check that pointer components are
-        // being initialized with data/procedure designators appropriately
-        if (MaybeExpr converted{ConvertToType(*symbol, std::move(*value))}) {
-          result.Add(*symbol, std::move(*converted));
+        bool isNULL{std::holds_alternative<NullPointer>(value->u)};
+        if (symbol->has<semantics::ProcEntityDetails>()) {
+          CHECK(symbol->attrs().test(semantics::Attr::POINTER));
+          if (!isNULL) {
+            // TODO C7104: check that procedure pointer components are
+            // being initialized with compatible procedure designators
+            context.Say(expr.source,
+                "TODO: non-null procedure pointer component value not implemented yet"_err_en_US);
+          }
         } else {
-          if (auto *msg{context.Say(expr.source,
-                  "Structure constructor value is incompatible with component"_err_en_US)}) {
-            msg->Attach(symbol->name(), "Component declaration"_en_US);
+          CHECK(symbol->has<semantics::ObjectEntityDetails>());
+          if (symbol->attrs().test(semantics::Attr::POINTER)) {
+            if (!isNULL) {
+              // TODO C7104: check that object pointer components are
+              // being initialized with compatible object designators
+              context.Say(expr.source,
+                  "TODO: non-null object pointer component value not implemented yet"_err_en_US);
+            }
+          } else if (MaybeExpr converted{
+                         ConvertToType(*symbol, std::move(*value))}) {
+            result.Add(*symbol, std::move(*converted));
+          } else {
+            if (auto *msg{context.Say(expr.source,
+                    "Structure constructor value is incompatible with component"_err_en_US)}) {
+              msg->Attach(symbol->name(), "Component declaration"_en_US);
+            }
           }
         }
       }
@@ -1628,6 +1646,13 @@ static MaybeExpr AnalyzeExpr(ExpressionAnalysisContext &context,
       return TypedWrapper<FunctionRef, ProcedureRef>(*dyType,
           ProcedureRef{std::move(proc->procedureDesignator),
               std::move(proc->arguments)});
+    } else {
+      if (const auto *intrinsic{
+              std::get_if<SpecificIntrinsic>(&proc->procedureDesignator.u)}) {
+        if (intrinsic->name == "null"s && proc->arguments.empty()) {
+          return {Expr<SomeType>{NullPointer{}}};
+        }
+      }
     }
   }
   return std::nullopt;

diff --git a/flang/lib/semantics/symbol.cc b/flang/lib/semantics/symbol.cc
index de708f9..e1d4dc7 100644 (file)
--- a/flang/lib/semantics/symbol.cc
+++ b/flang/lib/semantics/symbol.cc
@@ -591,6 +591,7 @@ Symbol &Symbol::Instantiate(
           },
           [&](const ProcBindingDetails &that) { symbol.details_ = that; },
           [&](const GenericBindingDetails &that) { symbol.details_ = that; },
+          [&](const ProcEntityDetails &that) { symbol.details_ = that; },
           [&](const TypeParamDetails &that) {
             // LEN type parameter, or error recovery on a KIND type parameter
             // with no corresponding actual argument or default

diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt
index 4edbad0..2df6257 100644 (file)
--- a/flang/test/semantics/CMakeLists.txt
+++ b/flang/test/semantics/CMakeLists.txt
@@ -73,6 +73,7 @@ set(ERROR_TESTS
   resolve45.f90
   resolve46.f90
   structconst01.f90
+  structconst02.f90
 )
 
 # These test files have expected symbols in the source

diff --git a/flang/test/semantics/structconst02.f90 b/flang/test/semantics/structconst02.f90
new file mode 100644 (file)
index 0000000..a50fa0f
--- /dev/null
+++ b/flang/test/semantics/structconst02.f90
@@ -0,0 +1,52 @@
+! Copyright (c) 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.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! Error tests for structure constructors: per-component type
+! (in)compatibility.
+
+module module1
+  interface
+    real function realfunc(x)
+      real, value :: x
+    end function realfunc
+  end interface
+  type :: scalar(ik,rk,zk,ck,lk,len)
+    integer, kind :: ik = 4, rk = 4, zk = 4, ck = 1, lk = 1
+    integer, len :: len = 1
+    integer(kind=ik) :: ix = 0
+    real(kind=rk) :: rx = 0.
+    complex(kind=zk) :: zx = (0.,0.)
+    character(kind=ck,len=len) :: cx = ' '
+    logical(kind=lk) :: lx = .false.
+    real(kind=rk), pointer :: rp = NULL()
+    procedure(realfunc), pointer :: rfp1 => NULL()
+    procedure(real), pointer :: rfp2 => NULL()
+  end type scalar
+ contains
+  subroutine scalararg(x)
+    type(scalar), intent(in) :: x
+  end subroutine scalararg
+  subroutine errors
+    call scalararg(scalar(4)(ix=1,rx=2.,zx=(3.,4.),cx='a',lx=.true.))
+    call scalararg(scalar(4)(1,2.,(3.,4.),'a',.true.))
+!    call scalararg(scalar(4)(ix=5.,rx=6,zx=(7._8,8._2),cx=4_'b',lx=.true._4))
+!    call scalararg(scalar(4)(5.,6,(7._8,8._2),4_'b',.true._4))
+    call scalararg(scalar(4)(ix=5.,rx=6,zx=(7._8,8._2),cx=4_'b',lx=.true.))
+    call scalararg(scalar(4)(5.,6,(7._8,8._2),4_'b',.true.))
+    call scalararg(scalar(4)(ix='a'))
+    call scalararg(scalar(4)(ix=.false.))
+    call scalararg(scalar(4)(ix=[1]))
+    !TODO more!
+  end subroutine errors
+end module module1