return Designator{DataRef{common::Indirection{std::move(arrayElement)}}};
}
-static std::optional<Expr> ActualArgToExpr(ActualArgSpec &arg) {
+static std::optional<Expr> ActualArgToExpr(
+ parser::CharBlock at, ActualArgSpec &arg) {
return std::visit(
common::visitors{
[&](common::Indirection<Expr> &y) {
[&](common::Indirection<Variable> &y) {
return std::visit(
[&](auto &indirection) {
- return std::make_optional<Expr>(
- std::move(indirection.value()));
+ std::optional<Expr> result{std::move(indirection.value())};
+ result->source = at;
+ return result;
},
y.value().u);
},
auto &name{std::get<parser::Name>(std::get<ProcedureDesignator>(v.t).u)};
std::list<Expr> args;
for (auto &arg : std::get<std::list<ActualArgSpec>>(v.t)) {
- args.emplace_back(std::move(ActualArgToExpr(arg).value()));
+ args.emplace_back(std::move(ActualArgToExpr(name.source, arg).value()));
}
return MakeArrayElementRef(name, args);
}
-StructureConstructor FunctionReference::ConvertToStructureConstructor() {
+StructureConstructor FunctionReference::ConvertToStructureConstructor(
+ const semantics::DerivedTypeSpec &derived) {
Name name{std::get<parser::Name>(std::get<ProcedureDesignator>(v.t).u)};
std::list<ComponentSpec> components;
for (auto &arg : std::get<std::list<ActualArgSpec>>(v.t)) {
if (auto &kw{std::get<std::optional<Keyword>>(arg.t)}) {
keyword.emplace(Keyword{Name{kw->v}});
}
- components.emplace_back(
- std::move(keyword), ComponentDataSource{ActualArgToExpr(arg).value()});
+ components.emplace_back(std::move(keyword),
+ ComponentDataSource{ActualArgToExpr(name.source, arg).value()});
}
- return StructureConstructor{
- DerivedTypeSpec{std::move(name), std::list<TypeParamSpec>{}},
- std::move(components)};
+ DerivedTypeSpec spec{std::move(name), std::list<TypeParamSpec>{}};
+ spec.derivedTypeSpec = &derived;
+ return StructureConstructor{std::move(spec), std::move(components)};
}
// R1544 stmt-function-stmt
struct FunctionReference {
WRAPPER_CLASS_BOILERPLATE(FunctionReference, Call);
Designator ConvertToArrayElementRef();
- StructureConstructor ConvertToStructureConstructor();
+ StructureConstructor ConvertToStructureConstructor(
+ const semantics::DerivedTypeSpec &);
};
// R1521 call-stmt -> CALL procedure-designator [( [actual-arg-spec-list] )]
auto &parsedType{std::get<parser::DerivedTypeSpec>(structure.t)};
parser::CharBlock typeName{std::get<parser::Name>(parsedType.t).source};
if (parsedType.derivedTypeSpec == nullptr) {
- Say("INTERNAL: StructureConstructor lacks type"_err_en_US);
+ Say("INTERNAL: parser::StructureConstructor lacks type"_err_en_US);
return std::nullopt;
}
const auto &spec{*parsedType.derivedTypeSpec};
if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) { // C796
if (auto *msg{Say(typeName,
- "ABSTRACT derived type '%s' cannot be used in a structure constructor"_err_en_US,
+ "ABSTRACT derived type '%s' cannot be used in a "
+ "structure constructor"_err_en_US,
typeName.ToString().data())}) {
msg->Attach(
typeSymbol.name(), "Declaration of ABSTRACT derived type"_en_US);
return std::nullopt;
}
-// Converts, if appropriate, a misparse of the ambiguous syntax A(1) as
-// a function reference into an array reference or a structure constructor.
+// Converts, if appropriate, an original misparse of ambiguous syntax like
+// A(1) as a function reference into an array reference or a structure
+// constructor.
template<typename... A>
void FixMisparsedFunctionReference(const std::variant<A...> &constU) {
// The parse tree is updated in situ when resolving an ambiguous parse.
return;
}
Symbol &symbol{name->symbol->GetUltimate()};
- if constexpr (common::HasMember<common::Indirection<parser::Designator>,
- uType>) {
- if (symbol.has<semantics::ObjectEntityDetails>()) {
+ if (symbol.has<semantics::ObjectEntityDetails>()) {
+ if constexpr (common::HasMember<common::Indirection<parser::Designator>,
+ uType>) {
u = common::Indirection{funcRef.ConvertToArrayElementRef()};
- return;
// N.B. Expression semantics will reinterpret an array element
// reference as a single-character substring elsewhere if necessary.
+ } else {
+ common::die("can't fix misparsed function as array reference");
}
- }
- if constexpr (common::HasMember<StructureConstructor, uType>) {
- if (symbol.has<semantics::DerivedTypeDetails>()) {
- u = funcRef.ConvertToStructureConstructor();
- return;
+ } else if (symbol.has<semantics::DerivedTypeDetails>()) {
+ if constexpr (common::HasMember<parser::StructureConstructor, uType>) {
+ CHECK(symbol.scope() != nullptr);
+ const semantics::DeclTypeSpec *type{
+ symbol.scope()->FindInstantiatedDerivedType(
+ semantics::DerivedTypeSpec{symbol})};
+ CHECK(type != nullptr);
+ u = funcRef.ConvertToStructureConstructor(type->derivedTypeSpec());
+ } else {
+ common::die("can't fix misparsed function as structure constructor");
}
}
}
const Scope *FindScope(const parser::CharBlock &) const;
// Attempts to find a match for a derived type instance
- const DeclTypeSpec *FindInstantiatedDerivedType(
- const DerivedTypeSpec &, DeclTypeSpec::Category) const;
+ const DeclTypeSpec *FindInstantiatedDerivedType(const DerivedTypeSpec &,
+ DeclTypeSpec::Category = DeclTypeSpec::TypeDerived) const;
// Returns a matching derived type instance if one exists, otherwise
// creates one
structconst01.f90
structconst02.f90
structconst03.f90
+ structconst04.f90
assign01.f90
)
! Error tests for structure constructors: C1594 violations
! from assigning globally-visible data to POINTER components.
+! test/semantics/structconst04.f90 is this same test without type
+! parameters.
module usefrom
real :: usedfrom1
--- /dev/null
+! 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.
+
+! Error tests for structure constructors: C1594 violations
+! from assigning globally-visible data to POINTER components.
+! This test is structconst03.f90 with the type parameters removed.
+
+module usefrom
+ real :: usedfrom1
+end module usefrom
+
+module module1
+ use usefrom
+ implicit none
+ type :: has_pointer1
+ real, pointer :: ptop
+ type(has_pointer1), allocatable :: link1 ! don't loop during analysis
+ end type has_pointer1
+ type :: has_pointer2
+ type(has_pointer1) :: pnested
+ type(has_pointer2), allocatable :: link2
+ end type has_pointer2
+ type, extends(has_pointer2) :: has_pointer3
+ type(has_pointer3), allocatable :: link3
+ end type has_pointer3
+ type :: t1
+ real, pointer :: pt1
+ type(t1), allocatable :: link
+ end type t1
+ type :: t2
+ type(has_pointer1) :: hp1
+ type(t2), allocatable :: link
+ end type t2
+ type :: t3
+ type(has_pointer2) :: hp2
+ type(t3), allocatable :: link
+ end type t3
+ type :: t4
+ type(has_pointer3) :: hp3
+ type(t4), allocatable :: link
+ end type t4
+ real :: modulevar1
+ type(has_pointer1) :: modulevar2
+ type(has_pointer2) :: modulevar3
+ type(has_pointer3) :: modulevar4
+
+ contains
+
+ pure real function pf1(dummy1, dummy2, dummy3, dummy4)
+ real :: local1
+ type(t1) :: x1
+ type(t2) :: x2
+ type(t3) :: x3
+ type(t4) :: x4
+ real, intent(in) :: dummy1
+ real, intent(inout) :: dummy2
+ real, pointer :: dummy3
+ real, intent(inout) :: dummy4[*]
+ real :: commonvar1
+ common /cblock/ commonvar1
+ pf1 = 0.
+ x1 = t1(local1)
+ !ERROR: Externally visible object 'usedfrom1' must not be associated with pointer component 'pt1' in a PURE function
+ x1 = t1(usedfrom1)
+ !ERROR: Externally visible object 'modulevar1' must not be associated with pointer component 'pt1' in a PURE function
+ x1 = t1(modulevar1)
+ !ERROR: Externally visible object 'cblock' must not be associated with pointer component 'pt1' in a PURE function
+ x1 = t1(commonvar1)
+ !ERROR: Externally visible object 'dummy1' must not be associated with pointer component 'pt1' in a PURE function
+ x1 = t1(dummy1)
+ x1 = t1(dummy2)
+ !ERROR: Externally visible object 'dummy3' must not be associated with pointer component 'pt1' in a PURE function
+ x1 = t1(dummy3)
+! TODO when semantics handles coindexing:
+! TODO !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+! TODO x1 = t1(dummy4[0])
+ x1 = t1(dummy4)
+ !ERROR: Externally visible object 'modulevar2' must not be associated with pointer component 'ptop' in a PURE function
+ x2 = t2(modulevar2)
+ !ERROR: Externally visible object 'modulevar3' must not be associated with pointer component 'ptop' in a PURE function
+ x3 = t3(modulevar3)
+ !ERROR: Externally visible object 'modulevar4' must not be associated with pointer component 'ptop' in a PURE function
+ x4 = t4(modulevar4)
+ contains
+ subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
+ real :: local1a
+ type(t1) :: x1a
+ type(t2) :: x2a
+ type(t3) :: x3a
+ type(t4) :: x4a
+ real, intent(in) :: dummy1a
+ real, intent(inout) :: dummy2a
+ real, pointer :: dummy3a
+ real, intent(inout) :: dummy4a[*]
+ x1a = t1(local1a)
+ !ERROR: Externally visible object 'usedfrom1' must not be associated with pointer component 'pt1' in a PURE function
+ x1a = t1(usedfrom1)
+ !ERROR: Externally visible object 'modulevar1' must not be associated with pointer component 'pt1' in a PURE function
+ x1a = t1(modulevar1)
+ !ERROR: Externally visible object 'cblock' must not be associated with pointer component 'pt1' in a PURE function
+ x1a = t1(commonvar1)
+ !ERROR: Externally visible object 'dummy1' must not be associated with pointer component 'pt1' in a PURE function
+ x1a = t1(dummy1)
+ !ERROR: Externally visible object 'dummy1a' must not be associated with pointer component 'pt1' in a PURE function
+ x1a = t1(dummy1a)
+ x1a = t1(dummy2a)
+ !ERROR: Externally visible object 'dummy3' must not be associated with pointer component 'pt1' in a PURE function
+ x1a = t1(dummy3)
+ !ERROR: Externally visible object 'dummy3a' must not be associated with pointer component 'pt1' in a PURE function
+ x1a = t1(dummy3a)
+! TODO when semantics handles coindexing:
+! TODO !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+! TODO x1a = t1(dummy4a[0])
+ x1a = t1(dummy4a)
+ !ERROR: Externally visible object 'modulevar2' must not be associated with pointer component 'ptop' in a PURE function
+ x2a = t2(modulevar2)
+ !ERROR: Externally visible object 'modulevar3' must not be associated with pointer component 'ptop' in a PURE function
+ x3a = t3(modulevar3)
+ !ERROR: Externally visible object 'modulevar4' must not be associated with pointer component 'ptop' in a PURE function
+ x4a = t4(modulevar4)
+ end subroutine subr
+ end function pf1
+
+ impure real function ipf1(dummy1, dummy2, dummy3, dummy4)
+ real :: local1
+ type(t1) :: x1
+ type(t2) :: x2
+ type(t3) :: x3
+ type(t4) :: x4
+ real, intent(in) :: dummy1
+ real, intent(inout) :: dummy2
+ real, pointer :: dummy3
+ real, intent(inout) :: dummy4[*]
+ real :: commonvar1
+ common /cblock/ commonvar1
+ ipf1 = 0.
+ x1 = t1(local1)
+ x1 = t1(usedfrom1)
+ x1 = t1(modulevar1)
+ x1 = t1(commonvar1)
+ x1 = t1(dummy1)
+ x1 = t1(dummy2)
+ x1 = t1(dummy3)
+! TODO when semantics handles coindexing:
+! TODO x1 = t1(dummy4[0])
+ x1 = t1(dummy4)
+ x2 = t2(modulevar2)
+ x3 = t3(modulevar3)
+ x4 = t4(modulevar4)
+ end function ipf1
+end module module1
projects / platform / upstream / llvm.git / commitdiff