[flang] Semantic checks for C712 through C727

I've updated the compiler and test source with references to the contraints at
the points where they were enforced and tested.  Many of these were already
implemented and required no code change.  A few constraint checks were both
implemented and tested, and I only added references to the constraint
numbers in the compiler source and tests.  Here are the things I had to
implement:

Constraint C716 states that, in a REAL constant, if both a kind-param and an
exponent letter appear, the exponent letter must be 'E'.

Constraints C715 and C719 require that a KIND value be actually implemented.

Constraint C722 requires that functions that return assumed-length character
types are external.

Constraint C726 disallows assumed lenght charater types for dummy arguments and
return types.

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

diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h
index 2e135b0..7282a96 100644 (file)
--- a/flang/include/flang/Semantics/expression.h
+++ b/flang/include/flang/Semantics/expression.h
@@ -186,7 +186,7 @@ public:
     auto result{Analyze(x.thing)};
     if (result) {
       *result = Fold(std::move(*result));
-      if (!IsConstantExpr(*result)) { //C886,C887
+      if (!IsConstantExpr(*result)) {  //  C886, C887, C713
         SayAt(x, "Must be a constant value"_err_en_US);
         ResetExpr(x);
         return std::nullopt;

diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 69ca0e3..f739584 100644 (file)
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -48,7 +48,7 @@ const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &);
 const DeclTypeSpec *FindParentTypeSpec(const DeclTypeSpec &);
 const DeclTypeSpec *FindParentTypeSpec(const Scope &);
 const DeclTypeSpec *FindParentTypeSpec(const Symbol &);
- 
+
 // Return the Symbol of the variable of a construct association, if it exists
 const Symbol *GetAssociationRoot(const Symbol &);
 
@@ -78,6 +78,10 @@ bool DoesScopeContain(const Scope *, const Symbol &);
 bool IsUseAssociated(const Symbol &, const Scope &);
 bool IsHostAssociated(const Symbol &, const Scope &);
 bool IsDummy(const Symbol &);
+bool IsStmtFunction(const Symbol &);
+bool IsInStmtFunction(const Symbol &);
+bool IsStmtFunctionDummy(const Symbol &);
+bool IsStmtFunctionResult(const Symbol &);
 bool IsPointerDummy(const Symbol &);
 bool IsFunction(const Symbol &);
 bool IsPureProcedure(const Symbol &);
@@ -154,7 +158,7 @@ inline bool IsAssumedSizeArray(const Symbol &symbol) {
   return details && details->IsAssumedSize();
 }
 bool IsAssumedLengthCharacter(const Symbol &);
-bool IsAssumedLengthCharacterFunction(const Symbol &);
+bool IsAssumedLengthExternalCharacterFunction(const Symbol &);
 // Is the symbol modifiable in this scope
 std::optional<parser::MessageFixedText> WhyNotModifiable(
     const Symbol &, const Scope &);

diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index cfa675c..624fb35 100644 (file)
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -101,7 +101,7 @@ ConvertRealOperandsResult ConvertRealOperands(
             return {AsSameKindExprs<TypeCategory::Real>(
                 ConvertTo(ry, std::move(bx)), std::move(ry))};
           },
-          [&](auto &&, auto &&) -> ConvertRealOperandsResult {
+          [&](auto &&, auto &&) -> ConvertRealOperandsResult {  // C718
             messages.Say("operands must be INTEGER or REAL"_err_en_US);
             return std::nullopt;
           },

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 4e46331..1b7dd98 100644 (file)
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -105,9 +105,11 @@ private:
 
 void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {
   if (value.isAssumed()) {
-    if (!canBeAssumed) {  // C795
+    if (!canBeAssumed) {  // C795, C721, C726
       messages_.Say(
-          "An assumed (*) type parameter may be used only for a dummy argument, associate name, or named constant"_err_en_US);
+          "An assumed (*) type parameter may be used only for a (non-statement"
+          " function) dummy argument, associate name, named constant, or"
+          " external function result"_err_en_US);
     }
   } else {
     CheckSpecExpr(value.GetExplicit());
@@ -186,16 +188,19 @@ void CheckHelper::Check(const Symbol &symbol) {
       }
     }
   }
-  if (type) {
+  if (type) {  // Section 7.2, paragraph 7
     bool canHaveAssumedParameter{IsNamedConstant(symbol) ||
-        IsAssumedLengthCharacterFunction(symbol) ||
+        IsAssumedLengthExternalCharacterFunction(symbol) ||  // C722
         symbol.test(Symbol::Flag::ParentComp)};
-    if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
-      canHaveAssumedParameter |= object->isDummy() ||
-          (object->isFuncResult() &&
-              type->category() == DeclTypeSpec::Character);
-    } else {
-      canHaveAssumedParameter |= symbol.has<AssocEntityDetails>();
+    if (!IsStmtFunctionDummy(symbol)) {  // C726
+      if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+        canHaveAssumedParameter |= object->isDummy() ||
+            (object->isFuncResult() &&
+                type->category() == DeclTypeSpec::Character) ||
+            IsStmtFunctionResult(symbol);  // Avoids multiple messages
+      } else {
+        canHaveAssumedParameter |= symbol.has<AssocEntityDetails>();
+      }
     }
     Check(*type, canHaveAssumedParameter);
     if (InPure() && InFunction() && IsFunctionResult(symbol)) {
@@ -216,7 +221,7 @@ void CheckHelper::Check(const Symbol &symbol) {
       }
     }
   }
-  if (IsAssumedLengthCharacterFunction(symbol)) {  // C723
+  if (IsAssumedLengthExternalCharacterFunction(symbol)) {  // C723
     if (symbol.attrs().test(Attr::RECURSIVE)) {
       messages_.Say(
           "An assumed-length CHARACTER(*) function cannot be RECURSIVE"_err_en_US);

diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index a41e754..5c1a040 100644 (file)
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -500,10 +500,10 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) {
   // Use a local message context around the real literal for better
   // provenance on any messages.
   auto restorer{GetContextualMessages().SetLocation(x.real.source)};
-  // If a kind parameter appears, it defines the kind of the literal and any
-  // letter used in an exponent part (e.g., the 'E' in "6.02214E+23")
-  // should agree.  In the absence of an explicit kind parameter, any exponent
-  // letter determines the kind.  Otherwise, defaults apply.
+  // If a kind parameter appears, it defines the kind of the literal and the
+  // letter used in an exponent part must be 'E' (e.g., the 'E' in
+  // "6.02214E+23").  In the absence of an explicit kind parameter, any
+  // exponent letter determines the kind.  Otherwise, defaults apply.
   auto &defaults{context_.defaultKinds()};
   int defaultKind{defaults.GetDefaultKind(TypeCategory::Real)};
   const char *end{x.real.source.end()};
@@ -525,14 +525,13 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) {
     defaultKind = *letterKind;
   }
   auto kind{AnalyzeKindParam(x.kind, defaultKind)};
-  if (letterKind && kind != *letterKind && expoLetter != 'e') {
-    Say("Explicit kind parameter on real constant disagrees with "
-        "exponent letter '%c'"_en_US,
-        expoLetter);
+  if (x.kind && letterKind && expoLetter != 'e') {  // C716
+    Say("Explicit kind parameter on REAL constant can only be used with"
+        " exponent letter 'E'"_err_en_US);
   }
   auto result{common::SearchTypes(
       RealTypeVisitor{kind, x.real.source, GetFoldingContext()})};
-  if (!result) {
+  if (!result) {  // C717
     Say("Unsupported REAL(KIND=%d)"_err_en_US, kind);
   }
   return AsMaybeExpr(std::move(result));
@@ -704,7 +703,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::NamedConstant &n) {
     if (IsConstantExpr(folded)) {
       return {folded};
     }
-    Say(n.v.source, "must be a constant"_err_en_US);
+    Say(n.v.source, "must be a constant"_err_en_US);  // C718
   }
   return std::nullopt;
 }
@@ -1820,8 +1819,8 @@ void ExpressionAnalyzer::CheckForBadRecursion(
       if (proc.attrs().test(semantics::Attr::NON_RECURSIVE)) {  // 15.6.2.1(3)
         msg = Say("NON_RECURSIVE procedure '%s' cannot call itself"_err_en_US,
             callSite);
-      } else if (IsAssumedLengthCharacterFunction(proc)) {  // 15.6.2.1(3)
-        msg = Say(
+      } else if (IsAssumedLengthExternalCharacterFunction(proc)) {
+        msg = Say(  // 15.6.2.1(3)
             "Assumed-length CHARACTER(*) function '%s' cannot call itself"_err_en_US,
             callSite);
       }
@@ -2422,7 +2421,7 @@ DynamicType ExpressionAnalyzer::GetDefaultKindOfType(
 
 bool ExpressionAnalyzer::CheckIntrinsicKind(
     TypeCategory category, std::int64_t kind) {
-  if (IsValidKindOfIntrinsicType(category, kind)) {
+  if (IsValidKindOfIntrinsicType(category, kind)) {  // C712, C714, C715
     return true;
   } else {
     Say("%s(KIND=%jd) is not a supported type"_err_en_US,
@@ -2471,7 +2470,7 @@ bool ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at,
     const MaybeExpr &result, TypeCategory category, bool defaultKind) {
   if (result) {
     if (auto type{result->GetType()}) {
-      if (type->category() != category) { // C885
+      if (type->category() != category) {  // C885
         Say(at, "Must have %s type, but is %s"_err_en_US,
             ToUpperCase(EnumToString(category)),
             ToUpperCase(type->AsFortran()));

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 7d6fa5d..670cec7 100644 (file)
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -2602,6 +2602,7 @@ bool SubprogramVisitor::HandleStmtFunction(const parser::StmtFunctionStmt &x) {
   if (resultType) {
     resultDetails.set_type(*resultType);
   }
+  resultDetails.set_funcResult(true);
   Symbol &result{MakeSymbol(name, std::move(resultDetails))};
   ApplyImplicitRules(result);
   details.set_result(result);
@@ -3271,6 +3272,13 @@ void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Character &) {
 }
 void DeclarationVisitor::Post(const parser::CharSelector::LengthAndKind &x) {
   charInfo_.kind = EvaluateSubscriptIntExpr(x.kind);
+  std::optional<std::int64_t> intKind{ToInt64(charInfo_.kind)};
+  if (intKind &&
+      !evaluate::IsValidKindOfIntrinsicType(
+          TypeCategory::Character, *intKind)) {  // C715, C719
+    Say(currStmtSource().value(),
+        "KIND value (%jd) not valid for CHARACTER"_err_en_US, *intKind);
+  }
   if (x.length) {
     charInfo_.length = GetParamValue(*x.length, common::TypeParamAttr::Len);
   }

diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index b4a2a28..d5fc39c 100644 (file)
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -196,6 +196,29 @@ bool IsDummy(const Symbol &symbol) {
   }
 }
 
+bool IsStmtFunction(const Symbol &symbol) {
+  const auto *subprogram{symbol.detailsIf<SubprogramDetails>()};
+  if (subprogram && subprogram->stmtFunction()) {
+    return true;
+  }
+  return false;
+}
+
+bool IsInStmtFunction(const Symbol &symbol) {
+  if (const Symbol * function{symbol.owner().symbol()}) {
+    return IsStmtFunction(*function);
+  }
+  return false;
+}
+
+bool IsStmtFunctionDummy(const Symbol &symbol) {
+  return IsDummy(symbol) && IsInStmtFunction(symbol);
+}
+
+bool IsStmtFunctionResult(const Symbol &symbol) {
+  return IsFunctionResult(symbol) && IsInStmtFunction(symbol);
+}
+
 bool IsPointerDummy(const Symbol &symbol) {
   return IsPointer(symbol) && IsDummy(symbol);
 }
@@ -686,11 +709,13 @@ bool IsAssumedLengthCharacter(const Symbol &symbol) {
   }
 }
 
-bool IsAssumedLengthCharacterFunction(const Symbol &symbol) {
-  // Assumed-length character functions only appear as such in their
-  // definitions; their interfaces, pointers to them, and dummy procedures
-  // cannot be assumed-length.
-  return symbol.has<SubprogramDetails>() && IsAssumedLengthCharacter(symbol);
+// C722 and C723:  For a function to be assumed length, it must be external and
+// of CHARACTER type
+bool IsAssumedLengthExternalCharacterFunction(const Symbol &symbol) {
+  return IsAssumedLengthCharacter(symbol) &&
+      ((symbol.has<SubprogramDetails>() && symbol.owner().IsGlobal()) ||
+          (symbol.test(Symbol::Flag::Function) &&
+              symbol.attrs().test(Attr::EXTERNAL)));
 }
 
 const Symbol *IsExternalInPureContext(

diff --git a/flang/test/Semantics/CMakeLists.txt b/flang/test/Semantics/CMakeLists.txt
index ac3e9f6..51cc8e4 100644 (file)
--- a/flang/test/Semantics/CMakeLists.txt
+++ b/flang/test/Semantics/CMakeLists.txt
@@ -31,6 +31,7 @@ set(ERROR_TESTS
   io09.f90
   io10.f90
   kinds02.f90
+  kinds04.f90
   resolve01.f90
   resolve02.f90
   resolve03.f90
@@ -103,6 +104,9 @@ set(ERROR_TESTS
   resolve70.f90
   resolve71.f90
   resolve72.f90
+  resolve73.f90
+  resolve74.f90
+  resolve75.f90
   stop01.f90
   structconst01.f90
   structconst02.f90
@@ -207,6 +211,7 @@ set(ERROR_TESTS
   critical02.f90
   critical03.f90
   block-data01.f90
+  complex01.f90
   data01.f90
 )
 

diff --git a/flang/test/Semantics/call05.f90 b/flang/test/Semantics/call05.f90
index 09a2c13..368ec59 100644 (file)
--- a/flang/test/Semantics/call05.f90
+++ b/flang/test/Semantics/call05.f90
@@ -19,9 +19,9 @@ module m
   class(t2), allocatable :: pa2(:)
   class(*), pointer :: up(:)
   class(*), allocatable :: ua(:)
-  !ERROR: An assumed (*) type parameter may be used only for a dummy argument, associate name, or named constant
+  !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result
   type(pdt(*)), pointer :: amp(:)
-  !ERROR: An assumed (*) type parameter may be used only for a dummy argument, associate name, or named constant
+  !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result
   type(pdt(*)), allocatable :: ama(:)
   type(pdt(:)), pointer :: dmp(:)
   type(pdt(:)), allocatable :: dma(:)

diff --git a/flang/test/Semantics/complex01.f90 b/flang/test/Semantics/complex01.f90
new file mode 100644 (file)
index 0000000..4fb46ba
--- /dev/null
+++ b/flang/test/Semantics/complex01.f90
@@ -0,0 +1,32 @@
+! C718 Each named constant in a complex literal constant shall be of type 
+! integer or real.
+subroutine s()
+  integer :: ivar = 35
+  integer, parameter :: iconst = 35
+  real :: rvar = 68.9
+  real, parameter :: rconst = 68.9
+  character :: cvar = 'hello'
+  character, parameter :: cconst = 'hello'
+  logical :: lvar = .true.
+  logical, parameter :: lconst = .true.
+  complex :: cvar1 = (1, 1)
+  complex :: cvar2 = (1.0, 1.0)
+  complex :: cvar3 = (1.0, 1)
+  complex :: cvar4 = (1, 1.0)
+  complex :: cvar5 = (iconst, 1.0)
+  complex :: cvar6 = (iconst, rconst)
+  complex :: cvar7 = (rconst, iconst)
+
+  !ERROR: must be a constant
+  complex :: cvar8 = (ivar, 1.0)
+  !ERROR: must be a constant
+  !ERROR: must be a constant
+  complex :: cvar9 = (ivar, rvar)
+  !ERROR: must be a constant
+  !ERROR: must be a constant
+  complex :: cvar10 = (rvar, ivar)
+  !ERROR: operands must be INTEGER or REAL
+  complex :: cvar11 = (cconst, 1.0)
+  !ERROR: operands must be INTEGER or REAL
+  complex :: cvar12 = (lconst, 1.0)
+end subroutine s

diff --git a/flang/test/Semantics/kinds02.f90 b/flang/test/Semantics/kinds02.f90
index 4ad99ad..9fb9213 100644 (file)
--- a/flang/test/Semantics/kinds02.f90
+++ b/flang/test/Semantics/kinds02.f90
@@ -1,3 +1,15 @@
+! C712 The value of scalar-int-constant-expr shall be nonnegative and 
+! shall specify a representation method that exists on the processor.
+! C714 The value of kind-param shall be nonnegative.
+! C715 The value of kind-param shall specify a representation method that 
+! exists on the processor.
+! C719 The value of scalar-int-constant-expr shall be nonnegative and shall 
+! specify a representation method that exists on the processor.
+! C725 The optional comma in a length-selector is permitted only if no 
+! double-colon separator appears in the typedeclaration- stmt.
+! C727 The value of kind-param shall specify a representation method that 
+! exists on the processor.
+!
 !ERROR: INTEGER(KIND=0) is not a supported type
 integer(kind=0) :: j0
 !ERROR: INTEGER(KIND=-1) is not a supported type
@@ -40,4 +52,19 @@ logical(kind=-1) :: lm1
 logical(kind=3) :: l3
 !ERROR: LOGICAL(KIND=16) is not a supported type
 logical(kind=16) :: l16
+character (len=99, kind=1) :: cvar1
+character (len=99, kind=2) :: cvar2
+character *4, cvar3
+character *(5), cvar4
+!ERROR: KIND value (3) not valid for CHARACTER
+character (len=99, kind=3) :: cvar5
+!ERROR: KIND value (-1) not valid for CHARACTER
+character (len=99, kind=-1) :: cvar6
+character(len=*), parameter :: cvar7 = 1_"abcd"
+character(len=*), parameter :: cvar8 = 2_"abcd"
+!ERROR: CHARACTER(KIND=3) is not a supported type
+character(len=*), parameter :: cvar9 = 3_"abcd"
+character(len=*), parameter :: cvar10 = 4_"abcd"
+!ERROR: CHARACTER(KIND=8) is not a supported type
+character(len=*), parameter :: cvar11 = 8_"abcd"
 end program

diff --git a/flang/test/Semantics/kinds04.f90 b/flang/test/Semantics/kinds04.f90
new file mode 100644 (file)
index 0000000..a44c62b
--- /dev/null
+++ b/flang/test/Semantics/kinds04.f90
@@ -0,0 +1,31 @@
+! C716 If both kind-param and exponent-letter appear, exponent-letter 
+! shall be E.
+! C717 The value of kind-param shall specify an approximation method that 
+! exists on the processor.
+subroutine s(var)
+  real :: realvar1 = 4.0E6_4
+  real :: realvar2 = 4.0D6
+  real :: realvar3 = 4.0Q6
+  !ERROR: Explicit kind parameter on REAL constant can only be used with exponent letter 'E'
+  real :: realvar4 = 4.0D6_8
+  !ERROR: Explicit kind parameter on REAL constant can only be used with exponent letter 'E'
+  real :: realvar5 = 4.0Q6_16
+  real :: realvar6 = 4.0E6_8
+  real :: realvar7 = 4.0E6_10
+  real :: realvar8 = 4.0E6_16
+  !ERROR: Unsupported REAL(KIND=32)
+  real :: realvar9 = 4.0E6_32
+
+  double precision :: doublevar1 = 4.0E6_4
+  double precision :: doublevar2 = 4.0D6
+  double precision :: doublevar3 = 4.0Q6
+  !ERROR: Explicit kind parameter on REAL constant can only be used with exponent letter 'E'
+  double precision :: doublevar4 = 4.0D6_8
+  !ERROR: Explicit kind parameter on REAL constant can only be used with exponent letter 'E'
+  double precision :: doublevar5 = 4.0Q6_16
+  double precision :: doublevar6 = 4.0E6_8
+  double precision :: doublevar7 = 4.0E6_10
+  double precision :: doublevar8 = 4.0E6_16
+  !ERROR: Unsupported REAL(KIND=32)
+  double precision :: doublevar9 = 4.0E6_32
+end subroutine s

diff --git a/flang/test/Semantics/resolve35.f90 b/flang/test/Semantics/resolve35.f90
index 2598d9c..6acd24f 100644 (file)
--- a/flang/test/Semantics/resolve35.f90
+++ b/flang/test/Semantics/resolve35.f90
@@ -66,6 +66,7 @@ subroutine s6b
   integer :: l = 4
   forall(integer(k) :: i = 1:10)
   end forall
+  ! C713 A scalar-int-constant-name shall be a named constant of type integer.
   !ERROR: Must be a constant value
   forall(integer(l) :: i = 1:10)
   end forall

diff --git a/flang/test/Semantics/resolve37.f90 b/flang/test/Semantics/resolve37.f90
index a33e370..ccc05f3 100644 (file)
--- a/flang/test/Semantics/resolve37.f90
+++ b/flang/test/Semantics/resolve37.f90
@@ -6,6 +6,7 @@ integer :: n = 2
 !ERROR: Must be a constant value
 parameter(m=n)
 integer(k) :: x
+! C713 A scalar-int-constant-name shall be a named constant of type integer.
 !ERROR: Must have INTEGER type, but is REAL(4)
 integer(l) :: y
 !ERROR: Must be a constant value

diff --git a/flang/test/Semantics/resolve41.f90 b/flang/test/Semantics/resolve41.f90
index 3e5c48e..2f61867 100644 (file)
--- a/flang/test/Semantics/resolve41.f90
+++ b/flang/test/Semantics/resolve41.f90
@@ -4,6 +4,7 @@ module m
   !ERROR: Must have INTEGER type, but is REAL(4)
   integer :: aa = 2_a
   integer :: b = 8
+  ! C713 A scalar-int-constant-name shall be a named constant of type integer.
   !ERROR: Must be a constant value
   integer :: bb = 2_b
   !TODO: should get error -- not scalar

diff --git a/flang/test/Semantics/resolve73.f90 b/flang/test/Semantics/resolve73.f90
new file mode 100644 (file)
index 0000000..191be31
--- /dev/null
+++ b/flang/test/Semantics/resolve73.f90
@@ -0,0 +1,40 @@
+! C721 A type-param-value of * shall be used only
+! * to declare a dummy argument,
+! * to declare a named constant,
+! * in the type-spec of an ALLOCATE statement wherein each allocate-object is 
+!   a dummy argument of type CHARACTER with an assumed character length,
+! * in the type-spec or derived-type-spec of a type guard statement (11.1.11), 
+!   or
+! * in an external function, to declare the character length parameter of the function result.
+subroutine s(arg)
+  character(len=*), pointer :: arg
+  character*(*), parameter  :: cvar1 = "abc"
+  character*4,  cvar2
+  character(len=4_4) :: cvar3
+  !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result
+  character(len=*) :: cvar4
+
+  type derived(param)
+    integer, len :: param
+    class(*), allocatable :: x
+  end type
+  type(derived(34)) :: a
+  interface
+    function fun()
+      character(len=4) :: fun
+    end function fun
+  end interface
+
+  select type (ax => a%x)
+    type is (integer)
+      print *, "hello"
+    type is (character(len=*))
+      print *, "hello"
+    class is (derived(param=*))
+      print *, "hello"
+    class default
+      print *, "hello"
+  end select
+
+  allocate (character(len=*) :: arg)
+end subroutine s

diff --git a/flang/test/Semantics/resolve74.f90 b/flang/test/Semantics/resolve74.f90
new file mode 100644 (file)
index 0000000..a674b1f
--- /dev/null
+++ b/flang/test/Semantics/resolve74.f90
@@ -0,0 +1,37 @@
+! C722 A function name shall not be declared with an asterisk type-param-value 
+! unless it is of type CHARACTER and is the name of a dummy function or the 
+! name of the result of an external function.
+subroutine s()
+
+  type derived(param)
+    integer, len :: param
+  end type
+  type(derived(34)) :: a
+
+  procedure(character(len=*)) :: externCharFunc
+  !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result
+  procedure(type(derived(param =*))) :: externDerivedFunc
+
+  interface
+    subroutine subr(dummyFunc)
+      character(len=*) :: dummyFunc
+    end subroutine subr
+  end interface
+
+  contains
+    function works()
+      type(derived(param=4)) :: works
+    end function works
+
+  !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result
+    function fails1()
+      character(len=*) :: fails1
+    end function fails1
+
+  !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result
+    function fails2()
+  !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result
+      type(derived(param=*)) :: fails2
+    end function fails2
+
+end subroutine s

diff --git a/flang/test/Semantics/resolve75.f90 b/flang/test/Semantics/resolve75.f90
new file mode 100644 (file)
index 0000000..2c63a36
--- /dev/null
+++ b/flang/test/Semantics/resolve75.f90
@@ -0,0 +1,13 @@
+! C726 The length specified for a character statement function or for a 
+! statement function dummy argument of type character shall be a constant 
+! expression.
+subroutine s()
+  implicit character(len=3) (c)
+  implicit character(len=*) (d)
+  stmtFunc1 (x) = x * 32
+  cStmtFunc2 (x) = "abc"
+  !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result
+  cStmtFunc3 (dummy) = "abc"
+  !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result
+  dStmtFunc3 (x) = "abc"
+end subroutine s