forked from OSchip/llvm-project
[flang] More fixes; tests now all pass (with updates to some)
Original-commit: flang-compiler/f18@236ff3a3db Reviewed-on: https://github.com/flang-compiler/f18/pull/638 Tree-same-pre-rewrite: false
This commit is contained in:
parent
da6445198a
commit
e071162e04
|
@ -763,6 +763,7 @@ public:
|
|||
const parser::Name &, const parser::InitialDataTarget &);
|
||||
void PointerInitialization(
|
||||
const parser::Name &, const parser::ProcPointerInit &);
|
||||
void CheckExplicitInterface(const parser::Name &);
|
||||
void CheckBindings(const parser::TypeBoundProcedureStmt::WithoutInterface &);
|
||||
|
||||
protected:
|
||||
|
@ -799,8 +800,6 @@ protected:
|
|||
const parser::Name *ResolveName(const parser::Name &);
|
||||
bool PassesSharedLocalityChecks(const parser::Name &name, Symbol &symbol);
|
||||
Symbol *NoteInterfaceName(const parser::Name &);
|
||||
void CheckExplicitInterface(Symbol &);
|
||||
void CheckBinding(Symbol &);
|
||||
|
||||
private:
|
||||
// The attribute corresponding to the statement containing an ObjectDecl
|
||||
|
@ -845,7 +844,6 @@ private:
|
|||
Symbol &DeclareProcEntity(const parser::Name &, Attrs, const ProcInterface &);
|
||||
void SetType(const parser::Name &, const DeclTypeSpec &);
|
||||
const Symbol *ResolveDerivedType(const parser::Name &);
|
||||
bool CanBeTypeBoundProc(const Symbol &);
|
||||
Symbol *MakeTypeSymbol(const SourceName &, Details &&);
|
||||
Symbol *MakeTypeSymbol(const parser::Name &, Details &&);
|
||||
bool OkToAddComponent(const parser::Name &, const Symbol * = nullptr);
|
||||
|
@ -1660,7 +1658,8 @@ void ScopeHandler::PopScope() {
|
|||
// assumed to be objects.
|
||||
// TODO: Statement functions
|
||||
for (auto &pair : currScope()) {
|
||||
ConvertToObjectEntity(*pair.second);
|
||||
Symbol &symbol{*pair.second};
|
||||
ConvertToObjectEntity(symbol);
|
||||
}
|
||||
SetScope(currScope_->parent());
|
||||
}
|
||||
|
@ -3435,13 +3434,21 @@ void DeclarationVisitor::CheckBindings(
|
|||
auto &bindingName{std::get<parser::Name>(declaration.t)};
|
||||
if (Symbol * binding{FindInScope(currScope(), bindingName)}) {
|
||||
if (auto *details{binding->detailsIf<ProcBindingDetails>()}) {
|
||||
const Symbol &procedure{details->symbol().GetUltimate()};
|
||||
const Symbol *procedure{FindSubprogram(details->symbol())};
|
||||
if (!CanBeTypeBoundProc(procedure)) {
|
||||
auto &optName{std::get<std::optional<parser::Name>>(declaration.t)};
|
||||
const parser::Name &procedureName{optName ? *optName : bindingName};
|
||||
SayWithDecl(procedureName, const_cast<Symbol &>(procedure),
|
||||
"'%s' is not a module procedure or external procedure"
|
||||
" with explicit interface"_err_en_US);
|
||||
if (details->symbol().name() != binding->name()) {
|
||||
Say(binding->name(),
|
||||
"The binding of '%s' ('%s') must be either an accessible "
|
||||
"module procedure or an external procedure with "
|
||||
"an explicit interface"_err_en_US,
|
||||
binding->name(), details->symbol().name());
|
||||
} else {
|
||||
Say(binding->name(),
|
||||
"'%s' must be either an accessible module procedure "
|
||||
"or an external procedure with an explicit interface"_err_en_US,
|
||||
binding->name());
|
||||
}
|
||||
context().SetError(*binding);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
@ -4067,55 +4074,23 @@ const Symbol *DeclarationVisitor::ResolveDerivedType(const parser::Name &name) {
|
|||
return symbol;
|
||||
}
|
||||
|
||||
// Check this symbol suitable as a type-bound procedure - C769
|
||||
bool DeclarationVisitor::CanBeTypeBoundProc(const Symbol &symbol) {
|
||||
if (symbol.has<SubprogramNameDetails>()) {
|
||||
return symbol.owner().kind() == Scope::Kind::Module;
|
||||
} else if (auto *details{symbol.detailsIf<SubprogramDetails>()}) {
|
||||
return symbol.owner().kind() == Scope::Kind::Module ||
|
||||
details->isInterface();
|
||||
} else if (auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
|
||||
return !symbol.IsDummy() && !symbol.attrs().test(Attr::POINTER) &&
|
||||
proc->HasExplicitInterface();
|
||||
} else {
|
||||
return false;
|
||||
}
|
||||
}
|
||||
|
||||
Symbol *DeclarationVisitor::NoteInterfaceName(const parser::Name &name) {
|
||||
// The symbol is checked later by CheckExplicitInterface() or
|
||||
// CheckBinding() to ensure that it defines an explicit interface
|
||||
// or binds to a procedure. The name can be a forward reference.
|
||||
// The symbol is checked later by CheckExplicitInterface() and
|
||||
// CheckBindings(). It can be a forward reference.
|
||||
if (!NameIsKnownOrIntrinsic(name)) {
|
||||
Resolve(name, MakeSymbol(InclusiveScope(), name.source, Attrs{}));
|
||||
Symbol &symbol{MakeSymbol(InclusiveScope(), name.source, Attrs{})};
|
||||
Resolve(name, symbol);
|
||||
}
|
||||
return name.symbol;
|
||||
}
|
||||
|
||||
void DeclarationVisitor::CheckExplicitInterface(Symbol &symbol) {
|
||||
if (const Symbol * interface{FindInterface(symbol)}) {
|
||||
const Symbol *subp{FindSubprogram(*interface)};
|
||||
if (subp == nullptr || !subp->HasExplicitInterface()) {
|
||||
Say(symbol.name(),
|
||||
"The interface of '%s' ('%s') is not an abstract interface or a "
|
||||
"procedure with an explicit interface"_err_en_US,
|
||||
symbol.name(), interface->name());
|
||||
context().SetError(symbol);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
void DeclarationVisitor::CheckBinding(Symbol &symbol) {
|
||||
if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
|
||||
const Symbol &binding{details->symbol()};
|
||||
const Symbol *subp{FindSubprogram(binding)};
|
||||
if (subp == nullptr || !subp->HasExplicitInterface() || IsDummy(*subp) ||
|
||||
IsProcedurePointer(*subp)) {
|
||||
Say(symbol.name(),
|
||||
"The binding of '%s' ('%s') is not a "
|
||||
"procedure with an explicit interface"_err_en_US,
|
||||
symbol.name(), binding.name());
|
||||
context().SetError(symbol);
|
||||
void DeclarationVisitor::CheckExplicitInterface(const parser::Name &name) {
|
||||
if (const Symbol * symbol{name.symbol}) {
|
||||
if (!symbol->HasExplicitInterface()) {
|
||||
Say(name,
|
||||
"'%s' must be an abstract interface or a procedure with "
|
||||
"an explicit interface"_err_en_US,
|
||||
symbol->name());
|
||||
}
|
||||
}
|
||||
}
|
||||
|
@ -4764,11 +4739,6 @@ const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
|
|||
}
|
||||
return &name;
|
||||
}
|
||||
// TODO pmk: if in a variable or component initialization with deferred
|
||||
// semantic analysis, just MakeSymbol() for now and don't apply any
|
||||
// implicit typing rules. Then do object conversion and implicit
|
||||
// typing (or not) in DeferredInitializationHelper (taking Pointer
|
||||
// out of the name). Still not sure how to deal with PDT components.
|
||||
if (isImplicitNoneType()) {
|
||||
Say(name, "No explicit type declared for '%s'"_err_en_US);
|
||||
return nullptr;
|
||||
|
@ -5027,7 +4997,7 @@ void DeclarationVisitor::PointerInitialization(
|
|||
details.set_init(*targetName->symbol);
|
||||
}
|
||||
} else {
|
||||
details.set_init(nullptr); // NULL()
|
||||
details.set_init(nullptr); // explicit NULL()
|
||||
}
|
||||
} else {
|
||||
Say(name,
|
||||
|
@ -5074,9 +5044,7 @@ void ResolveNamesVisitor::HandleProcedureName(
|
|||
}
|
||||
MakeExternal(*symbol);
|
||||
}
|
||||
if (!symbol->has<ProcEntityDetails>()) {
|
||||
ConvertToProcEntity(*symbol);
|
||||
}
|
||||
SetProcFlag(name, *symbol, flag);
|
||||
} else if (symbol->has<UnknownDetails>()) {
|
||||
CHECK(!"unexpected UnknownDetails");
|
||||
|
@ -5525,12 +5493,13 @@ bool ResolveNamesVisitor::BeginScope(const ProgramTree &node) {
|
|||
}
|
||||
}
|
||||
|
||||
// The processing of initializers of pointers is deferred until all of
|
||||
// the pertinent specification parts have been visited. This deferred
|
||||
// processing enables the use of forward references in those initializers.
|
||||
class DeferredPointerInitializationVisitor {
|
||||
// Some analyses and checks, such as the processing of initializers of
|
||||
// pointers, is deferred until all of the pertinent specification parts
|
||||
// have been visited. This deferred processing enables the use of forward
|
||||
// references in these circumstances.
|
||||
class DeferredCheckVisitor {
|
||||
public:
|
||||
explicit DeferredPointerInitializationVisitor(ResolveNamesVisitor &resolver)
|
||||
explicit DeferredCheckVisitor(ResolveNamesVisitor &resolver)
|
||||
: resolver_{resolver} {}
|
||||
|
||||
template<typename A> void Walk(const A &x) { parser::Walk(x, *this); }
|
||||
|
@ -5539,7 +5508,7 @@ public:
|
|||
template<typename A> void Post(const A &) {}
|
||||
|
||||
void Post(const parser::DerivedTypeStmt &x) {
|
||||
auto &name{std::get<parser::Name>(x.t)};
|
||||
const auto &name{std::get<parser::Name>(x.t)};
|
||||
if (Symbol * symbol{name.symbol}) {
|
||||
if (Scope * scope{symbol->scope()}) {
|
||||
if (scope->kind() == Scope::Kind::DerivedType) {
|
||||
|
@ -5556,6 +5525,11 @@ public:
|
|||
}
|
||||
}
|
||||
|
||||
void Post(const parser::ProcInterface &pi) {
|
||||
if (const auto *name{std::get_if<parser::Name>(&pi.u)}) {
|
||||
resolver_.CheckExplicitInterface(*name);
|
||||
}
|
||||
}
|
||||
bool Pre(const parser::EntityDecl &decl) {
|
||||
Init(std::get<parser::Name>(decl.t),
|
||||
std::get<std::optional<parser::Initialization>>(decl.t));
|
||||
|
@ -5573,6 +5547,9 @@ public:
|
|||
}
|
||||
return false;
|
||||
}
|
||||
void Post(const parser::TypeBoundProcedureStmt::WithInterface &tbps) {
|
||||
resolver_.CheckExplicitInterface(tbps.interfaceName);
|
||||
}
|
||||
void Post(const parser::TypeBoundProcedureStmt::WithoutInterface &tbps) {
|
||||
if (pushedScope_) {
|
||||
resolver_.CheckBindings(tbps);
|
||||
|
@ -5605,14 +5582,12 @@ void ResolveNamesVisitor::FinishSpecificationParts(const ProgramTree &node) {
|
|||
// type-bound procedure bindings have not yet been traversed.
|
||||
// We do that now, when any (formerly) forward references that appear
|
||||
// in those initializers will resolve to the right symbols.
|
||||
DeferredPointerInitializationVisitor{*this}.Walk(node.spec());
|
||||
DeferredPointerInitializationVisitor{*this}.Walk(node.exec()); // for BLOCK
|
||||
DeferredCheckVisitor{*this}.Walk(node.spec());
|
||||
DeferredCheckVisitor{*this}.Walk(node.exec()); // for BLOCK
|
||||
for (auto &pair : currScope()) {
|
||||
Symbol &symbol{*pair.second};
|
||||
if (const auto *details{symbol.detailsIf<GenericDetails>()}) {
|
||||
CheckSpecificsAreDistinguishable(symbol, details->specificProcs());
|
||||
} else if (symbol.has<ProcEntityDetails>()) {
|
||||
CheckExplicitInterface(symbol);
|
||||
}
|
||||
}
|
||||
// Finish the definitions of derived types and parameterized derived
|
||||
|
@ -5643,7 +5618,7 @@ static int FindIndexOfName(
|
|||
return -1;
|
||||
}
|
||||
|
||||
// Perform checks on procedure bindings of this type
|
||||
// Perform final checks on a derived type and set the pass arguments.
|
||||
void ResolveNamesVisitor::FinishDerivedTypeDefinition(Scope &scope) {
|
||||
CHECK(scope.IsDerivedType() && scope.symbol());
|
||||
for (auto &pair : scope) {
|
||||
|
@ -5652,12 +5627,8 @@ void ResolveNamesVisitor::FinishDerivedTypeDefinition(Scope &scope) {
|
|||
common::visitors{
|
||||
[&](ProcEntityDetails &x) {
|
||||
SetPassArg(comp, x.interface().symbol(), x);
|
||||
CheckExplicitInterface(comp);
|
||||
},
|
||||
[&](ProcBindingDetails &x) {
|
||||
SetPassArg(comp, &x.symbol(), x);
|
||||
CheckBinding(comp);
|
||||
},
|
||||
[&](ProcBindingDetails &x) { SetPassArg(comp, &x.symbol(), x); },
|
||||
[](auto &) {},
|
||||
},
|
||||
comp.details());
|
||||
|
|
|
@ -216,7 +216,7 @@ void Scope::add_importName(const SourceName &name) {
|
|||
|
||||
// true if name can be imported or host-associated from parent scope.
|
||||
bool Scope::CanImport(const SourceName &name) const {
|
||||
if (IsGlobal()) {
|
||||
if (IsGlobal() || parent_.IsGlobal()) {
|
||||
return false;
|
||||
}
|
||||
switch (GetImportKind()) {
|
||||
|
|
|
@ -418,6 +418,23 @@ bool IsSaved(const Symbol &symbol) {
|
|||
}
|
||||
}
|
||||
|
||||
// Check this symbol suitable as a type-bound procedure - C769
|
||||
bool CanBeTypeBoundProc(const Symbol *symbol) {
|
||||
if (symbol == nullptr || IsDummy(*symbol) || IsProcedurePointer(*symbol)) {
|
||||
return false;
|
||||
} else if (symbol->has<SubprogramNameDetails>()) {
|
||||
return symbol->owner().kind() == Scope::Kind::Module;
|
||||
} else if (auto *details{symbol->detailsIf<SubprogramDetails>()}) {
|
||||
return symbol->owner().kind() == Scope::Kind::Module ||
|
||||
details->isInterface();
|
||||
} else if (const auto *proc{symbol->detailsIf<ProcEntityDetails>()}) {
|
||||
return !symbol->attrs().test(Attr::INTRINSIC) &&
|
||||
proc->HasExplicitInterface();
|
||||
} else {
|
||||
return false;
|
||||
}
|
||||
}
|
||||
|
||||
bool IsFinalizable(const Symbol &symbol) {
|
||||
if (const DeclTypeSpec * type{symbol.GetType()}) {
|
||||
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
|
||||
|
|
|
@ -84,6 +84,7 @@ const Symbol *HasEventOrLockPotentialComponent(const DerivedTypeSpec &);
|
|||
bool IsOrContainsEventOrLockComponent(const Symbol &);
|
||||
// Has an explicit or implied SAVE attribute
|
||||
bool IsSaved(const Symbol &);
|
||||
bool CanBeTypeBoundProc(const Symbol *);
|
||||
|
||||
// Return an ultimate component of type that matches predicate, or nullptr.
|
||||
const Symbol *FindUltimateComponent(
|
||||
|
|
|
@ -119,6 +119,12 @@ end function
|
|||
|
||||
program test_typeless
|
||||
class(*), allocatable :: x
|
||||
interface
|
||||
subroutine sub
|
||||
end subroutine
|
||||
real function func()
|
||||
end function
|
||||
end interface
|
||||
procedure (sub), pointer :: subp => sub
|
||||
procedure (func), pointer :: funcp => func
|
||||
|
||||
|
|
|
@ -25,12 +25,6 @@
|
|||
! C1120 -- DO variable (and associated expressions) must be INTEGER.
|
||||
! This is extended by allowing REAL and DOUBLE PRECISION
|
||||
|
||||
SUBROUTINE sub()
|
||||
END SUBROUTINE sub
|
||||
|
||||
FUNCTION ifunc()
|
||||
END FUNCTION ifunc
|
||||
|
||||
MODULE share
|
||||
INTEGER :: intvarshare
|
||||
REAL :: realvarshare
|
||||
|
@ -56,6 +50,12 @@ PROGRAM do_issue_458
|
|||
REAL, POINTER :: prvar
|
||||
DOUBLE PRECISION, POINTER :: pdvar
|
||||
LOGICAL, POINTER :: plvar
|
||||
INTERFACE
|
||||
SUBROUTINE sub()
|
||||
END SUBROUTINE sub
|
||||
FUNCTION ifunc()
|
||||
END FUNCTION ifunc
|
||||
END INTERFACE
|
||||
PROCEDURE(ifunc), POINTER :: pifunc => NULL()
|
||||
|
||||
! DO variables
|
||||
|
|
|
@ -22,20 +22,20 @@ module m
|
|||
procedure(integer) :: b
|
||||
procedure(foo) :: c
|
||||
procedure(bar) :: d
|
||||
!ERROR: The interface of 'e' ('missing') is not an abstract interface or a procedure with an explicit interface
|
||||
!ERROR: 'missing' must be an abstract interface or a procedure with an explicit interface
|
||||
procedure(missing) :: e
|
||||
!ERROR: The interface of 'f' ('b') is not an abstract interface or a procedure with an explicit interface
|
||||
!ERROR: 'b' must be an abstract interface or a procedure with an explicit interface
|
||||
procedure(b) :: f
|
||||
procedure(c) :: g
|
||||
external :: h
|
||||
!ERROR: The interface of 'i' ('h') is not an abstract interface or a procedure with an explicit interface
|
||||
!ERROR: 'h' must be an abstract interface or a procedure with an explicit interface
|
||||
procedure(h) :: i
|
||||
procedure(forward) :: j
|
||||
!ERROR: The interface of 'k1' ('bad1') is not an abstract interface or a procedure with an explicit interface
|
||||
!ERROR: 'bad1' must be an abstract interface or a procedure with an explicit interface
|
||||
procedure(bad1) :: k1
|
||||
!ERROR: The interface of 'k2' ('bad2') is not an abstract interface or a procedure with an explicit interface
|
||||
!ERROR: 'bad2' must be an abstract interface or a procedure with an explicit interface
|
||||
procedure(bad2) :: k2
|
||||
!ERROR: The interface of 'k3' ('bad3') is not an abstract interface or a procedure with an explicit interface
|
||||
!ERROR: 'bad3' must be an abstract interface or a procedure with an explicit interface
|
||||
procedure(bad3) :: k3
|
||||
|
||||
abstract interface
|
||||
|
|
|
@ -35,21 +35,21 @@ module m
|
|||
type t1
|
||||
integer :: c
|
||||
contains
|
||||
!ERROR: Procedure 'missing' not found
|
||||
!ERROR: The binding of 'a' ('missing') must be either an accessible module procedure or an external procedure with an explicit interface
|
||||
procedure, nopass :: a => missing
|
||||
procedure, nopass :: b => s, s2
|
||||
!ERROR: 'c' is not a module procedure or external procedure with explicit interface
|
||||
!ERROR: Type parameter, component, or procedure binding 'c' already defined in this type
|
||||
procedure, nopass :: c
|
||||
!ERROR: DEFERRED is only allowed when an interface-name is provided
|
||||
procedure, nopass, deferred :: d => s
|
||||
!Note: s3 not found because it's not accessible -- should we issue a message
|
||||
!to that effect?
|
||||
!ERROR: Procedure 's3' not found
|
||||
!ERROR: 's3' must be either an accessible module procedure or an external procedure with an explicit interface
|
||||
procedure, nopass :: s3
|
||||
procedure, nopass :: foo
|
||||
!ERROR: 'bar' is not a module procedure or external procedure with explicit interface
|
||||
!ERROR: 'bar' must be either an accessible module procedure or an external procedure with an explicit interface
|
||||
procedure, nopass :: bar
|
||||
!ERROR: 'i' is not a module procedure or external procedure with explicit interface
|
||||
!ERROR: 'i' must be either an accessible module procedure or an external procedure with an explicit interface
|
||||
procedure, nopass :: i
|
||||
!ERROR: Type parameter, component, or procedure binding 'b' already defined in this type
|
||||
procedure, nopass :: b => s4
|
||||
|
@ -59,7 +59,7 @@ module m
|
|||
procedure(foo), nopass, deferred :: f
|
||||
!ERROR: DEFERRED is required when an interface-name is provided
|
||||
procedure(foo), nopass :: g
|
||||
!ERROR: The interface of 'h' ('bar') is not an abstract interface or a procedure with an explicit interface
|
||||
!ERROR: 'bar' must be an abstract interface or a procedure with an explicit interface
|
||||
procedure(bar), nopass, deferred :: h
|
||||
end type
|
||||
type t2
|
||||
|
|
Loading…
Reference in New Issue