if (derived_ != nullptr) {
CHECK(category_ == TypeCategory::Derived);
return DerivedTypeSpecAsFortran(*derived_);
- // TODO pmk: how to indicate polymorphism? can't use TYPE() vs CLASS()
} else if (charLength_ != nullptr) {
std::string result{"CHARACTER(KIND="s + std::to_string(kind_) + ",LEN="};
if (charLength_->isAssumed()) {
result += ss.str();
}
return result + ')';
- } else if (isPolymorphic_) {
- return "CLASS(*)"; // not valid, just for debugging
+ } else if (IsUnlimitedPolymorphic()) {
+ return "CLASS(*)";
+ } else if (IsAssumedType()) {
+ return "TYPE(*)";
} else if (kind_ == 0) {
return "(typeless intrinsic function argument)";
} else {
}
} else {
// NULL(), pointer to subroutine, &c.
- messages.Say("Typeless item not allowed for '%s=' argument"_err_en_US,
- d.keyword);
+ if ("loc"s != name) {
+ messages.Say("Typeless item not allowed for '%s=' argument"_err_en_US,
+ d.keyword);
+ }
}
return std::nullopt;
} else if (!d.typePattern.categorySet.test(type->category())) {
for (std::size_t j{0}; j < dummies; ++j) {
const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
if (const auto &arg{rearranged[j]}) {
- const Expr<SomeType> *expr{arg->UnwrapExpr()};
- CHECK(expr != nullptr);
- std::optional<characteristics::TypeAndShape> typeAndShape;
- if (auto type{expr->GetType()}) {
- if (auto shape{GetShape(context, *expr)}) {
- typeAndShape.emplace(*type, std::move(*shape));
+ if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) {
+ std::optional<characteristics::TypeAndShape> typeAndShape;
+ if (auto type{expr->GetType()}) {
+ if (auto shape{GetShape(context, *expr)}) {
+ typeAndShape.emplace(*type, std::move(*shape));
+ } else {
+ typeAndShape.emplace(*type);
+ }
} else {
- typeAndShape.emplace(*type);
+ typeAndShape.emplace(DynamicType::TypelessIntrinsicArgument());
+ }
+ dummyArgs.emplace_back(
+ characteristics::DummyDataObject{std::move(typeAndShape.value())});
+ if (d.typePattern.kindCode == KindCode::same &&
+ !sameDummyArg.has_value()) {
+ sameDummyArg = j;
}
} else {
- typeAndShape.emplace(DynamicType::TypelessIntrinsicArgument());
- }
- dummyArgs.emplace_back(
- characteristics::DummyDataObject{std::move(typeAndShape.value())});
- if (d.typePattern.kindCode == KindCode::same &&
- !sameDummyArg.has_value()) {
- sameDummyArg = j;
+ CHECK(arg->GetAssumedTypeDummy() != nullptr);
}
} else {
// optional argument is absent
}
} else if (name == "loc") {
if (const auto &arg{call.arguments[0]}) {
- ok = GetLastSymbol(arg->UnwrapExpr()) != nullptr;
+ ok = arg->GetAssumedTypeDummy() != nullptr ||
+ GetLastSymbol(arg->UnwrapExpr()) != nullptr;
}
if (!ok) {
messages.Say(
bool DynamicType::operator==(const DynamicType &that) const {
return category_ == that.category_ && kind_ == that.kind_ &&
PointeeComparison(charLength_, that.charLength_) &&
- PointeeComparison(derived_, that.derived_) &&
- isPolymorphic_ == that.isPolymorphic_;
+ PointeeComparison(derived_, that.derived_);
}
bool DynamicType::IsAssumedLengthCharacter() const {
bool DynamicType::IsTypeCompatibleWith(const DynamicType &that) const {
return *this == that || IsUnlimitedPolymorphic() ||
- (isPolymorphic_ && IsAncestorTypeOf(derived_, that.derived_));
+ (IsPolymorphic() && derived_ != nullptr &&
+ IsAncestorTypeOf(derived_, that.derived_));
}
std::optional<DynamicType> DynamicType::From(
*derived, type.category() == semantics::DeclTypeSpec::ClassDerived};
} else if (type.category() == semantics::DeclTypeSpec::ClassStar) {
return DynamicType::UnlimitedPolymorphic();
+ } else if (type.category() == semantics::DeclTypeSpec::TypeStar) {
+ return DynamicType::AssumedType();
} else {
- // Assumed-type dummy arguments (TYPE(*)) do not have dynamic types.
+ common::die("DynamicType::From(DeclTypeSpec): failed");
}
return std::nullopt;
}
}
explicit constexpr DynamicType(
const semantics::DerivedTypeSpec &dt, bool poly = false)
- : category_{TypeCategory::Derived}, derived_{&dt}, isPolymorphic_{poly} {}
+ : category_{TypeCategory::Derived}, derived_{&dt} {}
// A rare use case used for representing the characteristics of an
// intrinsic function like REAL() that accepts a typeless BOZ literal
static constexpr DynamicType UnlimitedPolymorphic() {
DynamicType result;
- result.isPolymorphic_ = true;
+ result.kind_ = 1;
return result; // CLASS(*)
}
+ static constexpr DynamicType AssumedType() {
+ DynamicType result;
+ result.kind_ = 2;
+ return result; // TYPE(*)
+ }
+
// Comparison is deep -- type parameters are compared independently.
bool operator==(const DynamicType &) const;
bool operator!=(const DynamicType &that) const { return !(*this == that); }
constexpr const semantics::ParamValue *charLength() const {
return charLength_;
}
- constexpr bool isPolymorphic() const { return isPolymorphic_; }
std::string AsFortran() const;
std::string AsFortran(std::string &&charLenExpr) const;
DynamicType ResultTypeForMultiply(const DynamicType &) const;
bool IsAssumedLengthCharacter() const;
+ constexpr bool IsPolymorphic() const {
+ return category_ == TypeCategory::Derived && kind_ > 0;
+ }
constexpr bool IsUnlimitedPolymorphic() const {
- return isPolymorphic_ && derived_ == nullptr;
+ return category_ == TypeCategory::Derived && derived_ == nullptr &&
+ kind_ == 1;
+ }
+ constexpr bool IsAssumedType() const {
+ return category_ == TypeCategory::Derived && derived_ == nullptr &&
+ kind_ == 2;
}
constexpr const semantics::DerivedTypeSpec &GetDerivedTypeSpec() const {
CHECK(derived_ != nullptr);
constexpr DynamicType() {}
TypeCategory category_{TypeCategory::Derived}; // overridable default
- int kind_{0}; // set only for intrinsic types
+ int kind_{0}; // for Derived, encodes 1->CLASS(T or *), 2->TYPE(*)
const semantics::ParamValue *charLength_{nullptr};
const semantics::DerivedTypeSpec *derived_{nullptr}; // TYPE(T), CLASS(T)
- bool isPolymorphic_{false}; // CLASS(T), CLASS(*)
};
std::string DerivedTypeSpecAsFortran(const semantics::DerivedTypeSpec &);
}
} else if (auto dyType{DynamicType::From(symbol)}) {
return TypedWrapper<Designator, DataRef>(*dyType, std::move(ref));
- } else if (const auto *declTypeSpec{symbol.GetType()}) {
- if (declTypeSpec->category() == semantics::DeclTypeSpec::TypeStar) {
- Say("TYPE(*) assumed-type dummy argument '%s' may not be "
- "used except as an actual argument"_err_en_US,
- symbol.name());
- }
}
return std::nullopt;
}
pd.u);
}
-static const Symbol *AssumedTypeDummy(const parser::Expr &x) {
+template<typename A> static const Symbol *AssumedTypeDummy(const A &x) {
if (const auto *designator{
std::get_if<common::Indirection<parser::Designator>>(&x.u)}) {
if (const auto *dataRef{
return nullptr;
}
+std::optional<ActualArgument> ExpressionAnalyzer::AnalyzeActualArgument(
+ const parser::Expr &expr) {
+ if (const Symbol * assumedTypeDummy{AssumedTypeDummy(expr)}) {
+ return ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
+ } else if (MaybeExpr argExpr{Analyze(expr)}) {
+ return ActualArgument{Fold(GetFoldingContext(), std::move(*argExpr))};
+ } else {
+ return std::nullopt;
+ }
+}
+
+std::optional<ActualArgument> ExpressionAnalyzer::AnalyzeActualArgument(
+ const parser::Variable &var) {
+ if (const Symbol * assumedTypeDummy{AssumedTypeDummy(var)}) {
+ return ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
+ } else if (MaybeExpr argExpr{Analyze(var)}) {
+ return ActualArgument{std::move(*argExpr)};
+ } else {
+ return std::nullopt;
+ }
+}
+
MaybeExpr ExpressionAnalyzer::Analyze(
const parser::FunctionReference &funcRef) {
// TODO: C1002: Allow a whole assumed-size array to appear if the dummy
ActualArguments arguments;
for (const auto &arg :
std::get<std::list<parser::ActualArgSpec>>(funcRef.v.t)) {
- MaybeExpr actualArgExpr;
- const Symbol *assumedTypeDummy{nullptr};
+ std::optional<ActualArgument> actual;
std::visit(
common::visitors{
[&](const common::Indirection<parser::Expr> &x) {
// TODO: Distinguish & handle procedure name and
// proc-component-ref
- if (!(assumedTypeDummy = AssumedTypeDummy(x.value()))) {
- actualArgExpr = Analyze(x.value());
- }
+ actual = AnalyzeActualArgument(x.value());
},
[&](const parser::AltReturnSpec &) {
Say("alternate return specification may not appear on function reference"_err_en_US);
},
},
std::get<parser::ActualArg>(arg.t).u);
- if (assumedTypeDummy != nullptr) {
- arguments.emplace_back(
- std::make_optional(ActualArgument::AssumedType{*assumedTypeDummy}));
- } else if (actualArgExpr.has_value()) {
- arguments.emplace_back(std::make_optional(
- Fold(GetFoldingContext(), std::move(*actualArgExpr))));
+ if (actual.has_value()) {
+ arguments.emplace_back(std::move(actual));
if (const auto &argKW{std::get<std::optional<parser::Keyword>>(arg.t)}) {
arguments.back()->keyword = argKW->v.source;
}
// Represent %LOC() exactly as if it had been a call to the LOC() extension
// intrinsic function.
// Use the actual source for the name of the call for error reporting.
- if (MaybeExpr arg{Analyze(x.v.value())}) {
+ if (std::optional<ActualArgument> arg{AnalyzeActualArgument(x.v.value())}) {
parser::CharBlock at{GetContextualMessages().at()};
CHECK(at.size() >= 4);
parser::CharBlock loc{at.begin() + 1, 3};
CHECK(loc == "loc");
- return MakeFunctionRef(
- loc, ActualArguments{ActualArgument{std::move(*arg)}});
+ return MakeFunctionRef(loc, ActualArguments{std::move(*arg)});
+ } else {
+ return std::nullopt;
}
- return std::nullopt;
}
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedUnary &) {
MaybeExpr TopLevelChecks(DataRef &&);
std::optional<Expr<SubscriptInteger>> GetSubstringBound(
const std::optional<parser::ScalarIntExpr> &);
-
std::optional<ProcedureDesignator> AnalyzeProcedureComponentRef(
const parser::ProcComponentRef &);
+ std::optional<ActualArgument> AnalyzeActualArgument(const parser::Expr &);
+ std::optional<ActualArgument> AnalyzeActualArgument(const parser::Variable &);
struct CalleeAndArguments {
ProcedureDesignator procedureDesignator;
case common::TypeCategory::Logical:
return context().MakeLogicalType(type.kind());
case common::TypeCategory::Derived:
- return currScope().MakeDerivedType(type.isPolymorphic()
- ? DeclTypeSpec::ClassDerived
- : DeclTypeSpec::TypeDerived,
- DerivedTypeSpec{type.GetDerivedTypeSpec()});
+ if (type.IsAssumedType()) {
+ return currScope().MakeTypeStarType();
+ } else if (type.IsUnlimitedPolymorphic()) {
+ return currScope().MakeClassStarType();
+ } else {
+ return currScope().MakeDerivedType(type.IsPolymorphic()
+ ? DeclTypeSpec::ClassDerived
+ : DeclTypeSpec::TypeDerived,
+ DerivedTypeSpec{type.GetDerivedTypeSpec()});
+ }
case common::TypeCategory::Character:
default: CRASH_NO_CASE;
}
c_long_double_complex = c_long_double
integer, parameter :: c_bool = 1 ! TODO: or default LOGICAL?
- integer, parameter :: c_char = 1 ! TODO: Kanji mode
+ integer, parameter :: c_char = 1
contains
! TODO: Define, or write in C and change this to an interface
end subroutine c_f_pointer
+ function c_loc(x)
+ type(c_ptr) :: c_loc
+ type(*), intent(in) :: x
+ c_loc = c_ptr(loc(x))
+ end function c_loc
+
+ function c_funloc(x)
+ type(c_funptr) :: c_funloc
+ external :: x
+ c_funloc = c_funptr(loc(x))
+ end function c_funloc
+
! TODO c_f_procpointer
- ! TODO c_funcloc
- ! TODO c_loc
! TODO c_sizeof
end module iso_c_binding
projects / platform / upstream / llvm.git / commitdiff