[flang] Extension: unrestricted intrinsics as specifics in generics

[klausler]

Summary

At least one other Fortran compiler supports the use of unrestricted intrinsic
functions as specific procedures in generic interfaces, and the usage seems
to be both useful and unambiguous. Support it with a portability warning.

Fixes llvm-test-suite/Fortran/gfortran/regression/pr95500.f90.

flang/docs/Extensions.md

* INCLUDE lines can start in any column, can be preceded in
   between the letters of the word INCLUDE, and can have a
   numeric character literal kind prefix on the file name.
 * Intrinsic procedures TAND and ATAND. Constant folding is currently
   not supported for these procedures but this is planned.
 * When a pair of quotation marks in a character literal are split
   by a line continuation in free form, the second quotation mark
   may appear at the beginning of the continuation line without an
   ampersand, althought one is required by the standard.
+* Unrestricted `INTRINSIC` functions are accepted for use in
+  `PROCEDURE` statements in generic interfaces, as in some other
+  compilers.
 
 ### Extensions supported when enabled by options
 
 * C-style backslash escape sequences in quoted CHARACTER literals
   (but not Hollerith) [-fbackslash]
 * Logical abbreviations `.T.`, `.F.`, `.N.`, `.A.`, `.O.`, and `.X.`
   [-flogical-abbreviations]
 * `.XOR.` as a synonym for `.NEQV.` [-fxor-operator]

flang/lib/Semantics/check-declarations.cpp

if (specific.attrs().test(Attr::ABSTRACT)) {
               "Generic interface '%s' must not use abstract interface '%s' as a specific procedure"_err_en_US,
               generic.name(), specific.name())}) {
         msg->Attach(
             specific.name(), "Definition of '%s'"_en_US, specific.name());
       }
       continue;
     }
     if (specific.attrs().test(Attr::INTRINSIC)) {
+      // GNU Fortran allows INTRINSIC procedures in generics.
+      auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
+          specific.name().ToString())};
+      if (intrinsic && !intrinsic->isRestrictedSpecific) {
         if (auto *msg{messages_.Say(specific.name(),
-              "Specific procedure '%s' of generic interface '%s' may not be INTRINSIC"_err_en_US,
+                "Specific procedure '%s' of generic interface '%s' should not be INTRINSIC"_port_en_US,
                 specific.name(), generic.name())}) {
-        msg->Attach(generic.name(), "Definition of '%s'"_en_US, generic.name());
+          msg->Attach(
+              generic.name(), "Definition of '%s'"_en_US, generic.name());
+        }
+      } else {
+        if (auto *msg{messages_.Say(specific.name(),
+                "Procedure '%s' of generic interface '%s' is INTRINSIC but not an unrestricted specific intrinsic function"_port_en_US,
+                specific.name(), generic.name())}) {
+          msg->Attach(
+              generic.name(), "Definition of '%s'"_en_US, generic.name());
         }
         continue;
       }
+    }
     if (IsStmtFunction(specific)) {
       if (auto *msg{messages_.Say(specific.name(),
               "Specific procedure '%s' of generic interface '%s' may not be a statement function"_err_en_US,
               specific.name(), generic.name())}) {
         msg->Attach(generic.name(), "Definition of '%s'"_en_US, generic.name());
       }
       continue;
     }

flang/lib/Semantics/expression.cpp

auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
   } else if (IsProcedure(ultimate) &&
       ultimate.attrs().test(semantics::Attr::ABSTRACT)) {
     Say("Abstract procedure interface '%s' may not be referenced"_err_en_US,
         name.source);
   } else {
     resolution = symbol;
   }
   if (!resolution || resolution->attrs().test(semantics::Attr::INTRINSIC)) {
-    // Not generic, or no resolution; may be intrinsic
+    auto name{resolution ? resolution->name() : ultimate.name()};
     if (std::optional<SpecificCall> specificCall{context_.intrinsics().Probe(
-            CallCharacteristics{ultimate.name().ToString(), isSubroutine},
-            arguments, GetFoldingContext())}) {
+            CallCharacteristics{name.ToString(), isSubroutine}, arguments,
+            GetFoldingContext())}) {
       CheckBadExplicitType(*specificCall, *symbol);
       return CalleeAndArguments{
           ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
           std::move(specificCall->arguments)};
     } else {
       if (isGenericInterface) {
         EmitGenericResolutionError(*symbol, dueToAmbiguity, isSubroutine);
       }

flang/lib/Semantics/resolve-names.cpp

if (symbol.has<GenericDetails>()) {
       // Generic interface is extending intrinsic; ok
     } else if (!ConvertToProcEntity(symbol)) {
       SayWithDecl(
           name, symbol, "INTRINSIC attribute not allowed on '%s'"_err_en_US);
     } else if (symbol.attrs().test(Attr::EXTERNAL)) { // C840
       Say(symbol.name(),
           "Symbol '%s' cannot have both EXTERNAL and INTRINSIC attributes"_err_en_US,
           symbol.name());
-    } else if (symbol.GetType()) {
+    } else {
+      if (symbol.GetType()) {
         // These warnings are worded so that they should make sense in either
         // order.
         Say(symbol.name(),
             "Explicit type declaration ignored for intrinsic function '%s'"_warn_en_US,
             symbol.name())
             .Attach(name.source,
                 "INTRINSIC statement for explicitly-typed '%s'"_en_US,
                 name.source);
       }
+      if (!symbol.test(Symbol::Flag::Function) &&
+          !symbol.test(Symbol::Flag::Subroutine)) {
+        if (context().intrinsics().IsIntrinsicFunction(
+                name.source.ToString())) {
+          symbol.set(Symbol::Flag::Function);
+        } else if (context().intrinsics().IsIntrinsicSubroutine(
+                       name.source.ToString())) {
+          symbol.set(Symbol::Flag::Subroutine);
+        }
+      }
+    }
   }
   return false;
 }
 bool DeclarationVisitor::Pre(const parser::OptionalStmt &x) {
   return CheckNotInBlock("OPTIONAL") && // C1107
       HandleAttributeStmt(Attr::OPTIONAL, x.v);
 }
 bool DeclarationVisitor::Pre(const parser::ProtectedStmt &x) {

flang/test/Semantics/call16.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 
 ! Test that intrinsic functions used as subroutines and vice versa are caught.
 
 subroutine test(x, t)
  intrinsic :: sin, cpu_time
- !ERROR: Cannot use intrinsic function 'sin' as a subroutine
+ !ERROR: Cannot call intrinsic function 'sin' as a subroutine
  call sin(x)
- !ERROR: Cannot use intrinsic subroutine 'cpu_time' as a function
+ !ERROR: Cannot call intrinsic subroutine 'cpu_time' as a function
  x = cpu_time(t)
 end subroutine
 
 

flang/test/Semantics/generic06.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 module m
-  !ERROR: Specific procedure 'sin' of generic interface 'yintercept' may not be INTRINSIC
+  !PORTABILITY: Specific procedure 'sin' of generic interface 'yintercept' should not be INTRINSIC
   intrinsic sin
   interface yIntercept
     procedure sin
   end interface
-  !ERROR: Specific procedure 'cos' of generic interface 'xintercept' may not be INTRINSIC
+  !PORTABILITY: Specific procedure 'cos' of generic interface 'xintercept' should not be INTRINSIC
   intrinsic cos
   generic :: xIntercept => cos
 end module
 
 subroutine foo
   interface slope
     procedure tan
   end interface
   !ERROR: Specific procedure 'tan' of generic interface 'slope' may not be a statement function
   tan(x) = sin(x) / cos(x)
 end subroutine