2019-03-04 10:13:12 -08:00
|
|
|
// Copyright (c) 2019, 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.
|
|
|
|
|
2019-03-26 00:33:03 -07:00
|
|
|
#include "tools.h"
|
2019-03-26 18:03:33 -07:00
|
|
|
#include "scope.h"
|
2019-04-11 21:25:45 +01:00
|
|
|
#include "semantics.h"
|
2019-04-12 16:30:03 -07:00
|
|
|
#include "symbol.h"
|
|
|
|
#include "type.h"
|
2019-04-16 19:50:52 +01:00
|
|
|
#include "../common/Fortran.h"
|
2019-04-12 16:30:03 -07:00
|
|
|
#include "../common/indirection.h"
|
|
|
|
#include "../parser/message.h"
|
|
|
|
#include "../parser/parse-tree.h"
|
2019-03-04 10:13:12 -08:00
|
|
|
#include <algorithm>
|
|
|
|
#include <set>
|
|
|
|
#include <variant>
|
|
|
|
|
|
|
|
namespace Fortran::semantics {
|
|
|
|
|
|
|
|
static const Symbol *FindCommonBlockInScope(
|
|
|
|
const Scope &scope, const Symbol &object) {
|
|
|
|
for (const auto &pair : scope.commonBlocks()) {
|
|
|
|
const Symbol &block{*pair.second};
|
|
|
|
if (IsCommonBlockContaining(block, object)) {
|
|
|
|
return █
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return nullptr;
|
|
|
|
}
|
|
|
|
|
|
|
|
const Symbol *FindCommonBlockContaining(const Symbol &object) {
|
|
|
|
for (const Scope *scope{&object.owner()};
|
|
|
|
scope->kind() != Scope::Kind::Global; scope = &scope->parent()) {
|
|
|
|
if (const Symbol * block{FindCommonBlockInScope(*scope, object)}) {
|
|
|
|
return block;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return nullptr;
|
|
|
|
}
|
|
|
|
|
|
|
|
const Scope *FindProgramUnitContaining(const Scope &start) {
|
|
|
|
const Scope *scope{&start};
|
|
|
|
while (scope != nullptr) {
|
|
|
|
switch (scope->kind()) {
|
|
|
|
case Scope::Kind::Module:
|
|
|
|
case Scope::Kind::MainProgram:
|
|
|
|
case Scope::Kind::Subprogram: return scope;
|
2019-05-31 16:37:00 -07:00
|
|
|
case Scope::Kind::Global: return nullptr;
|
2019-03-04 10:13:12 -08:00
|
|
|
case Scope::Kind::DerivedType:
|
|
|
|
case Scope::Kind::Block:
|
|
|
|
case Scope::Kind::Forall:
|
|
|
|
case Scope::Kind::ImpliedDos: scope = &scope->parent();
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return nullptr;
|
|
|
|
}
|
|
|
|
|
|
|
|
const Scope *FindProgramUnitContaining(const Symbol &symbol) {
|
|
|
|
return FindProgramUnitContaining(symbol.owner());
|
|
|
|
}
|
|
|
|
|
|
|
|
const Scope *FindPureFunctionContaining(const Scope *scope) {
|
|
|
|
scope = FindProgramUnitContaining(*scope);
|
|
|
|
while (scope != nullptr) {
|
|
|
|
if (IsPureFunction(*scope)) {
|
|
|
|
return scope;
|
|
|
|
}
|
|
|
|
scope = FindProgramUnitContaining(scope->parent());
|
|
|
|
}
|
|
|
|
return nullptr;
|
|
|
|
}
|
|
|
|
|
|
|
|
bool IsCommonBlockContaining(const Symbol &block, const Symbol &object) {
|
|
|
|
const auto &objects{block.get<CommonBlockDetails>().objects()};
|
|
|
|
auto found{std::find(objects.begin(), objects.end(), &object)};
|
|
|
|
return found != objects.end();
|
|
|
|
}
|
|
|
|
|
|
|
|
bool IsUseAssociated(const Symbol &symbol, const Scope &scope) {
|
|
|
|
const Scope *owner{FindProgramUnitContaining(symbol.GetUltimate().owner())};
|
|
|
|
return owner != nullptr && owner->kind() == Scope::Kind::Module &&
|
|
|
|
owner != FindProgramUnitContaining(scope);
|
|
|
|
}
|
|
|
|
|
2019-03-26 00:33:03 -07:00
|
|
|
bool DoesScopeContain(
|
|
|
|
const Scope *maybeAncestor, const Scope &maybeDescendent) {
|
2019-03-05 13:11:57 -08:00
|
|
|
if (maybeAncestor != nullptr) {
|
|
|
|
const Scope *scope{&maybeDescendent};
|
|
|
|
while (scope->kind() != Scope::Kind::Global) {
|
|
|
|
scope = &scope->parent();
|
|
|
|
if (scope == maybeAncestor) {
|
|
|
|
return true;
|
|
|
|
}
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
|
|
|
}
|
|
|
|
return false;
|
|
|
|
}
|
|
|
|
|
2019-03-05 13:11:57 -08:00
|
|
|
bool DoesScopeContain(const Scope *maybeAncestor, const Symbol &symbol) {
|
|
|
|
return DoesScopeContain(maybeAncestor, symbol.owner());
|
|
|
|
}
|
|
|
|
|
2019-03-04 10:13:12 -08:00
|
|
|
bool IsHostAssociated(const Symbol &symbol, const Scope &scope) {
|
2019-03-05 13:11:57 -08:00
|
|
|
return DoesScopeContain(FindProgramUnitContaining(symbol), scope);
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
|
|
|
|
|
|
|
bool IsDummy(const Symbol &symbol) {
|
|
|
|
if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
|
|
|
|
return details->isDummy();
|
|
|
|
} else if (const auto *details{symbol.detailsIf<ProcEntityDetails>()}) {
|
|
|
|
return details->isDummy();
|
|
|
|
} else {
|
|
|
|
return false;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
bool IsPointerDummy(const Symbol &symbol) {
|
2019-04-07 11:29:48 -07:00
|
|
|
return IsPointer(symbol) && IsDummy(symbol);
|
|
|
|
}
|
|
|
|
|
|
|
|
// variable-name
|
|
|
|
bool IsVariableName(const Symbol &symbol) {
|
2019-06-10 13:30:29 -07:00
|
|
|
const Symbol &ultimate{symbol.GetUltimate()};
|
|
|
|
return ultimate.has<ObjectEntityDetails>() && !IsParameter(ultimate);
|
2019-04-07 11:29:48 -07:00
|
|
|
}
|
|
|
|
|
|
|
|
// proc-name
|
|
|
|
bool IsProcName(const Symbol &symbol) {
|
2019-06-10 13:30:29 -07:00
|
|
|
return symbol.GetUltimate().has<ProcEntityDetails>();
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
|
|
|
|
|
|
|
bool IsFunction(const Symbol &symbol) {
|
2019-04-17 07:42:16 -07:00
|
|
|
return std::visit(
|
|
|
|
common::visitors{
|
|
|
|
[](const SubprogramDetails &x) { return x.isFunction(); },
|
|
|
|
[&](const SubprogramNameDetails &x) {
|
|
|
|
return symbol.test(Symbol::Flag::Function);
|
|
|
|
},
|
|
|
|
[](const ProcEntityDetails &x) {
|
|
|
|
const auto &ifc{x.interface()};
|
|
|
|
return ifc.type() || (ifc.symbol() && IsFunction(*ifc.symbol()));
|
|
|
|
},
|
|
|
|
[](const UseDetails &x) { return IsFunction(x.symbol()); },
|
|
|
|
[](const auto &) { return false; },
|
|
|
|
},
|
|
|
|
symbol.details());
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
|
|
|
|
|
|
|
bool IsPureFunction(const Symbol &symbol) {
|
|
|
|
return symbol.attrs().test(Attr::PURE) && IsFunction(symbol);
|
|
|
|
}
|
|
|
|
|
|
|
|
bool IsPureFunction(const Scope &scope) {
|
|
|
|
if (const Symbol * symbol{scope.GetSymbol()}) {
|
|
|
|
return IsPureFunction(*symbol);
|
|
|
|
} else {
|
|
|
|
return false;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2019-04-17 07:42:16 -07:00
|
|
|
bool IsProcedure(const Symbol &symbol) {
|
|
|
|
return std::visit(
|
|
|
|
common::visitors{
|
|
|
|
[](const SubprogramDetails &) { return true; },
|
|
|
|
[](const SubprogramNameDetails &) { return true; },
|
2019-04-25 13:18:33 -07:00
|
|
|
[](const ProcEntityDetails &) { return true; },
|
|
|
|
[](const GenericDetails &) { return true; },
|
2019-05-21 16:58:46 -07:00
|
|
|
[](const ProcBindingDetails &) { return true; },
|
2019-04-17 07:42:16 -07:00
|
|
|
[](const UseDetails &x) { return IsProcedure(x.symbol()); },
|
|
|
|
[](const auto &) { return false; },
|
|
|
|
},
|
|
|
|
symbol.details());
|
|
|
|
}
|
|
|
|
|
2019-04-18 15:07:40 -07:00
|
|
|
bool IsProcedurePointer(const Symbol &symbol) {
|
|
|
|
return symbol.has<ProcEntityDetails>() && IsPointer(symbol);
|
|
|
|
}
|
|
|
|
|
2019-03-04 16:28:35 -08:00
|
|
|
static const Symbol *FindPointerComponent(
|
2019-03-04 10:13:12 -08:00
|
|
|
const Scope &scope, std::set<const Scope *> &visited) {
|
|
|
|
if (scope.kind() != Scope::Kind::DerivedType) {
|
2019-03-04 16:28:35 -08:00
|
|
|
return nullptr;
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
|
|
|
if (!visited.insert(&scope).second) {
|
2019-03-04 16:28:35 -08:00
|
|
|
return nullptr;
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
2019-03-04 16:28:35 -08:00
|
|
|
// If there's a top-level pointer component, return it for clearer error
|
|
|
|
// messaging.
|
2019-03-04 10:13:12 -08:00
|
|
|
for (const auto &pair : scope) {
|
|
|
|
const Symbol &symbol{*pair.second};
|
2019-04-18 15:07:40 -07:00
|
|
|
if (IsPointer(symbol)) {
|
2019-03-04 16:28:35 -08:00
|
|
|
return &symbol;
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
2019-03-04 16:28:35 -08:00
|
|
|
}
|
|
|
|
for (const auto &pair : scope) {
|
|
|
|
const Symbol &symbol{*pair.second};
|
2019-03-04 10:13:12 -08:00
|
|
|
if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
|
|
|
|
if (const DeclTypeSpec * type{details->type()}) {
|
|
|
|
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
|
|
|
|
if (const Scope * nested{derived->scope()}) {
|
2019-03-04 16:28:35 -08:00
|
|
|
if (const Symbol *
|
|
|
|
pointer{FindPointerComponent(*nested, visited)}) {
|
|
|
|
return pointer;
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
2019-03-04 16:28:35 -08:00
|
|
|
return nullptr;
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
|
|
|
|
2019-03-04 16:28:35 -08:00
|
|
|
const Symbol *FindPointerComponent(const Scope &scope) {
|
2019-03-04 10:13:12 -08:00
|
|
|
std::set<const Scope *> visited;
|
2019-03-04 16:28:35 -08:00
|
|
|
return FindPointerComponent(scope, visited);
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
|
|
|
|
2019-03-04 16:28:35 -08:00
|
|
|
const Symbol *FindPointerComponent(const DerivedTypeSpec &derived) {
|
2019-03-04 10:13:12 -08:00
|
|
|
if (const Scope * scope{derived.scope()}) {
|
2019-03-04 16:28:35 -08:00
|
|
|
return FindPointerComponent(*scope);
|
2019-03-04 10:13:12 -08:00
|
|
|
} else {
|
2019-03-04 16:28:35 -08:00
|
|
|
return nullptr;
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2019-03-04 16:28:35 -08:00
|
|
|
const Symbol *FindPointerComponent(const DeclTypeSpec &type) {
|
2019-03-04 10:13:12 -08:00
|
|
|
if (const DerivedTypeSpec * derived{type.AsDerived()}) {
|
2019-03-04 16:28:35 -08:00
|
|
|
return FindPointerComponent(*derived);
|
2019-03-04 10:13:12 -08:00
|
|
|
} else {
|
2019-03-04 16:28:35 -08:00
|
|
|
return nullptr;
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2019-03-04 16:28:35 -08:00
|
|
|
const Symbol *FindPointerComponent(const DeclTypeSpec *type) {
|
|
|
|
return type ? FindPointerComponent(*type) : nullptr;
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
|
|
|
|
2019-03-04 16:28:35 -08:00
|
|
|
const Symbol *FindPointerComponent(const Symbol &symbol) {
|
2019-04-18 15:07:40 -07:00
|
|
|
return IsPointer(symbol) ? &symbol : FindPointerComponent(symbol.GetType());
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
|
|
|
|
|
|
|
// C1594 specifies several ways by which an object might be globally visible.
|
2019-03-04 16:28:35 -08:00
|
|
|
const Symbol *FindExternallyVisibleObject(
|
|
|
|
const Symbol &object, const Scope &scope) {
|
|
|
|
// TODO: Storage association with any object for which this predicate holds,
|
|
|
|
// once EQUIVALENCE is supported.
|
|
|
|
if (IsUseAssociated(object, scope) || IsHostAssociated(object, scope) ||
|
2019-03-04 10:13:12 -08:00
|
|
|
(IsPureFunction(scope) && IsPointerDummy(object)) ||
|
2019-03-04 16:28:35 -08:00
|
|
|
(object.attrs().test(Attr::INTENT_IN) && IsDummy(object))) {
|
|
|
|
return &object;
|
|
|
|
} else if (const Symbol * block{FindCommonBlockContaining(object)}) {
|
|
|
|
return block;
|
|
|
|
} else {
|
|
|
|
return nullptr;
|
|
|
|
}
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|
2019-03-26 00:33:03 -07:00
|
|
|
|
2019-04-19 08:22:28 -07:00
|
|
|
bool ExprHasTypeCategory(
|
|
|
|
const SomeExpr &expr, const common::TypeCategory &type) {
|
|
|
|
auto dynamicType{expr.GetType()};
|
2019-05-13 09:33:18 -07:00
|
|
|
return dynamicType.has_value() && dynamicType->category() == type;
|
2019-03-26 00:33:03 -07:00
|
|
|
}
|
2019-03-18 16:19:41 +00:00
|
|
|
|
2019-04-11 21:25:45 +01:00
|
|
|
bool ExprTypeKindIsDefault(
|
2019-04-19 08:22:28 -07:00
|
|
|
const SomeExpr &expr, const SemanticsContext &context) {
|
|
|
|
auto dynamicType{expr.GetType()};
|
2019-04-11 21:25:45 +01:00
|
|
|
return dynamicType.has_value() &&
|
2019-05-13 09:33:18 -07:00
|
|
|
dynamicType->category() != common::TypeCategory::Derived &&
|
2019-06-11 18:26:48 -07:00
|
|
|
dynamicType->kind() == context.GetDefaultKind(dynamicType->category());
|
2019-04-11 21:25:45 +01:00
|
|
|
}
|
2019-04-18 15:07:40 -07:00
|
|
|
|
|
|
|
const Symbol *FindFunctionResult(const Symbol &symbol) {
|
|
|
|
if (const auto *procEntity{symbol.detailsIf<ProcEntityDetails>()}) {
|
|
|
|
const ProcInterface &interface{procEntity->interface()};
|
|
|
|
if (interface.symbol() != nullptr) {
|
|
|
|
return FindFunctionResult(*interface.symbol());
|
|
|
|
}
|
|
|
|
} else if (const auto *subp{symbol.detailsIf<SubprogramDetails>()}) {
|
|
|
|
if (subp->isFunction()) {
|
|
|
|
return &subp->result();
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return nullptr;
|
|
|
|
}
|
[flang] Allocate semantic checks (second part)
Implement semantic checks and realted tests for constraints:
C937, C938, C939, C940, C941, C942, C945 (second part),
C946, C947, C948, C949 and C950.
Original-commit: flang-compiler/f18@b4965d272b1749d554e3d1388c0a7856591741e8
Tree-same-pre-rewrite: false
2019-04-26 01:10:04 -07:00
|
|
|
|
2019-06-23 10:59:32 -07:00
|
|
|
bool IsExtensibleType(const DerivedTypeSpec *derived) {
|
|
|
|
return derived && !IsIsoCType(derived) &&
|
|
|
|
!derived->typeSymbol().attrs().test(Attr::BIND_C) &&
|
|
|
|
!derived->typeSymbol().get<DerivedTypeDetails>().sequence();
|
|
|
|
}
|
|
|
|
|
[flang] Allocate semantic checks (second part)
Implement semantic checks and realted tests for constraints:
C937, C938, C939, C940, C941, C942, C945 (second part),
C946, C947, C948, C949 and C950.
Original-commit: flang-compiler/f18@b4965d272b1749d554e3d1388c0a7856591741e8
Tree-same-pre-rewrite: false
2019-04-26 01:10:04 -07:00
|
|
|
bool IsDerivedTypeFromModule(
|
|
|
|
const DerivedTypeSpec *derived, const char *module, const char *name) {
|
|
|
|
if (!derived) {
|
|
|
|
return false;
|
|
|
|
} else {
|
|
|
|
const auto &symbol{derived->typeSymbol()};
|
|
|
|
return symbol.name() == name && symbol.owner().IsModule() &&
|
|
|
|
symbol.owner().name() == module;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2019-06-21 17:32:11 -07:00
|
|
|
bool IsIsoCType(const DerivedTypeSpec *derived) {
|
|
|
|
return IsDerivedTypeFromModule(derived, "iso_c_binding", "c_ptr") ||
|
|
|
|
IsDerivedTypeFromModule(derived, "iso_c_binding", "c_funptr");
|
|
|
|
}
|
|
|
|
|
[flang] Allocate semantic checks (second part)
Implement semantic checks and realted tests for constraints:
C937, C938, C939, C940, C941, C942, C945 (second part),
C946, C947, C948, C949 and C950.
Original-commit: flang-compiler/f18@b4965d272b1749d554e3d1388c0a7856591741e8
Tree-same-pre-rewrite: false
2019-04-26 01:10:04 -07:00
|
|
|
bool IsTeamType(const DerivedTypeSpec *derived) {
|
|
|
|
return IsDerivedTypeFromModule(derived, "iso_fortran_env", "team_type");
|
|
|
|
}
|
|
|
|
|
|
|
|
const Symbol *HasCoarrayUltimateComponent(
|
|
|
|
const DerivedTypeSpec &derivedTypeSpec) {
|
2019-06-11 18:26:48 -07:00
|
|
|
return FindUltimateComponent(derivedTypeSpec, IsCoarray);
|
[flang] Allocate semantic checks (second part)
Implement semantic checks and realted tests for constraints:
C937, C938, C939, C940, C941, C942, C945 (second part),
C946, C947, C948, C949 and C950.
Original-commit: flang-compiler/f18@b4965d272b1749d554e3d1388c0a7856591741e8
Tree-same-pre-rewrite: false
2019-04-26 01:10:04 -07:00
|
|
|
}
|
|
|
|
|
|
|
|
const bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) {
|
|
|
|
return IsDerivedTypeFromModule(
|
|
|
|
derivedTypeSpec, "iso_fortran_env", "event_type") ||
|
|
|
|
IsDerivedTypeFromModule(derivedTypeSpec, "iso_fortran_env", "lock_type");
|
|
|
|
}
|
|
|
|
|
|
|
|
const Symbol *HasEventOrLockPotentialComponent(
|
|
|
|
const DerivedTypeSpec &derivedTypeSpec) {
|
|
|
|
|
|
|
|
const Symbol &symbol{derivedTypeSpec.typeSymbol()};
|
|
|
|
// TODO is it guaranteed that derived type symbol have a scope and is it the
|
|
|
|
// right scope to look into?
|
|
|
|
CHECK(symbol.scope());
|
|
|
|
for (const Symbol *componentSymbol :
|
|
|
|
symbol.get<DerivedTypeDetails>().OrderComponents(*symbol.scope())) {
|
|
|
|
CHECK(componentSymbol);
|
|
|
|
if (!IsPointer(*componentSymbol)) {
|
|
|
|
if (const DeclTypeSpec * declTypeSpec{componentSymbol->GetType()}) {
|
|
|
|
if (const DerivedTypeSpec *
|
|
|
|
componentDerivedTypeSpec{declTypeSpec->AsDerived()}) {
|
|
|
|
// Avoid infinite loop, that may happen if the component
|
|
|
|
// is an allocatable of the same type as the derived type.
|
|
|
|
// TODO: Is it legal to have longer type loops: i.e type B has a
|
|
|
|
// component of type A that has an allocatable component of type B?
|
|
|
|
if (&symbol != &componentDerivedTypeSpec->typeSymbol()) {
|
|
|
|
if (IsEventTypeOrLockType(componentDerivedTypeSpec)) {
|
|
|
|
return componentSymbol;
|
|
|
|
} else if (const Symbol *
|
|
|
|
subcomponent{HasEventOrLockPotentialComponent(
|
|
|
|
*componentDerivedTypeSpec)}) {
|
|
|
|
return subcomponent;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return nullptr;
|
|
|
|
}
|
2019-06-11 18:26:48 -07:00
|
|
|
|
|
|
|
const Symbol *FindUltimateComponent(const DerivedTypeSpec &derivedTypeSpec,
|
|
|
|
std::function<bool(const Symbol &)> predicate) {
|
|
|
|
const auto *scope{derivedTypeSpec.typeSymbol().scope()};
|
|
|
|
CHECK(scope);
|
|
|
|
for (const auto &pair : *scope) {
|
|
|
|
const Symbol &component{*pair.second};
|
|
|
|
const DeclTypeSpec *type{component.GetType()};
|
|
|
|
if (!type) {
|
|
|
|
continue;
|
|
|
|
}
|
|
|
|
const DerivedTypeSpec *derived{type->AsDerived()};
|
|
|
|
bool isUltimate{IsAllocatableOrPointer(component) || !derived};
|
|
|
|
if (const Symbol *
|
|
|
|
result{!isUltimate ? FindUltimateComponent(*derived, predicate)
|
|
|
|
: predicate(component) ? &component : nullptr}) {
|
|
|
|
return result;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return nullptr;
|
|
|
|
}
|
|
|
|
|
2019-07-02 12:10:09 -07:00
|
|
|
bool IsFinalizable(const Symbol &symbol) {
|
2019-07-02 20:34:27 -07:00
|
|
|
if (const DeclTypeSpec * type{symbol.GetType()}) {
|
|
|
|
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
|
|
|
|
if (const Scope * scope{derived->scope()}) {
|
2019-07-02 12:10:09 -07:00
|
|
|
for (auto &pair : *scope) {
|
|
|
|
Symbol &symbol{*pair.second};
|
|
|
|
if (symbol.has<FinalProcDetails>()) {
|
|
|
|
return true;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return false;
|
|
|
|
}
|
|
|
|
|
2019-07-10 18:20:27 -07:00
|
|
|
bool IsCoarray(const Symbol &symbol) { return symbol.Corank() > 0; }
|
2019-07-02 12:10:09 -07:00
|
|
|
|
|
|
|
bool IsAssumedSizeArray(const Symbol &symbol) {
|
|
|
|
const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
|
|
|
|
return details && details->IsAssumedSize();
|
|
|
|
}
|
|
|
|
|
2019-07-10 18:20:27 -07:00
|
|
|
static const DeclTypeSpec &InstantiateIntrinsicType(Scope &scope,
|
|
|
|
const DeclTypeSpec &spec, SemanticsContext &semanticsContext) {
|
|
|
|
const IntrinsicTypeSpec *intrinsic{spec.AsIntrinsic()};
|
|
|
|
CHECK(intrinsic != nullptr);
|
|
|
|
if (evaluate::ToInt64(intrinsic->kind()).has_value()) {
|
|
|
|
return spec; // KIND is already a known constant
|
|
|
|
}
|
|
|
|
// The expression was not originally constant, but now it must be so
|
|
|
|
// in the context of a parameterized derived type instantiation.
|
|
|
|
KindExpr copy{intrinsic->kind()};
|
|
|
|
evaluate::FoldingContext &foldingContext{semanticsContext.foldingContext()};
|
|
|
|
copy = evaluate::Fold(foldingContext, std::move(copy));
|
|
|
|
int kind{semanticsContext.GetDefaultKind(intrinsic->category())};
|
|
|
|
if (auto value{evaluate::ToInt64(copy)}) {
|
|
|
|
if (evaluate::IsValidKindOfIntrinsicType(intrinsic->category(), *value)) {
|
|
|
|
kind = *value;
|
|
|
|
} else {
|
|
|
|
foldingContext.messages().Say(
|
|
|
|
"KIND parameter value (%jd) of intrinsic type %s "
|
|
|
|
"did not resolve to a supported value"_err_en_US,
|
|
|
|
static_cast<std::intmax_t>(*value),
|
|
|
|
parser::ToUpperCaseLetters(
|
|
|
|
common::EnumToString(intrinsic->category())));
|
|
|
|
}
|
|
|
|
}
|
|
|
|
switch (spec.category()) {
|
|
|
|
case DeclTypeSpec::Numeric:
|
|
|
|
return scope.MakeNumericType(intrinsic->category(), KindExpr{kind});
|
|
|
|
case DeclTypeSpec::Logical: //
|
|
|
|
return scope.MakeLogicalType(KindExpr{kind});
|
|
|
|
case DeclTypeSpec::Character:
|
|
|
|
return scope.MakeCharacterType(
|
|
|
|
ParamValue{spec.characterTypeSpec().length()}, KindExpr{kind});
|
|
|
|
default: CRASH_NO_CASE;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
static const DeclTypeSpec *FindInstantiatedDerivedType(const Scope &scope,
|
|
|
|
const DerivedTypeSpec &spec, DeclTypeSpec::Category category) {
|
|
|
|
DeclTypeSpec type{category, spec};
|
|
|
|
if (const auto *found{scope.FindType(type)}) {
|
|
|
|
return found;
|
|
|
|
} else if (scope.kind() == Scope::Kind::Global) {
|
|
|
|
return nullptr;
|
|
|
|
} else {
|
|
|
|
return FindInstantiatedDerivedType(scope.parent(), spec, category);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
static Symbol &InstantiateSymbol(const Symbol &, Scope &, SemanticsContext &);
|
|
|
|
|
|
|
|
void InstantiateDerivedType(DerivedTypeSpec &spec, Scope &containingScope,
|
|
|
|
SemanticsContext &semanticsContext) {
|
|
|
|
Scope &newScope{containingScope.MakeScope(Scope::Kind::DerivedType)};
|
|
|
|
newScope.set_derivedTypeSpec(spec);
|
|
|
|
spec.ReplaceScope(newScope);
|
|
|
|
const Symbol &typeSymbol{spec.typeSymbol()};
|
|
|
|
const Scope *typeScope{typeSymbol.scope()};
|
|
|
|
CHECK(typeScope != nullptr);
|
|
|
|
const auto &typeDetails{typeSymbol.get<DerivedTypeDetails>()};
|
|
|
|
for (const Symbol *symbol :
|
|
|
|
typeDetails.OrderParameterDeclarations(typeSymbol)) {
|
|
|
|
const SourceName &name{symbol->name()};
|
|
|
|
if (typeScope->find(symbol->name()) != typeScope->end()) {
|
|
|
|
// This type parameter belongs to the derived type itself, not to
|
|
|
|
// one of its parents. Put the type parameter expression value
|
|
|
|
// into the new scope as the initialization value for the parameter.
|
|
|
|
if (ParamValue * paramValue{spec.FindParameter(name)}) {
|
|
|
|
const TypeParamDetails &details{symbol->get<TypeParamDetails>()};
|
|
|
|
paramValue->set_attr(details.attr());
|
|
|
|
if (MaybeIntExpr expr{paramValue->GetExplicit()}) {
|
|
|
|
// Ensure that any kind type parameters with values are
|
|
|
|
// constant by now.
|
|
|
|
if (details.attr() == common::TypeParamAttr::Kind) {
|
|
|
|
// Any errors in rank and type will have already elicited
|
|
|
|
// messages, so don't pile on by complaining further here.
|
|
|
|
if (auto maybeDynamicType{expr->GetType()}) {
|
|
|
|
if (expr->Rank() == 0 &&
|
|
|
|
maybeDynamicType->category() == TypeCategory::Integer) {
|
|
|
|
if (!evaluate::ToInt64(*expr).has_value()) {
|
|
|
|
std::stringstream fortran;
|
|
|
|
fortran << *expr;
|
|
|
|
if (auto *msg{
|
|
|
|
semanticsContext.foldingContext().messages().Say(
|
|
|
|
"Value of kind type parameter '%s' (%s) is not "
|
|
|
|
"a scalar INTEGER constant"_err_en_US,
|
|
|
|
name, fortran.str())}) {
|
|
|
|
msg->Attach(name, "declared here"_en_US);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
TypeParamDetails instanceDetails{details.attr()};
|
|
|
|
if (const DeclTypeSpec * type{details.type()}) {
|
|
|
|
instanceDetails.set_type(*type);
|
|
|
|
}
|
|
|
|
instanceDetails.set_init(std::move(*expr));
|
|
|
|
Symbol *parameter{
|
|
|
|
newScope.try_emplace(name, std::move(instanceDetails))
|
|
|
|
.first->second};
|
|
|
|
CHECK(parameter != nullptr);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
// Instantiate every non-parameter symbol from the original derived
|
|
|
|
// type's scope into the new instance.
|
|
|
|
auto restorer{semanticsContext.foldingContext().WithPDTInstance(spec)};
|
|
|
|
newScope.AddSourceRange(typeScope->sourceRange());
|
|
|
|
for (const auto &pair : *typeScope) {
|
|
|
|
const Symbol &symbol{*pair.second};
|
|
|
|
InstantiateSymbol(symbol, newScope, semanticsContext);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
void ProcessParameterExpressions(
|
|
|
|
DerivedTypeSpec &spec, evaluate::FoldingContext &foldingContext) {
|
|
|
|
const Symbol &typeSymbol{spec.typeSymbol()};
|
|
|
|
const DerivedTypeDetails &typeDetails{typeSymbol.get<DerivedTypeDetails>()};
|
|
|
|
auto paramDecls{typeDetails.OrderParameterDeclarations(typeSymbol)};
|
|
|
|
// Fold the explicit type parameter value expressions first. Do not
|
|
|
|
// fold them within the scope of the derived type being instantiated;
|
|
|
|
// these expressions cannot use its type parameters. Convert the values
|
|
|
|
// of the expressions to the declared types of the type parameters.
|
|
|
|
for (const Symbol *symbol : paramDecls) {
|
|
|
|
const SourceName &name{symbol->name()};
|
|
|
|
if (ParamValue * paramValue{spec.FindParameter(name)}) {
|
|
|
|
if (const MaybeIntExpr & expr{paramValue->GetExplicit()}) {
|
|
|
|
if (auto converted{evaluate::ConvertToType(*symbol, SomeExpr{*expr})}) {
|
|
|
|
SomeExpr folded{
|
|
|
|
evaluate::Fold(foldingContext, std::move(*converted))};
|
|
|
|
if (auto *intExpr{std::get_if<SomeIntExpr>(&folded.u)}) {
|
|
|
|
paramValue->SetExplicit(std::move(*intExpr));
|
|
|
|
continue;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
std::stringstream fortran;
|
|
|
|
fortran << *expr;
|
|
|
|
if (auto *msg{foldingContext.messages().Say(
|
|
|
|
"Value of type parameter '%s' (%s) is not "
|
|
|
|
"convertible to its type"_err_en_US,
|
|
|
|
name, fortran.str())}) {
|
|
|
|
msg->Attach(name, "declared here"_en_US);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
// Type parameter default value expressions are folded in declaration order
|
|
|
|
// within the scope of the derived type so that the values of earlier type
|
|
|
|
// parameters are available for use in the default initialization
|
|
|
|
// expressions of later parameters.
|
|
|
|
auto restorer{foldingContext.WithPDTInstance(spec)};
|
|
|
|
for (const Symbol *symbol : paramDecls) {
|
|
|
|
const SourceName &name{symbol->name()};
|
|
|
|
const TypeParamDetails &details{symbol->get<TypeParamDetails>()};
|
|
|
|
MaybeIntExpr expr;
|
|
|
|
ParamValue *paramValue{spec.FindParameter(name)};
|
|
|
|
if (paramValue == nullptr) {
|
|
|
|
expr = evaluate::Fold(foldingContext, common::Clone(details.init()));
|
|
|
|
} else if (paramValue->isExplicit()) {
|
|
|
|
expr = paramValue->GetExplicit();
|
|
|
|
}
|
|
|
|
if (expr.has_value()) {
|
|
|
|
if (paramValue != nullptr) {
|
|
|
|
paramValue->SetExplicit(std::move(*expr));
|
|
|
|
} else {
|
|
|
|
spec.AddParamValue(symbol->name(), ParamValue{std::move(*expr)});
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
const DeclTypeSpec &FindOrInstantiateDerivedType(Scope &scope,
|
|
|
|
DerivedTypeSpec &&spec, SemanticsContext &semanticsContext,
|
|
|
|
DeclTypeSpec::Category category) {
|
|
|
|
ProcessParameterExpressions(spec, semanticsContext.foldingContext());
|
|
|
|
if (const DeclTypeSpec *
|
|
|
|
type{FindInstantiatedDerivedType(scope, spec, category)}) {
|
|
|
|
return *type;
|
|
|
|
}
|
|
|
|
// Create a new instantiation of this parameterized derived type
|
|
|
|
// for this particular distinct set of actual parameter values.
|
|
|
|
DeclTypeSpec &type{scope.MakeDerivedType(std::move(spec), category)};
|
|
|
|
InstantiateDerivedType(type.derivedTypeSpec(), scope, semanticsContext);
|
|
|
|
return type;
|
|
|
|
}
|
|
|
|
|
|
|
|
// Clone a Symbol in the context of a parameterized derived type instance
|
|
|
|
static Symbol &InstantiateSymbol(
|
|
|
|
const Symbol &symbol, Scope &scope, SemanticsContext &semanticsContext) {
|
|
|
|
evaluate::FoldingContext foldingContext{semanticsContext.foldingContext()};
|
|
|
|
CHECK(foldingContext.pdtInstance() != nullptr);
|
|
|
|
const DerivedTypeSpec &instanceSpec{*foldingContext.pdtInstance()};
|
|
|
|
auto pair{scope.try_emplace(symbol.name(), symbol.attrs())};
|
|
|
|
Symbol &result{*pair.first->second};
|
|
|
|
if (!pair.second) {
|
|
|
|
// Symbol was already present in the scope, which can only happen
|
|
|
|
// in the case of type parameters.
|
|
|
|
CHECK(symbol.has<TypeParamDetails>());
|
|
|
|
return result;
|
|
|
|
}
|
|
|
|
result.attrs() = symbol.attrs();
|
|
|
|
result.flags() = symbol.flags();
|
|
|
|
result.set_details(common::Clone(symbol.details()));
|
|
|
|
if (auto *details{result.detailsIf<ObjectEntityDetails>()}) {
|
|
|
|
if (DeclTypeSpec * origType{result.GetType()}) {
|
|
|
|
if (const DerivedTypeSpec * derived{origType->AsDerived()}) {
|
|
|
|
DerivedTypeSpec newSpec{*derived};
|
|
|
|
if (symbol.test(Symbol::Flag::ParentComp)) {
|
|
|
|
// Forward any explicit type parameter values from the
|
|
|
|
// derived type spec under instantiation to its parent
|
|
|
|
// component derived type spec that define type parameters
|
|
|
|
// of the parent component.
|
|
|
|
for (const auto &pair : instanceSpec.parameters()) {
|
|
|
|
if (scope.find(pair.first) == scope.end()) {
|
|
|
|
newSpec.AddParamValue(pair.first, ParamValue{pair.second});
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
details->ReplaceType(FindOrInstantiateDerivedType(
|
|
|
|
scope, std::move(newSpec), semanticsContext, origType->category()));
|
|
|
|
} else if (origType->AsIntrinsic() != nullptr) {
|
|
|
|
details->ReplaceType(
|
|
|
|
InstantiateIntrinsicType(scope, *origType, semanticsContext));
|
|
|
|
} else if (origType->category() != DeclTypeSpec::ClassStar) {
|
|
|
|
DIE("instantiated component has type that is "
|
|
|
|
"neither intrinsic, derived, nor CLASS(*)");
|
|
|
|
}
|
|
|
|
}
|
|
|
|
details->set_init(
|
|
|
|
evaluate::Fold(foldingContext, std::move(details->init())));
|
|
|
|
for (ShapeSpec &dim : details->shape()) {
|
|
|
|
if (dim.lbound().isExplicit()) {
|
|
|
|
dim.lbound().SetExplicit(
|
|
|
|
Fold(foldingContext, std::move(dim.lbound().GetExplicit())));
|
|
|
|
}
|
|
|
|
if (dim.ubound().isExplicit()) {
|
|
|
|
dim.ubound().SetExplicit(
|
|
|
|
Fold(foldingContext, std::move(dim.ubound().GetExplicit())));
|
|
|
|
}
|
|
|
|
}
|
|
|
|
for (ShapeSpec &dim : details->coshape()) {
|
|
|
|
if (dim.lbound().isExplicit()) {
|
|
|
|
dim.lbound().SetExplicit(
|
|
|
|
Fold(foldingContext, std::move(dim.lbound().GetExplicit())));
|
|
|
|
}
|
|
|
|
if (dim.ubound().isExplicit()) {
|
|
|
|
dim.ubound().SetExplicit(
|
|
|
|
Fold(foldingContext, std::move(dim.ubound().GetExplicit())));
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return result;
|
|
|
|
}
|
|
|
|
|
2019-03-04 10:13:12 -08:00
|
|
|
}
|