[flang] Apply implicit typing to names in COMMON that appear in speci…

…fication expressions

Extend semantic analysis of expressions to catch missing cases

Fix statement function semantics, add degree trig intrinsics

Add GetUltimate to rewrite of bare namelist

Address review comments

Original-commit: flang-compiler/f18@52ff319
Reviewed-on: flang-compiler/f18#871

flang/lib/evaluate/characteristics.cc

@@ -67,7 +67,7 @@ bool TypeAndShape::operator==(const TypeAndShape &that) const {
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
-    const semantics::Symbol &symbol) {
+    const semantics::Symbol &symbol, FoldingContext &context) {
   return std::visit(
       common::visitors{
           [&](const semantics::ObjectEntityDetails &object) {
@@ -78,22 +78,17 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
             if (interface.type()) {
               return Characterize(*interface.type());
             } else {
-              return Characterize(*interface.symbol());
+              return Characterize(*interface.symbol(), context);
             }
           },
           [&](const semantics::UseDetails &use) {
-            return Characterize(use.symbol());
+            return Characterize(use.symbol(), context);
           },
           [&](const semantics::HostAssocDetails &assoc) {
-            return Characterize(assoc.symbol());
+            return Characterize(assoc.symbol(), context);
           },
-          [](const semantics::AssocEntityDetails &assoc) {
-            if (const semantics::Symbol *
-                nested{UnwrapWholeSymbolDataRef(assoc.expr())}) {
-              return Characterize(*nested);
-            } else {
-              return std::optional<TypeAndShape>{};
-            }
+          [&](const semantics::AssocEntityDetails &assoc) {
+            return Characterize(assoc, context);
           },
           [](const auto &) { return std::optional<TypeAndShape>{}; },
       },
@@ -111,6 +106,16 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
   }
 }
 
+std::optional<TypeAndShape> TypeAndShape::Characterize(
+    const semantics::AssocEntityDetails &assoc, FoldingContext &context) {
+  if (auto type{DynamicType::From(assoc.type())}) {
+    if (auto shape{GetShape(context, assoc.expr())}) {
+      return TypeAndShape{std::move(*type), std::move(*shape)};
+    }
+  }
+  return std::nullopt;
+}
+
 std::optional<TypeAndShape> TypeAndShape::Characterize(
     const semantics::DeclTypeSpec &spec) {
   if (auto type{DynamicType::From(spec)}) {
@@ -126,6 +131,9 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
     if (const auto *object{
             symbol->detailsIf<semantics::ObjectEntityDetails>()}) {
       return Characterize(*object);
+    } else if (const auto *assoc{
+                   symbol->detailsIf<semantics::AssocEntityDetails>()}) {
+      return Characterize(*assoc, context);
     }
   }
   if (auto type{expr.GetType()}) {

flang/lib/evaluate/characteristics.h

@@ -76,9 +76,12 @@ class TypeAndShape {
 
   bool operator==(const TypeAndShape &) const;
   bool operator!=(const TypeAndShape &that) const { return !(*this == that); }
-  static std::optional<TypeAndShape> Characterize(const semantics::Symbol &);
+  static std::optional<TypeAndShape> Characterize(
+      const semantics::Symbol &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
       const semantics::ObjectEntityDetails &);
+  static std::optional<TypeAndShape> Characterize(
+      const semantics::AssocEntityDetails &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
       const semantics::ProcEntityDetails &);
   static std::optional<TypeAndShape> Characterize(

flang/lib/evaluate/formatting.cc

@@ -639,12 +639,17 @@ std::ostream &DescriptorInquiry::AsFortran(std::ostream &o) const {
   case Field::Extent: o << "size("; break;
   case Field::Stride: o << "%STRIDE("; break;
   case Field::Rank: o << "rank("; break;
+  case Field::Len: break;
   }
   base_.AsFortran(o);
-  if (dimension_ >= 0) {
-    o << ",dim=" << (dimension_ + 1);
+  if (field_ == Field::Len) {
+    return o << "%len";
+  } else {
+    if (dimension_ >= 0) {
+      o << ",dim=" << (dimension_ + 1);
+    }
+    return o << ')';
   }
-  return o << ')';
 }
 
 INSTANTIATE_CONSTANT_TEMPLATES

flang/lib/evaluate/intrinsics.cc

@@ -258,6 +258,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"abs", {{"a", SameComplex}}, SameReal},
     {"achar", {{"i", AnyInt, Rank::elementalOrBOZ}, DefaultingKIND}, KINDChar},
     {"acos", {{"x", SameFloating}}, SameFloating},
+    {"acosd", {{"x", SameFloating}}, SameFloating},
     {"acosh", {{"x", SameFloating}}, SameFloating},
     {"adjustl", {{"string", SameChar}}, SameChar},
     {"adjustr", {{"string", SameChar}}, SameChar},
@@ -271,14 +272,18 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"any", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical,
         Rank::dimReduced},
     {"asin", {{"x", SameFloating}}, SameFloating},
+    {"asind", {{"x", SameFloating}}, SameFloating},
     {"asinh", {{"x", SameFloating}}, SameFloating},
     {"associated",
         {{"pointer", Addressable, Rank::known},
             {"target", Addressable, Rank::known, Optionality::optional}},
         DefaultLogical},
     {"atan", {{"x", SameFloating}}, SameFloating},
+    {"atand", {{"x", SameFloating}}, SameFloating},
     {"atan", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
+    {"atand", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
     {"atan2", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
+    {"atan2d", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
     {"atanh", {{"x", SameFloating}}, SameFloating},
     {"bessel_j0", {{"x", SameReal}}, SameReal},
     {"bessel_j1", {{"x", SameReal}}, SameReal},
@@ -325,6 +330,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"command_argument_count", {}, DefaultInt, Rank::scalar},
     {"conjg", {{"z", SameComplex}}, SameComplex},
     {"cos", {{"x", SameFloating}}, SameFloating},
+    {"cosd", {{"x", SameFloating}}, SameFloating},
     {"cosh", {{"x", SameFloating}}, SameFloating},
     {"count", {{"mask", AnyLogical, Rank::array}, OptionalDIM, DefaultingKIND},
         KINDInt, Rank::dimReduced},
@@ -648,6 +654,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"shiftr", {{"i", SameInt}, {"shift", AnyInt}}, SameInt},
     {"sign", {{"a", SameIntOrReal}, {"b", SameIntOrReal}}, SameIntOrReal},
     {"sin", {{"x", SameFloating}}, SameFloating},
+    {"sind", {{"x", SameFloating}}, SameFloating},
     {"sinh", {{"x", SameFloating}}, SameFloating},
     {"size",
         {{"array", AnyData, Rank::anyOrAssumedRank}, OptionalDIM,
@@ -665,6 +672,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"sum", {{"array", SameNumeric, Rank::array}, OptionalDIM, OptionalMASK},
         SameNumeric, Rank::dimReduced},
     {"tan", {{"x", SameFloating}}, SameFloating},
+    {"tand", {{"x", SameFloating}}, SameFloating},
     {"tanh", {{"x", SameFloating}}, SameFloating},
     {"tiny", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, Rank::scalar},
     {"trailz", {{"i", AnyInt}}, DefaultInt},
@@ -707,8 +715,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
 //   IS_CONTIGUOUS
 // TODO: Non-standard intrinsic functions
 //  AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT,
-//  COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL,
-//  EQV, NEQV, INT8, JINT, JNINT, KNINT,
+//  COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT,
 //  QCMPLX, DFLOAT, QEXT, QFLOAT, QREAL, DNUM,
 //  INUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF,
 //  MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR
@@ -789,6 +796,7 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
     {{"clog", {{"a", DefaultComplex}}, DefaultComplex}, "log"},
     {{"conjg", {{"a", DefaultComplex}}, DefaultComplex}},
     {{"cos", {{"x", DefaultReal}}, DefaultReal}},
+    {{"cosh", {{"x", DefaultReal}}, DefaultReal}},
     {{"csin", {{"a", DefaultComplex}}, DefaultComplex}, "sin"},
     {{"csqrt", {{"a", DefaultComplex}}, DefaultComplex}, "sqrt"},
     {{"ctan", {{"a", DefaultComplex}}, DefaultComplex}, "tan"},
@@ -1673,10 +1681,9 @@ static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface,
 std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
     const CallCharacteristics &call, ActualArguments &arguments,
     FoldingContext &context, const IntrinsicProcTable &intrinsics) const {
-  std::string name{call.name.ToString()};
   if (call.isSubroutineCall) {
     parser::Messages buffer;
-    auto subrRange{subroutines_.equal_range(name)};
+    auto subrRange{subroutines_.equal_range(call.name)};
     for (auto iter{subrRange.first}; iter != subrRange.second; ++iter) {
       if (auto specificCall{
               iter->second->Match(call, defaults_, arguments, context)}) {
@@ -1689,15 +1696,15 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
   // Special case: NULL()
   // All special cases handled here before the table probes below must
   // also be caught as special names in IsIntrinsic().
-  if (name == "null") {
+  if (call.name == "null") {
     return HandleNull(arguments, context, intrinsics);
   }
 
   // Helper to avoid emitting errors before it is sure there is no match
   parser::Messages localBuffer;
   parser::Messages *finalBuffer{context.messages().messages()};
   parser::ContextualMessages localMessages{
-      call.name, finalBuffer ? &localBuffer : nullptr};
+      context.messages().at(), finalBuffer ? &localBuffer : nullptr};
   FoldingContext localContext{context, localMessages};
   auto matchOrBufferMessages{
       [&](const IntrinsicInterface &intrinsic,
@@ -1718,7 +1725,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
 
   // Probe the generic intrinsic function table first.
   parser::Messages genericBuffer;
-  auto genericRange{genericFuncs_.equal_range(name)};
+  auto genericRange{genericFuncs_.equal_range(call.name)};
   for (auto iter{genericRange.first}; iter != genericRange.second; ++iter) {
     if (auto specificCall{
             matchOrBufferMessages(*iter->second, genericBuffer)}) {
@@ -1729,7 +1736,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
 
   // Probe the specific intrinsic function table next.
   parser::Messages specificBuffer;
-  auto specificRange{specificFuncs_.equal_range(name)};
+  auto specificRange{specificFuncs_.equal_range(call.name)};
   for (auto specIter{specificRange.first}; specIter != specificRange.second;
        ++specIter) {
     // We only need to check the cases with distinct generic names.
@@ -1764,7 +1771,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
                 "Argument type does not match specific intrinsic '%s' "
                 "requirements; using '%s' generic instead and converting the "
                 "result to %s if needed"_en_US,
-                name, genericName, newType.AsFortran());
+                call.name, genericName, newType.AsFortran());
             specificCall->specificIntrinsic.characteristics.value()
                 .functionResult.value()
                 .SetType(newType);

flang/lib/evaluate/intrinsics.h

@@ -23,13 +23,14 @@
 #include "../parser/message.h"
 #include <optional>
 #include <ostream>
+#include <string>
 
 namespace Fortran::evaluate {
 
 class FoldingContext;
 
 struct CallCharacteristics {
-  parser::CharBlock name;
+  std::string name;
   bool isSubroutineCall{false};
 };
 

flang/lib/evaluate/type.cc

@@ -32,32 +32,10 @@
 namespace Fortran::semantics {
 static bool IsDescriptor(const ObjectEntityDetails &details) {
   if (const auto *type{details.type()}) {
-    if (const IntrinsicTypeSpec * typeSpec{type->AsIntrinsic()}) {
-      if (typeSpec->category() == TypeCategory::Character) {
-        // TODO maybe character lengths won't be in descriptors
+    if (auto dynamicType{evaluate::DynamicType::From(*type)}) {
+      if (dynamicType->RequiresDescriptor()) {
         return true;
       }
-    } else if (const DerivedTypeSpec * typeSpec{type->AsDerived()}) {
-      if (details.isDummy()) {
-        return true;
-      }
-      // Any length type parameter?
-      if (const Scope * scope{typeSpec->scope()}) {
-        if (const Symbol * symbol{scope->symbol()}) {
-          if (const auto *details{symbol->detailsIf<DerivedTypeDetails>()}) {
-            for (const Symbol &param : details->paramDecls()) {
-              if (const auto *details{param.detailsIf<TypeParamDetails>()}) {
-                if (details->attr() == common::TypeParamAttr::Len) {
-                  return true;
-                }
-              }
-            }
-          }
-        }
-      }
-    } else if (type->category() == DeclTypeSpec::Category::TypeStar ||
-        type->category() == DeclTypeSpec::Category::ClassStar) {
-      return true;
     }
   }
   if (details.IsAssumedShape() || details.IsDeferredShape() ||
@@ -85,6 +63,17 @@ bool IsDescriptor(const Symbol &symbol0) {
         symbol.attrs().test(Attr::EXTERNAL)) {
       return IsDescriptor(*procDetails);
     }
+  } else if (const auto *assocDetails{symbol.detailsIf<AssocEntityDetails>()}) {
+    if (const auto &expr{assocDetails->expr()}) {
+      if (expr->Rank() > 0) {
+        return true;
+      }
+      if (const auto dynamicType{expr->GetType()}) {
+        if (dynamicType->RequiresDescriptor()) {
+          return true;
+        }
+      }
+    }
   }
   return false;
 }
@@ -394,6 +383,31 @@ DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const {
   return *this;
 }
 
+bool DynamicType::RequiresDescriptor() const {
+  if (IsPolymorphic() || IsAssumedLengthCharacter()) {
+    return true;
+  }
+  if (derived_) {
+    // Any length type parameter?
+    if (const auto *scope{derived_->scope()}) {
+      if (const auto *symbol{scope->symbol()}) {
+        if (const auto *details{
+                symbol->detailsIf<semantics::DerivedTypeDetails>()}) {
+          for (const Symbol &param : details->paramDecls()) {
+            if (const auto *details{
+                    param.detailsIf<semantics::TypeParamDetails>()}) {
+              if (details->attr() == common::TypeParamAttr::Len) {
+                return true;
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+  return false;
+}
+
 bool SomeKind<TypeCategory::Derived>::operator==(
     const SomeKind<TypeCategory::Derived> &that) const {
   return PointeeComparison(derivedTypeSpec_, that.derivedTypeSpec_);

flang/lib/evaluate/type.h

@@ -162,6 +162,8 @@ class DynamicType {
     return DEREF(derived_);
   }
 
+  bool RequiresDescriptor() const;
+
   // 7.3.2.3 & 15.5.2.4 type compatibility.
   // x.IsTypeCompatibleWith(y) is true if "x => y" or passing actual y to
   // dummy argument x would be valid.  Be advised, this is not a reflexive

flang/lib/evaluate/variable.cc

@@ -249,14 +249,16 @@ DescriptorInquiry::DescriptorInquiry(
   : base_{base}, field_{field}, dimension_{dim} {
   const Symbol &last{base_.GetLastSymbol()};
   CHECK(IsDescriptor(last));
-  CHECK(dim >= 0 && dim < last.Rank());
+  CHECK((field == Field::Len && dim == 0) ||
+      (field != Field::Len && dim >= 0 && dim < last.Rank()));
 }
 
 DescriptorInquiry::DescriptorInquiry(NamedEntity &&base, Field field, int dim)
   : base_{std::move(base)}, field_{field}, dimension_{dim} {
   const Symbol &last{base_.GetLastSymbol()};
   CHECK(IsDescriptor(last));
-  CHECK(dim >= 0 && dim < last.Rank());
+  CHECK((field == Field::Len && dim == 0) ||
+      (field != Field::Len && dim >= 0 && dim < last.Rank()));
 }
 
 // LEN()
@@ -265,6 +267,9 @@ static std::optional<Expr<SubscriptInteger>> SymbolLEN(const Symbol &sym) {
     if (const semantics::ParamValue * len{dyType->charLength()}) {
       if (auto intExpr{len->GetExplicit()}) {
         return ConvertToType<SubscriptInteger>(*std::move(intExpr));
+      } else {
+        return Expr<SubscriptInteger>{
+            DescriptorInquiry{NamedEntity{sym}, DescriptorInquiry::Field::Len}};
       }
     }
   }

flang/lib/evaluate/variable.h

@@ -139,7 +139,9 @@ class NamedEntity {
 
 // R916 type-param-inquiry
 // N.B. x%LEN for CHARACTER is rewritten in semantics to LEN(x), which is
-// then handled via LEN() member functions in the various classes.
+// then handled via LEN() member functions in the various classes;
+// it becomes a DescriptorInquiry with Field::Len for assumed-length
+// CHARACTER objects.
 // x%KIND for intrinsic types is similarly rewritten in semantics to
 // KIND(x), which is then folded to a constant value.
 // "Bare" type parameter references within a derived type definition do
@@ -441,11 +443,11 @@ template<typename T> struct Variable {
 class DescriptorInquiry {
 public:
   using Result = SubscriptInteger;
-  ENUM_CLASS(Field, LowerBound, Extent, Stride, Rank)
+  ENUM_CLASS(Field, LowerBound, Extent, Stride, Rank, Len)
 
   CLASS_BOILERPLATE(DescriptorInquiry)
-  DescriptorInquiry(const NamedEntity &, Field, int);
-  DescriptorInquiry(NamedEntity &&, Field, int);
+  DescriptorInquiry(const NamedEntity &, Field, int = 0);
+  DescriptorInquiry(NamedEntity &&, Field, int = 0);
 
   NamedEntity &base() { return base_; }
   const NamedEntity &base() const { return base_; }