diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -205,3 +205,12 @@ * We respect Fortran comments in macro actual arguments (like GNU, Intel, NAG; unlike PGI and XLF) on the principle that macro calls should be treated like function references. Fortran's line continuation methods also work. + +## Standard features not silently accepted + +* Fortran explicitly ignores type declaration statements when they + attempt to type the name of a generic intrinsic function (8.2 p3). + One can declare `CHARACTER::COS` and still get a real result + from `COS(3.14159)`, for example. f18 will complain when a + generic intrinsic function's inferred result type does not + match an explicit declaration. This message is a warning. diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -154,6 +154,7 @@ // called by Fold() to rewrite in place TypeAndShape &Rewrite(FoldingContext &); + std::string AsFortran() const; llvm::raw_ostream &Dump(llvm::raw_ostream &) const; private: diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -371,7 +371,7 @@ std::optional GetCalleeAndArguments( const parser::ProcedureDesignator &, ActualArguments &&, bool isSubroutine, bool mightBeStructureConstructor = false); - + void CheckBadExplicitType(const SpecificCall &, const Symbol &); void CheckForBadRecursion(parser::CharBlock, const semantics::Symbol &); bool EnforceTypeConstraint(parser::CharBlock, const MaybeExpr &, TypeCategory, bool defaultKind = false); diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -155,11 +155,9 @@ bool isElemental, bool thisIsDeferredShape, bool thatIsDeferredShape) const { if (!type_.IsTkCompatibleWith(that.type_)) { - const auto &len{that.LEN()}; messages.Say( "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US, - thatIs, that.type_.AsFortran(len ? len->AsFortran() : ""), thisIs, - type_.AsFortran(LEN_ ? LEN_->AsFortran() : "")); + thatIs, that.AsFortran(), thisIs, AsFortran()); return false; } return isElemental || @@ -235,6 +233,10 @@ } } +std::string TypeAndShape::AsFortran() const { + return type_.AsFortran(LEN_ ? LEN_->AsFortran() : ""); +} + llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const { o << type_.AsFortran(LEN_ ? LEN_->AsFortran() : ""); attrs_.Dump(o, EnumToString); 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 @@ -2044,6 +2044,7 @@ if (std::optional specificCall{context_.intrinsics().Probe( CallCharacteristics{ultimate.name().ToString(), isSubroutine}, arguments, GetFoldingContext())}) { + CheckBadExplicitType(*specificCall, *symbol); return CalleeAndArguments{ ProcedureDesignator{std::move(specificCall->specificIntrinsic)}, std::move(specificCall->arguments)}; @@ -2081,6 +2082,39 @@ return std::nullopt; } +// Fortran 2018 expressly states (8.2 p3) that any declared type for a +// generic intrinsic function "has no effect" on the result type of a +// call to that intrinsic. So one can declare "character*8 cos" and +// still get a real result from "cos(1.)". This is a dangerous feature, +// especially since implementations are free to extend their sets of +// intrinsics, and in doing so might clash with a name in a program. +// So we emit a warning in this situation, and perhaps it should be an +// error -- any correctly working program can silence the message by +// simply deleting the pointless type declaration. +void ExpressionAnalyzer::CheckBadExplicitType( + const SpecificCall &call, const Symbol &intrinsic) { + if (intrinsic.GetUltimate().GetType()) { + const auto &procedure{call.specificIntrinsic.characteristics.value()}; + if (const auto &result{procedure.functionResult}) { + if (const auto *typeAndShape{result->GetTypeAndShape()}) { + if (auto declared{ + typeAndShape->Characterize(intrinsic, GetFoldingContext())}) { + if (!declared->type().IsTkCompatibleWith(typeAndShape->type())) { + if (auto *msg{Say( + "The result type '%s' of the intrinsic function '%s' is not the explicit declared type '%s'"_en_US, + typeAndShape->AsFortran(), intrinsic.name(), + declared->AsFortran())}) { + msg->Attach(intrinsic.name(), + "Ignored declaration of intrinsic function '%s'"_en_US, + intrinsic.name()); + } + } + } + } + } + } +} + void ExpressionAnalyzer::CheckForBadRecursion( parser::CharBlock callSite, const semantics::Symbol &proc) { if (const auto *scope{proc.scope()}) { 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 @@ -3461,14 +3461,23 @@ bool DeclarationVisitor::Pre(const parser::IntrinsicStmt &x) { HandleAttributeStmt(Attr::INTRINSIC, x.v); for (const auto &name : x.v) { - auto *symbol{FindSymbol(name)}; - if (!ConvertToProcEntity(*symbol)) { + auto &symbol{DEREF(FindSymbol(name))}; + 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(), + 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()); + 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'"_en_US, + symbol.name()) + .Attach(name.source, + "INTRINSIC statement for explicitly-typed '%s'"_en_US, + name.source); } } return false; @@ -5971,9 +5980,7 @@ bool convertedToProcEntity{ConvertToProcEntity(*symbol)}; if (convertedToProcEntity && !symbol->attrs().test(Attr::EXTERNAL) && IsIntrinsic(symbol->name(), flag) && !IsDummy(*symbol)) { - symbol->attrs().set(Attr::INTRINSIC); - // 8.2(3): ignore type from intrinsic in type-declaration-stmt - symbol->get().set_interface(ProcInterface{}); + AcquireIntrinsicProcedureFlags(*symbol); } if (!SetProcFlag(name, *symbol, flag)) { return; // reported error diff --git a/flang/test/Semantics/badly-typed-intrinsic.f90 b/flang/test/Semantics/badly-typed-intrinsic.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/badly-typed-intrinsic.f90 @@ -0,0 +1,29 @@ +! RUN: %f18 -fsyntax-only %s 2>&1 | FileCheck %s + +type :: t +end type +integer :: acos +double precision :: cos +!CHECK: Explicit type declaration ignored for intrinsic function 'int' +complex :: int +character :: sin +logical :: asin +type(t) :: atan +!CHECK: INTRINSIC statement for explicitly-typed 'int' +intrinsic int +!CHECK: The result type 'REAL(4)' of the intrinsic function 'acos' is not the explicit declared type 'INTEGER(4)' +!CHECK: Ignored declaration of intrinsic function 'acos' +print *, acos(0.) +!CHECK: The result type 'REAL(4)' of the intrinsic function 'cos' is not the explicit declared type 'REAL(8)' +!CHECK: Ignored declaration of intrinsic function 'cos' +print *, cos(0.) +!CHECK: The result type 'REAL(4)' of the intrinsic function 'sin' is not the explicit declared type 'CHARACTER(KIND=1,LEN=1_8)' +!CHECK: Ignored declaration of intrinsic function 'sin' +print *, sin(0.) +!CHECK: The result type 'REAL(4)' of the intrinsic function 'asin' is not the explicit declared type 'LOGICAL(4)' +!CHECK: Ignored declaration of intrinsic function 'asin' +print *, asin(0.) +!CHECK: The result type 'REAL(4)' of the intrinsic function 'atan' is not the explicit declared type 't' +!CHECK: Ignored declaration of intrinsic function 'atan' +print *, atan(0.) +end diff --git a/flang/test/Semantics/symbol18.f90 b/flang/test/Semantics/symbol18.f90 --- a/flang/test/Semantics/symbol18.f90 +++ b/flang/test/Semantics/symbol18.f90 @@ -4,7 +4,7 @@ !DEF: /p1 MainProgram program p1 - !DEF: /p1/cos INTRINSIC (Function) ProcEntity + !DEF: /p1/cos ELEMENTAL, INTRINSIC, PURE (Function) ProcEntity INTEGER(4) integer cos !DEF: /p1/y (Implicit) ObjectEntity REAL(4) !REF: /p1/cos