diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -295,6 +295,9 @@ 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 diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -1726,12 +1726,25 @@ continue; } if (specific.attrs().test(Attr::INTRINSIC)) { - if (auto *msg{messages_.Say(specific.name(), - "Specific procedure '%s' of generic interface '%s' may not be INTRINSIC"_err_en_US, - specific.name(), generic.name())}) { - msg->Attach(generic.name(), "Definition of '%s'"_en_US, generic.name()); + // 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' should not be INTRINSIC"_port_en_US, + specific.name(), 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; } - continue; } if (IsStmtFunction(specific)) { if (auto *msg{messages_.Say(specific.name(), diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2608,10 +2608,10 @@ 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{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)}, diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -4619,15 +4619,27 @@ Say(symbol.name(), "Symbol '%s' cannot have both EXTERNAL and INTRINSIC attributes"_err_en_US, symbol.name()); - } 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); + } 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; diff --git a/flang/test/Semantics/call16.f90 b/flang/test/Semantics/call16.f90 --- a/flang/test/Semantics/call16.f90 +++ b/flang/test/Semantics/call16.f90 @@ -4,9 +4,9 @@ subroutine test(x, t) intrinsic :: sin, cpu_time - !ERROR: Cannot use intrinsic function 'sin' as a subroutine + !ERROR: Cannot call function 'sin' like a subroutine call sin(x) - !ERROR: Cannot use intrinsic subroutine 'cpu_time' as a function + !ERROR: Cannot call subroutine 'cpu_time' like a function x = cpu_time(t) end subroutine diff --git a/flang/test/Semantics/generic06.f90 b/flang/test/Semantics/generic06.f90 --- a/flang/test/Semantics/generic06.f90 +++ b/flang/test/Semantics/generic06.f90 @@ -1,11 +1,11 @@ ! 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