public:
using AttrsVisitor::Post;
using AttrsVisitor::Pre;
- void BeginDeclTypeSpec();
- void EndDeclTypeSpec();
bool Pre(const parser::IntegerTypeSpec &);
bool Pre(const parser::IntrinsicTypeSpec::Logical &);
bool Pre(const parser::IntrinsicTypeSpec::Real &);
void Post(const parser::ProcedureDeclarationStmt &);
protected:
- std::unique_ptr<DeclTypeSpec> declTypeSpec_;
+ std::unique_ptr<DeclTypeSpec> &GetDeclTypeSpec();
+ void BeginDeclTypeSpec();
+ void EndDeclTypeSpec();
+
std::unique_ptr<DerivedTypeSpec> derivedTypeSpec_;
std::unique_ptr<ParamValue> typeParamValue_;
private:
bool expectDeclTypeSpec_{false}; // should only see decl-type-spec when true
+ std::unique_ptr<DeclTypeSpec> declTypeSpec_;
void MakeIntrinsic(const IntrinsicTypeSpec &intrinsicTypeSpec);
void SetDeclTypeSpec(const DeclTypeSpec &declTypeSpec);
static KindParamValue GetKindParamValue(
// Function result name from parser::Suffix, if any.
const parser::Name *funcResultName_{nullptr};
- bool BeginSubprogram(const parser::Name &,
+ bool BeginSubprogram(const parser::Name &, Symbol::Flag,
const std::optional<parser::InternalSubprogramPart> &);
void EndSubprogram();
// Create a subprogram symbol in the current scope and push a new scope.
- Symbol &PushSubprogramScope(const parser::Name &);
+ Symbol &PushSubprogramScope(const parser::Name &, Symbol::Flag);
Symbol *GetSpecificFromGeneric(const parser::Name &);
};
}
void Post(const parser::TargetStmt &) { objectDeclAttr_ = std::nullopt; }
void Post(const parser::DimensionStmt::Declaration &);
+ bool Pre(const parser::TypeDeclarationStmt &) { return BeginDecl(); }
+ void Post(const parser::TypeDeclarationStmt &) { EndDecl(); }
+ bool Pre(const parser::DerivedTypeDef &x);
+ void Post(const parser::DerivedTypeDef &x);
+ bool Pre(const parser::DerivedTypeStmt &x);
+ void Post(const parser::DerivedTypeStmt &x);
+ bool Pre(const parser::TypeAttrSpec::Extends &x);
+ bool Pre(const parser::PrivateStmt &x);
+ bool Pre(const parser::SequenceStmt &x);
+ bool Pre(const parser::ComponentDefStmt &) { return BeginDecl(); }
+ void Post(const parser::ComponentDefStmt &) { EndDecl(); }
+ void Post(const parser::ComponentDecl &x);
+ bool Pre(const parser::ProcedureDeclarationStmt &);
+ void Post(const parser::ProcedureDeclarationStmt &);
+ bool Pre(const parser::ProcComponentDefStmt &);
+ void Post(const parser::ProcComponentDefStmt &);
+ void Post(const parser::ProcInterface &x);
+ void Post(const parser::ProcDecl &x);
+ bool Pre(const parser::FinalProcedureStmt &x);
protected:
bool BeginDecl();
private:
// The attribute corresponding to the statement containing an ObjectDecl
std::optional<Attr> objectDeclAttr_;
+ // In a DerivedTypeDef, this is data collected for it
+ std::unique_ptr<DerivedTypeDef::Data> derivedTypeData_;
+ // In a ProcedureDeclarationStmt or ProcComponentDefStmt, this is
+ // the interface name, if any.
+ const SourceName *interfaceName_{nullptr};
// Handle a statement that sets an attribute on a list of names.
bool HandleAttributeStmt(Attr, const std::list<parser::Name> &);
- void DeclareEntity(const parser::Name &, Attrs);
+ void DeclareObjectEntity(const parser::Name &, Attrs);
+ void DeclareProcEntity(const parser::Name &, Attrs, ProcInterface &&);
+
+ // Set the type of an entity or report an error.
+ void SetType(const SourceName &name, Symbol &symbol, const DeclTypeSpec &type);
+
+ // Declare an object or procedure entity.
+ template<typename T>
+ Symbol &DeclareEntity(const parser::Name &name, Attrs attrs) {
+ Symbol &symbol{MakeSymbol(name.source, attrs)};
+ if (symbol.has<UnknownDetails>()) {
+ symbol.set_details(T{});
+ } else if (auto *details = symbol.detailsIf<EntityDetails>()) {
+ if (!std::is_same<EntityDetails, T>::value) {
+ symbol.set_details(T(*details));
+ }
+ }
+ if (T *details = symbol.detailsIf<T>()) {
+ // OK
+ } else if (std::is_same<EntityDetails, T>::value &&
+ (symbol.has<ObjectEntityDetails>() ||
+ symbol.has<ProcEntityDetails>())) {
+ // OK
+ } else if (UseDetails *details = symbol.detailsIf<UseDetails>()) {
+ Say(name.source,
+ "'%s' is use-associated from module '%s' and cannot be re-declared"_err_en_US,
+ name.source, details->module().name());
+ } else if (auto *details = symbol.detailsIf<SubprogramNameDetails>()) {
+ if (details->kind() == SubprogramKind::Module) {
+ Say2(name.source,
+ "Declaration of '%s' conflicts with its use as module procedure"_err_en_US,
+ symbol.name(), "Module procedure definition"_en_US);
+ } else if (details->kind() == SubprogramKind::Internal) {
+ Say2(name.source,
+ "Declaration of '%s' conflicts with its use as internal procedure"_err_en_US,
+ symbol.name(), "Internal procedure definition"_en_US);
+ } else {
+ CHECK(!"unexpected kind");
+ }
+ } else {
+ SayAlreadyDeclared(name.source, symbol);
+ }
+ return symbol;
+ }
+
};
// Walk the parse tree and resolve names to symbols.
void Post(const parser::CommonBlockObject &);
bool Pre(const parser::TypeParamDefStmt &);
void Post(const parser::TypeParamDefStmt &);
- bool Pre(const parser::DataComponentDefStmt &) { return BeginDecl(); }
- void Post(const parser::DataComponentDefStmt &) { EndDecl(); }
bool Pre(const parser::TypeDeclarationStmt &) { return BeginDecl(); }
void Post(const parser::TypeDeclarationStmt &) { EndDecl(); }
void Post(const parser::ComponentDecl &);
}
void Post(const parser::ProcedureDesignator &);
+ bool Pre(const parser::FunctionReference &);
+ void Post(const parser::FunctionReference &);
+ bool Pre(const parser::CallStmt &);
+ void Post(const parser::CallStmt &);
private:
+ // Kind of procedure we are expecting to see in a ProcedureDesignator
+ std::optional<Symbol::Flag> expectedProcFlag_;
+
const parser::Name *GetVariableName(const parser::DataRef &);
const parser::Name *GetVariableName(const parser::Designator &);
const parser::Name *GetVariableName(const parser::Expr &);
// DeclTypeSpecVisitor implementation
+std::unique_ptr<DeclTypeSpec> &DeclTypeSpecVisitor::GetDeclTypeSpec() {
+ return declTypeSpec_;
+}
void DeclTypeSpecVisitor::BeginDeclTypeSpec() {
CHECK(!expectDeclTypeSpec_);
expectDeclTypeSpec_ = true;
bool DeclTypeSpecVisitor::Pre(const parser::TypeParamValue &x) {
typeParamValue_ = std::make_unique<ParamValue>(std::visit(
parser::visitors{
- [&](const parser::ScalarIntExpr &x) { return Bound{IntExpr{x}}; },
+ //TODO: create IntExpr from ScalarIntExpr
+ [&](const parser::ScalarIntExpr &x) { return Bound{IntExpr{}}; },
[&](const parser::Star &x) { return Bound::ASSUMED; },
[&](const parser::TypeParamValue::Deferred &x) {
return Bound::DEFERRED;
return false;
}
}
- implicitRules().SetType(*declTypeSpec_.get(), loLoc, hiLoc);
+ implicitRules().SetType(*GetDeclTypeSpec(), loLoc, hiLoc);
return false;
}
}
Bound ArraySpecVisitor::GetBound(const parser::SpecificationExpr &x) {
- return Bound(IntExpr(x.v));
+ return Bound(IntExpr{}); // TODO: convert x.v to IntExpr
}
// ScopeHandler implementation
for (auto &pair : CurrScope()) {
Symbol &symbol = pair.second;
if (symbol.has<UnknownDetails>()) {
- symbol.set_details(EntityDetails());
+ symbol.set_details(ObjectEntityDetails{});
+ } else if (auto *details = symbol.detailsIf<EntityDetails>()) {
+ symbol.set_details(ObjectEntityDetails{*details});
}
- if (auto *details = symbol.detailsIf<EntityDetails>()) {
+ if (auto *details = symbol.detailsIf<ObjectEntityDetails>()) {
if (!details->type()) {
const auto &name = pair.first;
if (const auto *type = implicitRules().GetType(name.begin()[0])) {
}
Symbol &localSymbol{MakeSymbol(localName, useSymbol.attrs())};
localSymbol.attrs() &= ~Attrs{Attr::PUBLIC, Attr::PRIVATE};
+ localSymbol.flags() |= useSymbol.flags();
if (auto *details = localSymbol.detailsIf<UseDetails>()) {
// check for importing the same symbol again:
if (localSymbol.GetUltimate() != useSymbol.GetUltimate()) {
void InterfaceVisitor::Post(const parser::GenericStmt &x) {
if (auto &accessSpec = std::get<std::optional<parser::AccessSpec>>(x.t)) {
- genericSymbol_->attrs() |= Attrs{AccessSpecToAttr(*accessSpec)};
+ genericSymbol_->attrs().set(AccessSpecToAttr(*accessSpec));
}
for (const auto &name : std::get<std::list<parser::Name>>(x.t)) {
AddToGeneric(name);
// Look up name: provides return type or tells us if it's an array
if (auto *symbol = FindSymbol(name.source)) {
if (auto *details = symbol->detailsIf<EntityDetails>()) {
- if (details->isArray()) {
- // not a stmt-func at all but an array; do nothing
- symbol->add_occurrence(name.source);
- badStmtFuncFound_ = true;
- return true;
- }
// TODO: check that attrs are compatible with stmt func
resultType = details->type();
occurrence = symbol->name();
EraseSymbol(symbol->name());
+ } else if (symbol->has<ObjectEntityDetails>()) {
+ // not a stmt-func at all but an array; do nothing
+ symbol->add_occurrence(name.source);
+ badStmtFuncFound_ = true;
+ return true;
}
}
if (badStmtFuncFound_) {
Say(name, "'%s' has not been declared as an array"_err_en_US);
return true;
}
- auto &symbol = PushSubprogramScope(name);
+ auto &symbol = PushSubprogramScope(name, Symbol::Flag::Function);
CopyImplicitRules();
if (occurrence) {
symbol.add_occurrence(*occurrence);
std::get<parser::Statement<parser::SubroutineStmt>>(x.t).statement.t);
const auto &subpPart =
std::get<std::optional<parser::InternalSubprogramPart>>(x.t);
- return BeginSubprogram(name, subpPart);
+ return BeginSubprogram(name, Symbol::Flag::Subroutine, subpPart);
}
void SubprogramVisitor::Post(const parser::SubroutineSubprogram &) {
EndSubprogram();
std::get<parser::Statement<parser::FunctionStmt>>(x.t).statement.t);
const auto &subpPart =
std::get<std::optional<parser::InternalSubprogramPart>>(x.t);
- return BeginSubprogram(name, subpPart);
+ return BeginSubprogram(name, Symbol::Flag::Function, subpPart);
}
void SubprogramVisitor::Post(const parser::FunctionSubprogram &) {
EndSubprogram();
bool SubprogramVisitor::Pre(const parser::InterfaceBody::Subroutine &x) {
const auto &name = std::get<parser::Name>(
std::get<parser::Statement<parser::SubroutineStmt>>(x.t).statement.t);
- return BeginSubprogram(name, std::nullopt);
+ return BeginSubprogram(name, Symbol::Flag::Subroutine, std::nullopt);
}
void SubprogramVisitor::Post(const parser::InterfaceBody::Subroutine &) {
EndSubprogram();
bool SubprogramVisitor::Pre(const parser::InterfaceBody::Function &x) {
const auto &name = std::get<parser::Name>(
std::get<parser::Statement<parser::FunctionStmt>>(x.t).statement.t);
- return BeginSubprogram(name, std::nullopt);
+ return BeginSubprogram(name, Symbol::Flag::Function, std::nullopt);
}
void SubprogramVisitor::Post(const parser::InterfaceBody::Function &) {
EndSubprogram();
}
// add function result to function scope
EntityDetails funcResultDetails;
- if (declTypeSpec_) {
- funcResultDetails.set_type(*declTypeSpec_);
+ if (auto &type = GetDeclTypeSpec()) {
+ funcResultDetails.set_type(*type);
}
EndDeclTypeSpec();
}
bool SubprogramVisitor::BeginSubprogram(const parser::Name &name,
+ Symbol::Flag subpFlag,
const std::optional<parser::InternalSubprogramPart> &subpPart) {
if (subpNamesOnly_) {
- MakeSymbol(name, SubprogramNameDetails{*subpNamesOnly_});
+ auto &symbol = MakeSymbol(name, SubprogramNameDetails{*subpNamesOnly_});
+ symbol.set(subpFlag);
return false;
}
- PushSubprogramScope(name);
+ PushSubprogramScope(name, subpFlag);
if (subpPart) {
subpNamesOnly_ = SubprogramKind::Internal;
parser::Walk(*subpPart, *static_cast<ResolveNamesVisitor *>(this));
}
}
-Symbol &SubprogramVisitor::PushSubprogramScope(const parser::Name &name) {
+Symbol &SubprogramVisitor::PushSubprogramScope(
+ const parser::Name &name, Symbol::Flag subpFlag) {
Symbol *symbol = GetSpecificFromGeneric(name);
if (!symbol) {
symbol = &MakeSymbol(name, SubprogramDetails{});
+ symbol->set(subpFlag);
}
auto &details = symbol->details<SubprogramDetails>();
if (inInterfaceBlock()) {
Scope &subpScope = CurrScope().MakeScope(Scope::Kind::Subprogram, symbol);
PushScope(subpScope);
// can't reuse this name inside subprogram:
- MakeSymbol(name, SubprogramDetails(details));
+ MakeSymbol(name, SubprogramDetails(details)).set(subpFlag);
return *symbol;
}
void DeclarationVisitor::Post(const parser::DimensionStmt::Declaration &x) {
const auto &name = std::get<parser::Name>(x.t);
- DeclareEntity(name, Attrs{});
+ DeclareObjectEntity(name, Attrs{});
}
void DeclarationVisitor::Post(const parser::EntityDecl &x) {
// TODO: may be under StructureStmt
const auto &name{std::get<parser::ObjectName>(x.t)};
// TODO: CoarraySpec, CharLength, Initialization
- DeclareEntity(name, attrs_ ? *attrs_ : Attrs());
+ Attrs attrs{attrs_ ? *attrs_ : Attrs{}};
+ if (!arraySpec().empty()) {
+ DeclareObjectEntity(name, attrs);
+ } else {
+ Symbol &symbol{DeclareEntity<EntityDetails>(name, attrs)};
+ if (auto &type = GetDeclTypeSpec()) {
+ SetType(name.source, symbol, *type);
+ }
+ }
}
bool DeclarationVisitor::Pre(const parser::AsynchronousStmt &x) {
return HandleAttributeStmt(Attr::CONTIGUOUS, x.v);
}
bool DeclarationVisitor::Pre(const parser::ExternalStmt &x) {
- return HandleAttributeStmt(Attr::EXTERNAL, x.v);
+ HandleAttributeStmt(Attr::EXTERNAL, x.v);
+ for (const auto &name : x.v) {
+ auto *symbol = FindSymbol(name.source);
+ if (symbol->has<ProcEntityDetails>()) {
+ // nothing to do
+ } else if (symbol->has<UnknownDetails>()) {
+ symbol->set_details(ProcEntityDetails{});
+ } else if (auto *details = symbol->detailsIf<EntityDetails>()) {
+ symbol->set_details(ProcEntityDetails(*details));
+ symbol->set(Symbol::Flag::Function);
+ } else {
+ Say2(name.source,
+ "EXTERNAL attribute not allowed on '%s'"_err_en_US,
+ symbol->name(), "Declaration of '%s'"_en_US);
+ }
+ }
+ return false;
}
bool DeclarationVisitor::Pre(const parser::IntrinsicStmt &x) {
return HandleAttributeStmt(Attr::INTRINSIC, x.v);
void DeclarationVisitor::Post(const parser::ObjectDecl &x) {
CHECK(objectDeclAttr_.has_value());
const auto &name = std::get<parser::ObjectName>(x.t);
- DeclareEntity(name, Attrs{*objectDeclAttr_});
+ DeclareObjectEntity(name, Attrs{*objectDeclAttr_});
+}
+
+void DeclarationVisitor::DeclareProcEntity(
+ const parser::Name &name, Attrs attrs, ProcInterface &&interface) {
+ Symbol &symbol{DeclareEntity<ProcEntityDetails>(name, attrs)};
+ if (auto *details = symbol.detailsIf<ProcEntityDetails>()) {
+ if (interface.type()) {
+ symbol.set(Symbol::Flag::Function);
+ } else if (interface.symbol()) {
+ symbol.set(interface.symbol()->test(Symbol::Flag::Function)
+ ? Symbol::Flag::Function
+ : Symbol::Flag::Subroutine);
+ }
+ details->set_interface(std::move(interface));
+ symbol.attrs().set(Attr::EXTERNAL);
+ }
}
-void DeclarationVisitor::DeclareEntity(const parser::Name &name, Attrs attrs) {
- Symbol &symbol{MakeSymbol(name.source, attrs)};
- // TODO: check attribute consistency
- if (symbol.has<UnknownDetails>()) {
- symbol.set_details(EntityDetails());
- }
- if (EntityDetails *details = symbol.detailsIf<EntityDetails>()) {
- if (declTypeSpec_) {
+void DeclarationVisitor::DeclareObjectEntity(
+ const parser::Name &name, Attrs attrs) {
+ Symbol &symbol{DeclareEntity<ObjectEntityDetails>(name, attrs)};
+ if (auto *details = symbol.detailsIf<ObjectEntityDetails>()) {
+ if (auto &type = GetDeclTypeSpec()) {
if (details->type().has_value()) {
Say(name, "The type of '%s' has already been declared"_err_en_US);
} else {
- details->set_type(*declTypeSpec_);
+ details->set_type(*type);
}
}
if (!arraySpec().empty()) {
}
ClearArraySpec();
}
- } else if (UseDetails *details = symbol.detailsIf<UseDetails>()) {
- Say(name.source,
- "'%s' is use-associated from module '%s' and cannot be re-declared"_err_en_US,
- name.source, details->module().name());
- } else if (auto *details = symbol.detailsIf<SubprogramNameDetails>()) {
- if (details->kind() == SubprogramKind::Module) {
- Say2(name.source,
- "Declaration of '%s' conflicts with its use as module procedure"_err_en_US,
- symbol.name(), "Module procedure definition"_en_US);
- } else if (details->kind() == SubprogramKind::Internal) {
- Say2(name.source,
- "Declaration of '%s' conflicts with its use as internal procedure"_err_en_US,
- symbol.name(), "Internal procedure definition"_en_US);
+ }
+}
+
+bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) {
+ CHECK(!derivedTypeData_);
+ derivedTypeData_ = std::make_unique<DerivedTypeDef::Data>();
+ return true;
+}
+void DeclarationVisitor::Post(const parser::DerivedTypeDef &x) {
+ DerivedTypeDef derivedType{*derivedTypeData_};
+ //TODO: do something with derivedType
+ derivedTypeData_.reset();
+}
+bool DeclarationVisitor::Pre(const parser::DerivedTypeStmt &x) {
+ derivedTypeData_->name = std::get<parser::Name>(x.t).source;
+ BeginAttrs();
+ return true;
+}
+void DeclarationVisitor::Post(const parser::DerivedTypeStmt &x) {
+ derivedTypeData_->attrs = GetAttrs();
+ EndAttrs();
+}
+bool DeclarationVisitor::Pre(const parser::TypeAttrSpec::Extends &x) {
+ derivedTypeData_->extends = x.v.source;
+ return false;
+}
+bool DeclarationVisitor::Pre(const parser::PrivateStmt &x) {
+ derivedTypeData_->Private = true;
+ return false;
+}
+bool DeclarationVisitor::Pre(const parser::SequenceStmt &x) {
+ derivedTypeData_->sequence = true;
+ return false;
+}
+void DeclarationVisitor::Post(const parser::ComponentDecl &x) {
+ const auto &name = std::get<parser::Name>(x.t).source;
+ derivedTypeData_->dataComps.emplace_back(
+ *GetDeclTypeSpec(), name, GetAttrs(), arraySpec());
+ ClearArraySpec();
+}
+bool DeclarationVisitor::Pre(const parser::ProcedureDeclarationStmt &) {
+ CHECK(!interfaceName_);
+ return BeginDecl();
+}
+void DeclarationVisitor::Post(const parser::ProcedureDeclarationStmt &) {
+ interfaceName_ = nullptr;
+ EndDecl();
+}
+bool DeclarationVisitor::Pre(const parser::ProcComponentDefStmt &) {
+ CHECK(!interfaceName_);
+ return true;
+}
+void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &) {
+ interfaceName_ = nullptr;
+}
+void DeclarationVisitor::Post(const parser::ProcInterface &x) {
+ if (auto *name = std::get_if<parser::Name>(&x.u)) {
+ interfaceName_ = &name->source;
+ }
+}
+
+void DeclarationVisitor::Post(const parser::ProcDecl &x) {
+ const auto &name = std::get<parser::Name>(x.t);
+ ProcInterface interface;
+ if (interfaceName_) {
+ auto *symbol = FindSymbol(*interfaceName_);
+ if (!symbol) {
+ Say(*interfaceName_, "Explicit interface '%s' not found"_err_en_US);
+ } else if (!symbol->HasExplicitInterface()) {
+ Say2(*interfaceName_,
+ "'%s' is not an abstract interface or a procedure with an explicit interface"_err_en_US,
+ symbol->name(), "Declaration of '%s'"_en_US);
} else {
- CHECK(!"unexpected kind");
+ interface = *symbol;
+ }
+ } else if (auto &type = GetDeclTypeSpec()) {
+ interface = *type;
+ }
+ if (derivedTypeData_) {
+ derivedTypeData_->procComps.emplace_back(
+ ProcDecl{name.source}, GetAttrs(), std::move(interface));
+ } else {
+ DeclareProcEntity(name, GetAttrs(), std::move(interface));
+ }
+}
+
+bool DeclarationVisitor::Pre(const parser::FinalProcedureStmt &x) {
+ for (const parser::Name &name : x.v) {
+ derivedTypeData_->finalProcs.push_back(name.source);
+ }
+ return false;
+}
+
+void DeclarationVisitor::SetType(
+ const SourceName &name, Symbol &symbol, const DeclTypeSpec &type) {
+ if (auto *details = symbol.detailsIf<EntityDetails>()) {
+ if (!details->type().has_value()) {
+ details->set_type(type);
+ return;
+ }
+ } else if (auto *details = symbol.detailsIf<ObjectEntityDetails>()) {
+ if (!details->type().has_value()) {
+ details->set_type(type);
+ return;
+ }
+ } else if (auto *details = symbol.detailsIf<ProcEntityDetails>()) {
+ if (!details->interface().type()) {
+ details->interface() = type;
+ return;
}
} else {
- SayAlreadyDeclared(name.source, symbol);
+ return;
}
+ Say(name, "The type of '%s' has already been declared"_err_en_US);
}
// ResolveNamesVisitor implementation
return true; // TODO
}
+bool ResolveNamesVisitor::Pre(const parser::FunctionReference &) {
+ expectedProcFlag_ = Symbol::Flag::Function;
+ return true;
+}
+void ResolveNamesVisitor::Post(const parser::FunctionReference &) {
+ expectedProcFlag_ = std::nullopt;
+}
+bool ResolveNamesVisitor::Pre(const parser::CallStmt &) {
+ expectedProcFlag_ = Symbol::Flag::Subroutine;
+ return true;
+}
+void ResolveNamesVisitor::Post(const parser::CallStmt &) {
+ expectedProcFlag_ = std::nullopt;
+}
+
bool ResolveNamesVisitor::CheckUseError(
const SourceName &name, const Symbol &symbol) {
const auto *details = symbol.detailsIf<UseErrorDetails>();
" attribute in a scope with IMPLICIT NONE(EXTERNAL)"_err_en_US);
}
symbol.attrs().set(Attr::EXTERNAL);
- symbol.set_details(SubprogramDetails{});
+ symbol.set_details(ProcEntityDetails{});
+ CHECK(expectedProcFlag_);
+ symbol.set(*expectedProcFlag_);
} else if (CheckUseError(name->source, symbol)) {
// error was reported
- } else if (!symbol.isSubprogram()) {
- auto *details = symbol.detailsIf<EntityDetails>();
- if (!details || !details->isArray()) {
+ } else {
+ if (auto *details = symbol.detailsIf<EntityDetails>()) {
+ symbol.set_details(ProcEntityDetails(*details));
+ symbol.set(Symbol::Flag::Function);
+ }
+ if (symbol.test(Symbol::Flag::Function) &&
+ expectedProcFlag_ == Symbol::Flag::Subroutine) {
+ Say2(name->source,
+ "Cannot call function '%s' like a subroutine"_err_en_US,
+ symbol.name(), "Declaration of '%s'"_en_US);
+ } else if (symbol.test(Symbol::Flag::Subroutine) &&
+ expectedProcFlag_ == Symbol::Flag::Function) {
+ Say2(name->source,
+ "Cannot call subroutine '%s' like a function"_err_en_US,
+ symbol.name(), "Declaration of '%s'"_en_US);
+ } else if (symbol.detailsIf<ProcEntityDetails>()) {
+ symbol.set(*expectedProcFlag_); // in case it hasn't been set yet
+ } else {
Say2(name->source,
"Use of '%s' as a procedure conflicts with its declaration"_err_en_US,
symbol.name(), "Declaration of '%s'"_en_US);
}
}
+static bool HasExplicitType(const Symbol &symbol) {
+ if (symbol.has<UnknownDetails>()) {
+ return false;
+ } else if (const auto *details = symbol.detailsIf<EntityDetails>()) {
+ return details->type().has_value();
+ } else if (const auto *details = symbol.detailsIf<ObjectEntityDetails>()) {
+ return details->type().has_value();
+ } else if (const auto *details = symbol.detailsIf<ProcEntityDetails>()) {
+ return details->interface().symbol() != nullptr ||
+ details->interface().type() != nullptr;
+ } else {
+ return true; // doesn't need explicit type
+ }
+}
+
void ResolveNamesVisitor::Post(const parser::SpecificationPart &s) {
badStmtFuncFound_ = false;
if (isImplicitNoneType()) {
for (const auto &pair : CurrScope()) {
const auto &name = pair.first;
const auto &symbol = pair.second;
- if (symbol.has<UnknownDetails>()) {
+ if (!HasExplicitType(symbol)) {
Say(name, "No explicit type declared for '%s'"_err_en_US);
- } else if (const auto *details = symbol.detailsIf<EntityDetails>()) {
- if (!details->type()) {
- Say(name, "No explicit type declared for '%s'"_err_en_US);
- }
}
}
}
void ResolveNamesVisitor::Post(const parser::Program &) {
// ensure that all temps were deallocated
CHECK(!attrs_);
- CHECK(!declTypeSpec_);
+ CHECK(!GetDeclTypeSpec());
}
void ResolveNames(
type_ = type;
}
-void EntityDetails::set_shape(const ArraySpec &shape) {
+void ObjectEntityDetails::set_type(const DeclTypeSpec &type) {
+ CHECK(!type_);
+ type_ = type;
+}
+
+void ObjectEntityDetails::set_shape(const ArraySpec &shape) {
CHECK(shape_.empty());
for (const auto &shapeSpec : shape) {
shape_.push_back(shapeSpec);
}
}
+ProcEntityDetails::ProcEntityDetails(const EntityDetails &d) {
+ if (auto &type = d.type()) {
+ interface_ = *type;
+ }
+}
+
const Symbol &UseDetails::module() const {
// owner is a module so it must have a symbol:
return *symbol_->owner().symbol();
[](const SubprogramDetails &) { return "Subprogram"; },
[](const SubprogramNameDetails &) { return "SubprogramName"; },
[](const EntityDetails &) { return "Entity"; },
+ [](const ObjectEntityDetails &) { return "ObjectEntity"; },
+ [](const ProcEntityDetails &) { return "ProcEntity"; },
[](const UseDetails &) { return "Use"; },
[](const UseErrorDetails &) { return "UseError"; },
[](const GenericDetails &) { return "Generic"; },
bool Symbol::CanReplaceDetails(const Details &details) const {
if (has<UnknownDetails>()) {
return true; // can always replace UnknownDetails
- } else if (std::holds_alternative<UseErrorDetails>(details)) {
- return true; // can replace any with UseErrorDetails
- } else if (has<SubprogramNameDetails>() &&
- std::holds_alternative<SubprogramDetails>(details)) {
- return true; // can replace SubprogramNameDetails with SubprogramDetails
} else {
- return false;
+ return std::visit(
+ parser::visitors{
+ [](const UseErrorDetails &) { return true; },
+ [=](const ObjectEntityDetails &) { return has<EntityDetails>(); },
+ [=](const ProcEntityDetails &) { return has<EntityDetails>(); },
+ [=](const SubprogramDetails &) {
+ return has<SubprogramNameDetails>();
+ },
+ [](const auto &) { return false; },
+ },
+ details);
}
}
bool Symbol::isSubprogram() const {
return std::visit(
parser::visitors{
- [&](const SubprogramDetails &) { return true; },
- [&](const SubprogramNameDetails &) { return true; },
- [&](const GenericDetails &) { return true; },
- [&](const UseDetails &x) { return x.symbol().isSubprogram(); },
- [&](const auto &) { return false; },
+ [](const SubprogramDetails &) { return true; },
+ [](const SubprogramNameDetails &) { return true; },
+ [](const GenericDetails &) { return true; },
+ [](const UseDetails &x) { return x.symbol().isSubprogram(); },
+ [](const auto &) { return false; },
},
details_);
}
+bool Symbol::HasExplicitInterface() const {
+ return std::visit(
+ parser::visitors{
+ [](const SubprogramDetails &) { return true; },
+ [](const SubprogramNameDetails &) { return true; },
+ [](const ProcEntityDetails &x) { return x.HasExplicitInterface(); },
+ [](const UseDetails &x) { return x.symbol().HasExplicitInterface(); },
+ [](const auto &) { return false; },
+ },
+ details_);
+}
+
+ObjectEntityDetails::ObjectEntityDetails(const EntityDetails &d)
+ : isDummy_{d.isDummy()} {
+ if (auto &type = d.type()) {
+ set_type(*type);
+ }
+}
+
std::ostream &operator<<(std::ostream &os, const EntityDetails &x) {
if (x.type()) {
os << " type: " << *x.type();
}
+ return os;
+}
+
+std::ostream &operator<<(std::ostream &os, const ObjectEntityDetails &x) {
+ if (x.type()) {
+ os << " type: " << *x.type();
+ }
if (!x.shape().empty()) {
os << " shape:";
for (const auto &s : x.shape()) {
return os;
}
+bool ProcEntityDetails::HasExplicitInterface() const {
+ if (auto *symbol = interface_.symbol()) {
+ return symbol->HasExplicitInterface();
+ }
+ return false;
+}
+
+std::ostream &operator<<(std::ostream &os, const ProcEntityDetails &x) {
+ if (auto *symbol = x.interface_.symbol()) {
+ os << ' ' << symbol->name().ToString();
+ } else if (auto *type = x.interface_.type()) {
+ os << ' ' << *type;
+ }
+ return os;
+}
+
+
static std::ostream &DumpType(std::ostream &os, const Symbol &symbol) {
if (const auto *details = symbol.detailsIf<EntityDetails>()) {
if (details->type()) {
os << ' ' << EnumToString(x.kind());
},
[&](const EntityDetails &x) { os << x; },
+ [&](const ObjectEntityDetails &x) { os << x; },
+ [&](const ProcEntityDetails &x) { os << x; },
[&](const UseDetails &x) {
os << " from " << x.symbol().name() << " in " << x.module().name();
},
return os;
}
+std::ostream &operator<<(std::ostream &o, Symbol::Flag flag) {
+ return o << Symbol::EnumToString(flag);
+}
+
+std::ostream &operator<<(std::ostream &o, const Symbol::Flags &flags) {
+ std::size_t n{flags.count()};
+ std::size_t seen{0};
+ for (std::size_t j{0}; seen < n; ++j) {
+ Symbol::Flag flag{static_cast<Symbol::Flag>(j)};
+ if (flags.test(flag)) {
+ if (seen++ > 0) {
+ o << ", ";
+ }
+ o << flag;
+ }
+ }
+ return o;
+}
+
std::ostream &operator<<(std::ostream &os, const Symbol &symbol) {
os << symbol.name();
if (!symbol.attrs().empty()) {
os << ", " << symbol.attrs();
}
+ if (!symbol.flags().empty()) {
+ os << " (" << symbol.flags() << ')';
+ }
os << ": " << symbol.details_;
return os;
}
SubprogramKind kind_;
};
+// A name from an entity-decl -- could be object or function.
class EntityDetails {
public:
EntityDetails(bool isDummy = false) : isDummy_{isDummy} {}
const std::optional<DeclTypeSpec> &type() const { return type_; }
void set_type(const DeclTypeSpec &type);
+ bool isDummy() const { return isDummy_; }
+
+private:
+ bool isDummy_;
+ std::optional<DeclTypeSpec> type_;
+ friend std::ostream &operator<<(std::ostream &, const EntityDetails &);
+};
+
+// An entity known to be an object.
+class ObjectEntityDetails {
+public:
+ ObjectEntityDetails(const EntityDetails &);
+ ObjectEntityDetails(bool isDummy = false) : isDummy_{isDummy} {}
+ const std::optional<DeclTypeSpec> &type() const { return type_; }
+ void set_type(const DeclTypeSpec &type);
const ArraySpec &shape() const { return shape_; }
void set_shape(const ArraySpec &shape);
bool isDummy() const { return isDummy_; }
bool isDummy_;
std::optional<DeclTypeSpec> type_;
ArraySpec shape_;
- friend std::ostream &operator<<(std::ostream &, const EntityDetails &);
+ friend std::ostream &operator<<(std::ostream &, const ObjectEntityDetails &);
+};
+
+// A procedure pointer, dummy procedure, or external procedure
+class ProcEntityDetails {
+public:
+ ProcEntityDetails() = default;
+ ProcEntityDetails(const EntityDetails &d);
+
+ const ProcInterface &interface() const { return interface_; }
+ ProcInterface &interface() { return interface_; }
+ void set_interface(ProcInterface &&interface) { interface_ = std::move(interface); }
+ bool HasExplicitInterface() const;
+
+private:
+ ProcInterface interface_;
+ friend std::ostream &operator<<(std::ostream &, const ProcEntityDetails &);
};
// Record the USE of a symbol: location is where (USE statement or renaming);
class UnknownDetails {};
using Details = std::variant<UnknownDetails, MainProgramDetails, ModuleDetails,
- SubprogramDetails, SubprogramNameDetails, EntityDetails, UseDetails,
- UseErrorDetails, GenericDetails>;
+ SubprogramDetails, SubprogramNameDetails, EntityDetails,
+ ObjectEntityDetails, ProcEntityDetails, UseDetails, UseErrorDetails,
+ GenericDetails>;
std::ostream &operator<<(std::ostream &, const Details &);
class Symbol {
public:
+ ENUM_CLASS(Flag, Function, Subroutine);
+ using Flags = EnumSet<Flag, Flag_enumSize>;
+
Symbol(const Scope &owner, const SourceName &name, const Attrs &attrs,
Details &&details)
: owner_{owner}, attrs_{attrs}, details_{std::move(details)} {
const SourceName &name() const { return occurrences_.front(); }
Attrs &attrs() { return attrs_; }
const Attrs &attrs() const { return attrs_; }
+ Flags &flags() { return flags_; }
+ const Flags &flags() const { return flags_; }
+ bool test(Flag flag) const { return flags_.test(flag); }
+ void set(Flag flag, bool value = true) { flags_.set(flag, value); }
// Does symbol have this type of details?
template<typename D> bool has() const {
const Symbol &GetUltimate() const;
bool isSubprogram() const;
+ bool HasExplicitInterface() const;
bool operator==(const Symbol &that) const { return this == &that; }
bool operator!=(const Symbol &that) const { return this != &that; }
const Scope &owner_;
std::list<SourceName> occurrences_;
Attrs attrs_;
+ Flags flags_;
Details details_;
const std::string GetDetailsName() const;
friend std::ostream &operator<<(std::ostream &, const Symbol &);
};
+std::ostream &operator<<(std::ostream &, Symbol::Flag);
+
} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_SYMBOL_H_
#include "type.h"
#include "attr.h"
+#include "symbol.h"
#include <iostream>
#include <set>
if (!x.data_.attrs.empty()) {
o << ", " << x.data_.attrs;
}
- o << " :: " << x.data_.name;
+ o << " :: " << x.data_.name.ToString();
if (x.data_.lenParams.size() > 0 || x.data_.kindParams.size() > 0) {
o << '(';
int n = 0;
for (const auto &comp : x.data_.procComps) {
o << " " << comp << "\n";
}
+ if (x.data_.hasTbpPart()) {
+ o << "CONTAINS\n";
+ if (x.data_.bindingPrivate) {
+ o << " PRIVATE\n";
+ }
+ for (const auto &tbp : x.data_.typeBoundProcs) {
+ o << " " << tbp << "\n";
+ }
+ for (const auto &tbg : x.data_.typeBoundGenerics) {
+ o << " " << tbg << "\n";
+ }
+ for (const auto &name : x.data_.finalProcs) {
+ o << " FINAL :: " << name.ToString() << '\n';
+ }
+ }
return o << "END TYPE";
}
if (!x.attrs_.empty()) {
o << ", " << x.attrs_;
}
- o << " :: " << x.name_;
+ o << " :: " << x.name_.ToString();
if (!x.arraySpec_.empty()) {
o << '(';
int n = 0;
return o;
}
-DataComponentDef::DataComponentDef(const DeclTypeSpec &type, const Name &name,
- const Attrs &attrs, const ArraySpec &arraySpec)
+DataComponentDef::DataComponentDef(const DeclTypeSpec &type,
+ const SourceName &name, const Attrs &attrs, const ArraySpec &arraySpec)
: type_{type}, name_{name}, attrs_{attrs}, arraySpec_{arraySpec} {
attrs.CheckValid({Attr::PUBLIC, Attr::PRIVATE, Attr::ALLOCATABLE,
Attr::POINTER, Attr::CONTIGUOUS});
}
std::ostream &operator<<(std::ostream &o, const ProcDecl &x) {
- return o << x.name_;
+ return o << x.name_.ToString();
}
-ProcComponentDef::ProcComponentDef(ProcDecl decl, Attrs attrs,
- const std::optional<Name> &interfaceName,
- const std::optional<DeclTypeSpec> &typeSpec)
- : decl_{decl}, attrs_{attrs}, interfaceName_{interfaceName}, typeSpec_{
- typeSpec} {
+ProcComponentDef::ProcComponentDef(
+ const ProcDecl &decl, Attrs attrs, ProcInterface &&interface)
+ : decl_{decl}, attrs_{attrs}, interface_{std::move(interface)} {
CHECK(attrs_.test(Attr::POINTER));
attrs_.CheckValid(
{Attr::PUBLIC, Attr::PRIVATE, Attr::NOPASS, Attr::POINTER, Attr::PASS});
- CHECK(!interfaceName || !typeSpec); // can't both be defined
}
std::ostream &operator<<(std::ostream &o, const ProcComponentDef &x) {
o << "PROCEDURE(";
- if (x.interfaceName_) {
- o << *x.interfaceName_;
- } else if (x.typeSpec_) {
- o << *x.typeSpec_;
+ if (auto *symbol = x.interface_.symbol()) {
+ o << symbol->name().ToString();
+ } else if (auto *type = x.interface_.type()) {
+ o << *type;
}
o << "), " << x.attrs_ << " :: " << x.decl_;
return o;
}
}
-DerivedTypeDef::DerivedTypeDef(const DerivedTypeDef::Data &data)
- : data_{data} {}
-
-DerivedTypeDefBuilder &DerivedTypeDefBuilder::name(const Name &x) {
- data_.name = x;
- return *this;
-}
-DerivedTypeDefBuilder &DerivedTypeDefBuilder::extends(const Name &x) {
- data_.extends = x;
- return *this;
-}
-DerivedTypeDefBuilder &DerivedTypeDefBuilder::attr(const Attr &x) {
- // TODO: x.CheckValid({Attr::ABSTRACT, Attr::PUBLIC, Attr::PRIVATE,
- // Attr::BIND_C});
- data_.attrs.set(x);
- return *this;
-}
-DerivedTypeDefBuilder &DerivedTypeDefBuilder::attrs(const Attrs &x) {
- x.CheckValid({Attr::ABSTRACT, Attr::PUBLIC, Attr::PRIVATE, Attr::BIND_C});
- data_.attrs |= x;
- return *this;
-}
-DerivedTypeDefBuilder &DerivedTypeDefBuilder::lenParam(const TypeParamDef &x) {
- data_.lenParams.push_back(x);
- return *this;
-}
-DerivedTypeDefBuilder &DerivedTypeDefBuilder::kindParam(const TypeParamDef &x) {
- data_.kindParams.push_back(x);
- return *this;
-}
-DerivedTypeDefBuilder &DerivedTypeDefBuilder::dataComponent(
- const DataComponentDef &x) {
- data_.dataComps.push_back(x);
- return *this;
-}
-DerivedTypeDefBuilder &DerivedTypeDefBuilder::procComponent(
- const ProcComponentDef &x) {
- data_.procComps.push_back(x);
- return *this;
-}
-DerivedTypeDefBuilder &DerivedTypeDefBuilder::Private(bool x) {
- data_.Private = x;
- return *this;
+std::ostream &operator<<(std::ostream &o, const TypeBoundProc &x) {
+ o << "PROCEDURE(";
+ if (x.interface_) {
+ o << x.interface_->ToString();
+ }
+ o << ")";
+ if (!x.attrs_.empty()) {
+ o << ", " << x.attrs_;
+ }
+ o << " :: " << x.binding_.ToString();
+ if (x.procedure_ != x.binding_) {
+ o << " => " << x.procedure_.ToString();
+ }
+ return o;
}
-DerivedTypeDefBuilder &DerivedTypeDefBuilder::sequence(bool x) {
- data_.sequence = x;
- return *this;
+std::ostream &operator<<(std::ostream &o, const TypeBoundGeneric &x) {
+ o << "GENERIC ";
+ if (!x.attrs_.empty()) {
+ o << ", " << x.attrs_;
+ }
+ o << " :: " << x.genericSpec_ << " => " << x.name_.ToString();
+ return o;
}
+DerivedTypeDef::DerivedTypeDef(const DerivedTypeDef::Data &data)
+ : data_{data} {}
+
} // namespace Fortran::semantics
#define FORTRAN_SEMANTICS_TYPE_H_
#include "attr.h"
+#include "../parser/char-block.h"
#include "../parser/idioms.h"
-#include "../parser/parse-tree.h"
#include <list>
#include <map>
#include <memory>
return IntExpr(); // TODO
}
IntExpr() {}
- IntExpr(const parser::ScalarIntExpr &) { /*TODO*/
- }
virtual std::ostream &Output(std::ostream &o) const { return o << "IntExpr"; }
};
// TODO: coarray-spec
// TODO: component-initialization
DataComponentDef(
- const DeclTypeSpec &type, const Name &name, const Attrs &attrs)
+ const DeclTypeSpec &type, const SourceName &name, const Attrs &attrs)
: DataComponentDef(type, name, attrs, ArraySpec{}) {}
- DataComponentDef(const DeclTypeSpec &type, const Name &name,
+ DataComponentDef(const DeclTypeSpec &type, const SourceName &name,
const Attrs &attrs, const ArraySpec &arraySpec);
const DeclTypeSpec &type() const { return type_; }
- const Name &name() const { return name_; }
+ const SourceName &name() const { return name_; }
const Attrs &attrs() const { return attrs_; }
const ArraySpec &shape() const { return arraySpec_; }
private:
const DeclTypeSpec type_;
- const Name name_;
+ const SourceName name_;
const Attrs attrs_;
const ArraySpec arraySpec_;
friend std::ostream &operator<<(std::ostream &, const DataComponentDef &);
};
+class Symbol;
+
+// This represents a proc-interface in the declaration of a procedure or
+// procedure component. It comprises a symbol (representing the specific
+// interface), a decl-type-spec (representing the function return type),
+// or neither.
+class ProcInterface {
+public:
+ ProcInterface() = default;
+ ProcInterface(ProcInterface &&that)
+ : symbol_{that.symbol_}, type_{std::move(that.type_)} {}
+ ProcInterface(const ProcInterface &that) : symbol_{that.symbol_} {
+ if (that.type_) {
+ *this = *that.type_;
+ }
+ }
+ ProcInterface &operator=(ProcInterface &&that) {
+ symbol_ = that.symbol_;
+ type_ = std::move(that.type_);
+ return *this;
+ }
+ ProcInterface &operator=(const Symbol &symbol) {
+ CHECK(!type_);
+ symbol_ = &symbol;
+ return *this;
+ }
+ ProcInterface &operator=(const DeclTypeSpec &type) {
+ CHECK(!symbol_);
+ type_ = std::make_unique<DeclTypeSpec>(type);
+ return *this;
+ }
+ const Symbol *symbol() const { return symbol_; }
+ const DeclTypeSpec *type() const { return type_.get(); }
+
+private:
+ const Symbol *symbol_{nullptr};
+ std::unique_ptr<const DeclTypeSpec> type_;
+};
+
class ProcDecl {
public:
- ProcDecl(const Name &name) : name_{name} {}
+ ProcDecl(const ProcDecl &decl) = default;
+ ProcDecl(const SourceName &name) : name_{name} {}
// TODO: proc-pointer-init
- const Name &name() const { return name_; }
+ const SourceName &name() const { return name_; }
private:
- const Name name_;
+ const SourceName name_;
friend std::ostream &operator<<(std::ostream &, const ProcDecl &);
};
class ProcComponentDef {
public:
- ProcComponentDef(ProcDecl decl, Attrs attrs)
- : ProcComponentDef(decl, attrs, std::nullopt, std::nullopt) {}
- ProcComponentDef(ProcDecl decl, Attrs attrs, const Name &interfaceName)
- : ProcComponentDef(decl, attrs, interfaceName, std::nullopt) {}
- ProcComponentDef(ProcDecl decl, Attrs attrs, const DeclTypeSpec &typeSpec)
- : ProcComponentDef(decl, attrs, std::nullopt, typeSpec) {}
+ ProcComponentDef(const ProcDecl &decl, Attrs attrs, ProcInterface &&interface);
const ProcDecl &decl() const { return decl_; }
const Attrs &attrs() const { return attrs_; }
- const std::optional<Name> &interfaceName() const { return interfaceName_; }
- const std::optional<DeclTypeSpec> &typeSpec() const { return typeSpec_; }
+ const ProcInterface &interface() const { return interface_; }
private:
- ProcComponentDef(ProcDecl decl, Attrs attrs,
- const std::optional<Name> &interfaceName,
- const std::optional<DeclTypeSpec> &typeSpec);
const ProcDecl decl_;
const Attrs attrs_;
- const std::optional<Name> interfaceName_;
- const std::optional<DeclTypeSpec> typeSpec_;
+ const ProcInterface interface_;
friend std::ostream &operator<<(std::ostream &, const ProcComponentDef &);
};
friend std::ostream &operator<<(std::ostream &, const GenericSpec &);
};
-class DerivedTypeDefBuilder;
+class TypeBoundGeneric {
+public:
+ TypeBoundGeneric(const SourceName &name, const Attrs &attrs,
+ const GenericSpec &genericSpec)
+ : name_{name}, attrs_{attrs}, genericSpec_{genericSpec} {
+ attrs_.CheckValid({Attr::PUBLIC, Attr::PRIVATE});
+ }
+
+private:
+ const SourceName name_;
+ const Attrs attrs_;
+ const GenericSpec genericSpec_;
+ friend std::ostream &operator<<(std::ostream &, const TypeBoundGeneric &);
+};
+
+class TypeBoundProc {
+public:
+ TypeBoundProc(const SourceName &interface, const Attrs &attrs,
+ const SourceName &binding)
+ : TypeBoundProc(interface, attrs, binding, binding) {
+ if (!attrs_.test(Attr::DEFERRED)) {
+ parser::die(
+ "DEFERRED attribute is required if interface name is specified");
+ }
+ }
+ TypeBoundProc(const Attrs &attrs, const SourceName &binding,
+ const std::optional<SourceName> &procedure)
+ : TypeBoundProc({}, attrs, binding, procedure ? *procedure : binding) {
+ if (attrs_.test(Attr::DEFERRED)) {
+ parser::die("DEFERRED attribute is only allowed with interface name");
+ }
+ }
+
+private:
+ TypeBoundProc(const std::optional<SourceName> &interface, const Attrs &attrs,
+ const SourceName &binding, const SourceName &procedure)
+ : interface_{interface}, attrs_{attrs}, binding_{binding}, procedure_{
+ procedure} {
+ attrs_.CheckValid({Attr::PUBLIC, Attr::PRIVATE, Attr::NOPASS, Attr::PASS,
+ Attr::DEFERRED, Attr::NON_OVERRIDABLE});
+ }
+ const std::optional<SourceName> interface_;
+ const Attrs attrs_;
+ const SourceName binding_;
+ const SourceName procedure_;
+ friend std::ostream &operator<<(std::ostream &, const TypeBoundProc &);
+};
// Definition of a derived type
class DerivedTypeDef {
public:
- const Name &name() const { return data_.name; }
- const std::optional<Name> &extends() const { return data_.extends; }
+ const SourceName &name() const { return data_.name; }
+ const std::optional<SourceName> &extends() const { return data_.extends; }
const Attrs &attrs() const { return data_.attrs; }
const TypeParamDefs &lenParams() const { return data_.lenParams; }
const TypeParamDefs &kindParams() const { return data_.kindParams; }
const std::list<ProcComponentDef> &procComponents() const {
return data_.procComps;
}
+ const std::list<TypeBoundProc> &typeBoundProcs() const {
+ return data_.typeBoundProcs;
+ }
+ const std::list<TypeBoundGeneric> &typeBoundGenerics() const {
+ return data_.typeBoundGenerics;
+ }
+ const std::list<SourceName> finalProcs() const { return data_.finalProcs; }
-private:
struct Data {
- Name name;
- std::optional<Name> extends;
+ SourceName name;
+ std::optional<SourceName> extends;
Attrs attrs;
bool Private{false};
bool sequence{false};
TypeParamDefs kindParams;
std::list<DataComponentDef> dataComps;
std::list<ProcComponentDef> procComps;
+ bool bindingPrivate{false};
+ std::list<TypeBoundProc> typeBoundProcs;
+ std::list<TypeBoundGeneric> typeBoundGenerics;
+ std::list<SourceName> finalProcs;
+ bool hasTbpPart() const {
+ return !finalProcs.empty() || !typeBoundProcs.empty() ||
+ !typeBoundGenerics.empty();
+ }
};
- friend class DerivedTypeDefBuilder;
explicit DerivedTypeDef(const Data &x);
+private:
const Data data_;
// TODO: type-bound procedures
friend std::ostream &operator<<(std::ostream &, const DerivedTypeDef &);
};
-class DerivedTypeDefBuilder {
-public:
- DerivedTypeDefBuilder(const Name &name) { data_.name = name; }
- DerivedTypeDefBuilder() {}
- operator DerivedTypeDef() const { return DerivedTypeDef(data_); }
- DerivedTypeDefBuilder &name(const Name &x);
- DerivedTypeDefBuilder &extends(const Name &x);
- DerivedTypeDefBuilder &attr(const Attr &x);
- DerivedTypeDefBuilder &attrs(const Attrs &x);
- DerivedTypeDefBuilder &lenParam(const TypeParamDef &x);
- DerivedTypeDefBuilder &kindParam(const TypeParamDef &x);
- DerivedTypeDefBuilder &dataComponent(const DataComponentDef &x);
- DerivedTypeDefBuilder &procComponent(const ProcComponentDef &x);
- DerivedTypeDefBuilder &Private(bool x = true);
- DerivedTypeDefBuilder &sequence(bool x = true);
-
-private:
- DerivedTypeDef::Data data_;
- friend class DerivedTypeDef;
-};
-
using ParamValue = LenParamValue;
// Instantiation of a DerivedTypeDef with kind and len parameter values
! limitations under the License.
integer :: y
-call x
-!ERROR: Use of 'y' as a procedure conflicts with its declaration
+procedure() :: a
+procedure(real) :: b
+call a ! OK - can be function or subroutine
+!ERROR: Cannot call subroutine 'a' like a function
+c = a()
+!ERROR: Cannot call function 'b' like a subroutine
+call b
+!ERROR: Cannot call function 'y' like a subroutine
call y
+call x
+!ERROR: Cannot call subroutine 'x' like a function
+z = x()
+end
+
+subroutine s
+ !ERROR: Cannot call function 'f' like a subroutine
+ call f
+ !ERROR: Cannot call subroutine 's' like a function
+ i = s()
+contains
+ function f()
+ end
end
+! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
module m1
end
+! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
module m1
integer :: x
integer, private :: y
+! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
module m1
integer :: x
integer :: y
+! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
module m
real :: var
interface i
+! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
module m
interface
subroutine sub0
+! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
module m
integer :: foo
!Note: PGI, Intel, and GNU allow this; NAG and Sun do not
+! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
module m1
implicit none
contains
+! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
module m
interface a
subroutine s(x)
--- /dev/null
+! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+! http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+module m
+ abstract interface
+ subroutine foo
+ end subroutine
+ end interface
+
+ procedure() :: a
+ procedure(integer) :: b
+ procedure(foo) :: c
+ procedure(bar) :: d
+ !ERROR: Explicit interface 'missing' not found
+ procedure(missing) :: e
+ !ERROR: 'b' is not an abstract interface or a procedure with an explicit interface
+ procedure(b) :: f
+ procedure(c) :: g
+ external :: h
+ !ERROR: 'h' is not an abstract interface or a procedure with an explicit interface
+ procedure(h) :: i
+
+ external :: a, b, c, d
+ !ERROR: EXTERNAL attribute not allowed on 'm'
+ external :: m
+ !ERROR: EXTERNAL attribute not allowed on 'foo'
+ external :: foo
+ !ERROR: EXTERNAL attribute not allowed on 'bar'
+ external :: bar
+
+contains
+ subroutine bar
+ end subroutine
+end module
projects / platform / upstream / llvm.git / commitdiff