maxjhandsome
/
llvm-project
forked from OSchip/llvm-project
1
0
Fork 0
Code Issues Pull Requests Packages Releases Wiki Activity

[flang] Update preprocessing document, commentary 

Extend documentation on preprocessing

IsSimplyContiguous

basic skeleton

Apply suggested improvements to mod-file.cc

Checks for new call13.f90 (15.4.2.2 explicit interfaces)

Implement checking for procedures that can be called via an implicit interface

Argument checking, test fixing

Better argument checking

Better derived type compatibility checking

Treat externals as if implicitly interfaced

Extend IEEE_EXCEPTIONS module so tests still pass with argument checking

SAME_TYPE_AS and EXTENDS_TYPE_OF intrinsic inquiry functions

Define interfaces for most intrinsic subroutines

Better PASS arguments

More with PASS() argument

Prep for review

address comments

fix comment

Remove formatted expression from specification expression error message per review

more review comments

Original-commit: flang-compiler/f18@3cca775da9
Reviewed-on: https://github.com/flang-compiler/f18/pull/776
This commit is contained in:
peter klausler 2019-09-16 16:58:13 -07:00
parent 143fe79383
commit b32a435b0b
36 changed files with 1306 additions and 307 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
flang/documentation/Preprocessing.md
View File

@ -14,6 +14,8 @@ Behavior common to (nearly) all compilers:
* Fixed form right margin clipping does not apply to directive lines.
* Macro names are not recognized as such when spaces are inserted
into their invocations in fixed form.
This includes spaces at the ends of lines that have been clipped
at column 72 (or whatever).
* Text is rescanned after expansion of macros and arguments.
* Macros are not expanded within quoted character literals or
quoted FORMAT edit descriptors.
@ -74,6 +76,9 @@ Judgement calls, where precedents are unclear:
* IBM claims to be ISO C compliant and therefore recognizes trigraph sequences.
* Fortran comments in macro actual arguments should be respected, on
the principle that a macro call should work like a function reference.
* If a `#define` or `#undef` directive appears among continuation
lines, it may or may not affect text in the continued statement that
appeared before the directive.
Behavior that few compilers properly support (or none), but should:
-------------------------------------------------------------------
@ -98,7 +103,7 @@ In short, a Fortran preprocessor should work as if:
6. Other preprocessing directives are processed and macros expanded.
Along the way, Fortran `INCLUDE` lines and preprocessor `#include` directives
are expanded, and all these steps applied recursively to the introduced text.
7. Any newly-created Fortran comments are removed.
7. Any Fortran comments created by macro replacement are removed.
Steps 5 and 6 are interleaved with respect to the preprocessing state.
Conditional compilation preprocessing directives always reflect only the macro
@ -115,3 +120,100 @@ text.
OpenMP-style directives that look like comments are not addressed by
this scheme but are obvious extensions.
Appendix
========
`N` in the table below means "not supported"; this doesn't
mean a bug, it just means that a particular behavior was
not observed.
`E` signifies "error reported".
The abbreviation `KWM` stands for "keyword macro" and `FLM` means
"function-like macro".
The first block of tests (`pp0*.F`) are all fixed-form source files;
the second block (`pp1*.F90`) are free-form source files.
```
f18
| pgfortran
| | ifort
| | | gfortran
| | | | xlf
| | | | | nagfor
| | | | | |
. . . . . . pp001.F keyword macros
. . . . . . pp002.F #undef
. . . . . . pp003.F function-like macros
. . . . . . pp004.F KWMs case-sensitive
. N . N N . pp005.F KWM split across continuation, implicit padding
. N . N N . pp006.F ditto, but with intervening *comment line
N N N N N N pp007.F KWM split across continuation, clipped after column 72
. . . . . . pp008.F KWM with spaces in name at invocation NOT replaced
. N . N N . pp009.F FLM call split across continuation, implicit padding
. N . N N . pp010.F ditto, but with intervening *comment line
N N N N N N pp011.F FLM call name split across continuation, clipped
. N . N N . pp012.F FLM call name split across continuation
. E . N N . pp013.F FLM call split between name and (
. N . N N . pp014.F FLM call split between name and (, with intervening *comment
. E . N N . pp015.F FLM call split between name and (, clipped
. E . N N . pp016.F FLM call split between name and ( and in argument
. . . . . . pp017.F KLM rescan
. . . . . . pp018.F KLM rescan with #undef (so rescan is after expansion)
. . . . . . pp019.F FLM rescan
. . . . . . pp020.F FLM expansion of argument
. . . . . . pp021.F KWM NOT expanded in 'literal'
. . . . . . pp022.F KWM NOT expanded in "literal"
. . E E . E pp023.F KWM NOT expanded in 9HHOLLERITH literal
. . . E . . pp024.F KWM NOT expanded in Hollerith in FORMAT
. . . . . . pp025.F KWM expansion is before token pasting due to fixed-form space removal
. . . E . E pp026.F ## token pasting works in FLM
E . . E E . pp027.F #DEFINE works in fixed form
. N . N N . pp028.F fixed-form clipping done before KWM expansion on source line
. . . . . . pp029.F \ newline allowed in #define
. . . . . . pp030.F /* C comment */ erased from #define
E E E E E E pp031.F // C++ comment NOT erased from #define
. . . . . . pp032.F /* C comment */ \ newline erased from #define
. . . . . . pp033.F /* C comment \ newline */ erased from #define
. . . . . N pp034.F \ newline allowed in name on KWM definition
. E . E E . pp035.F #if 2 .LT. 3 works
. . . . . . pp036.F #define FALSE TRUE ... .FALSE. -> .TRUE.
N N N N N N pp037.F fixed-form clipping NOT applied to #define
. . E . E E pp038.F FLM call with closing ')' on next line (not a continuation)
E . E . E E pp039.F FLM call with '(' on next line (not a continuation)
. . . . . . pp040.F #define KWM c, then KWM works as comment line initiator
E . E . . E pp041.F use KWM expansion as continuation indicators
N N N . . N pp042.F #define c 1, then use c as label in fixed-form
. . . . N . pp043.F #define with # in column 6 is a continuation line in fixed-form
E . . . . . pp044.F #define directive amid continuations
. . . . . . pp101.F90 keyword macros
. . . . . . pp102.F90 #undef
. . . . . . pp103.F90 function-like macros
. . . . . . pp104.F90 KWMs case-sensitive
. N N N N N pp105.F90 KWM call name split across continuation, with leading &
. N N N N N pp106.F90 ditto, with & ! comment
N N E E N . pp107.F90 KWM call name split across continuation, no leading &, with & ! comment
N N E E N . pp108.F90 ditto, but without & ! comment
. N N N N N pp109.F90 FLM call name split with leading &
. N N N N N pp110.F90 ditto, with & ! comment
N N E E N . pp111.F90 FLM call name split across continuation, no leading &, with & ! comment
N N E E N . pp112.F90 ditto, but without & ! comment
. N N N N E pp113.F90 FLM call split across continuation between name and (, leading &
. N N N N E pp114.F90 ditto, with & ! comment, leading &
N N N N N . pp115.F90 ditto, with & ! comment, no leading &
N N N N N . pp116.F90 FLM call split between name and (, no leading &
. . . . . . pp117.F90 KWM rescan
. . . . . . pp118.F90 KWM rescan with #undef, proving rescan after expansion
. . . . . . pp119.F90 FLM rescan
. . . . . . pp120.F90 FLM expansion of argument
. . . . . . pp121.F90 KWM NOT expanded in 'literal'
. . . . . . pp122.F90 KWM NOT expanded in "literal"
. . E E . E pp123.F90 KWM NOT expanded in Hollerith literal
. . E E . E pp124.F90 KWM NOT expanded in Hollerith in FORMAT
E . . E E . pp125.F90 #DEFINE works in free form
. . . . . . pp126.F90 \ newline works in #define
N . E . E E pp127.F90 FLM call with closing ')' on next line (not a continuation)
E . E . E E pp128.F90 FLM call with '(' on next line (not a continuation)
. . N . . N pp129.F90 #define KWM !, then KWM works as comment line initiator
E . E . . E pp130.F90 #define KWM &, use for continuation w/o pasting (ifort and nag seem to continue #define)
```

6
flang/lib/common/constexpr-bitset.h
View File

@ -1,4 +1,4 @@
// Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
// Copyright (c) 2018-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.
@ -92,9 +92,9 @@ public:
}
constexpr bool operator==(BitSet &&that) const { return bits_ == that.bits_; }
constexpr bool operator!=(const BitSet &that) const {
return bits_ == that.bits_;
return bits_ != that.bits_;
}
constexpr bool operator!=(BitSet &&that) const { return bits_ == that.bits_; }
constexpr bool operator!=(BitSet &&that) const { return bits_ != that.bits_; }
static constexpr std::size_t size() { return BITS; }
constexpr bool test(std::size_t x) const {

1
flang/lib/evaluate/CMakeLists.txt
View File

@ -15,6 +15,7 @@
add_library(FortranEvaluate
call.cc
characteristics.cc
check-call.cc
check-expression.cc
common.cc
complex.cc

5
flang/lib/evaluate/call.cc
View File

@ -44,6 +44,8 @@ ActualArgument &ActualArgument::operator=(Expr<SomeType> &&expr) {
std::optional<DynamicType> ActualArgument::GetType() const {
if (const Expr<SomeType> *expr{UnwrapExpr()}) {
return expr->GetType();
} else if (std::holds_alternative<AssumedType>(u_)) {
return DynamicType::AssumedType();
} else {
return std::nullopt;
}
@ -98,7 +100,8 @@ int ProcedureDesignator::Rank() const {
if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
if (const auto &result{intrinsic->characteristics.value().functionResult}) {
if (const auto *typeAndShape{result->GetTypeAndShape()}) {
CHECK(!typeAndShape->IsAssumedRank());
CHECK(!typeAndShape->attrs().test(
characteristics::TypeAndShape::Attr::AssumedRank));
return typeAndShape->Rank();
}
}

179
flang/lib/evaluate/characteristics.cc
View File

@ -13,11 +13,14 @@
// limitations under the License.
#include "characteristics.h"
#include "check-expression.h"
#include "fold.h"
#include "intrinsics.h"
#include "tools.h"
#include "type.h"
#include "../common/indirection.h"
#include "../parser/message.h"
#include "../semantics/scope.h"
#include "../semantics/symbol.h"
#include <initializer_list>
#include <ostream>
@ -38,8 +41,7 @@ static void CopyAttrs(const semantics::Symbol &src, A &dst,
}
bool TypeAndShape::operator==(const TypeAndShape &that) const {
return type_ == that.type_ && shape_ == that.shape_ &&
isAssumedRank_ == that.isAssumedRank_;
return type_ == that.type_ && shape_ == that.shape_ && attrs_ == that.attrs_;
}
std::optional<TypeAndShape> TypeAndShape::Characterize(
@ -98,20 +100,43 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
bool TypeAndShape::IsCompatibleWith(
parser::ContextualMessages &messages, const TypeAndShape &that) const {
const auto &len{that.LEN()};
if (!type_.IsTypeCompatibleWith(that.type_)) {
std::stringstream lenstr;
if (len) {
len->AsFortran(lenstr);
}
messages.Say("Target type '%s' is not compatible with '%s'"_err_en_US,
that.type_.AsFortran(), type_.AsFortran());
that.type_.AsFortran(lenstr.str()), type_.AsFortran());
return false;
}
if (auto myLEN{ToInt64(LEN())}) {
if (auto thatLEN{ToInt64(len)}) {
if (*thatLEN < *myLEN) {
messages.Say(
"Warning: effective length '%jd' is less than expected length '%jd'"_en_US,
*thatLEN, *myLEN);
}
}
}
return CheckConformance(messages, shape_, that.shape_);
}
void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) {
CHECK(shape_.empty() && !isAssumedRank_);
CHECK(shape_.empty() && !attrs_.test(Attr::AssumedRank));
if (object.IsAssumedRank()) {
isAssumedRank_ = true;
attrs_.set(Attr::AssumedRank);
return;
}
if (object.IsAssumedShape()) {
attrs_.set(Attr::AssumedShape);
}
if (object.IsAssumedSize()) {
attrs_.set(Attr::AssumedSize);
}
if (object.IsCoarray()) {
attrs_.set(Attr::Coarray);
}
for (const semantics::ShapeSpec &dim : object.shape()) {
if (dim.ubound().GetExplicit().has_value()) {
Expr<SubscriptInteger> extent{*dim.ubound().GetExplicit()};
@ -127,8 +152,23 @@ void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) {
}
}
void TypeAndShape::AcquireLEN() {
if (type_.category() == TypeCategory::Character) {
if (const auto *param{type_.charLength()}) {
if (const auto &intExpr{param->GetExplicit()}) {
LEN_ = *intExpr;
}
}
}
}
std::ostream &TypeAndShape::Dump(std::ostream &o) const {
o << type_.AsFortran();
std::stringstream LENstr;
if (LEN_.has_value()) {
LEN_->AsFortran(LENstr);
}
o << type_.AsFortran(LENstr.str());
attrs_.Dump(o, EnumToString);
if (!shape_.empty()) {
o << " dimension(";
char sep{'('};
@ -142,8 +182,6 @@ std::ostream &TypeAndShape::Dump(std::ostream &o) const {
}
}
o << ')';
} else if (isAssumedRank_) {
o << " dimension(*)";
}
return o;
}
@ -181,13 +219,34 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
CHECK(result.intent == common::Intent::Default);
result.intent = common::Intent::InOut;
}
// TODO: acquire coshape when symbol table represents it
return result;
}
}
return std::nullopt;
}
bool DummyDataObject::CanBePassedViaImplicitInterface() const {
if ((attrs &
Attrs{Attr::Allocatable, Attr::Asynchronous, Attr::Optional,
Attr::Pointer, Attr::Target, Attr::Value, Attr::Volatile})
.any()) {
return false; // 15.4.2.2(3)(a)
} else if ((type.attrs() &
TypeAndShape::Attrs{TypeAndShape::Attr::AssumedShape,
TypeAndShape::Attr::AssumedRank,
TypeAndShape::Attr::Coarray})
.any()) {
return false; // 15.4.2.2(3)(b-d)
} else if (type.type().IsPolymorphic()) {
return false; // 15.4.2.2(3)(f)
} else if (type.type().category() == TypeCategory::Derived) {
if (!type.type().GetDerivedTypeSpec().parameters().empty()) {
return false; // 15.4.2.2(3)(e)
}
}
return true;
}
std::ostream &DummyDataObject::Dump(std::ostream &o) const {
attrs.Dump(o, EnumToString);
if (intent != common::Intent::Default) {
@ -279,6 +338,14 @@ void DummyArgument::SetOptional(bool value) {
u);
}
bool DummyArgument::CanBePassedViaImplicitInterface() const {
if (const auto *object{std::get_if<DummyDataObject>(&u)}) {
return object->CanBePassedViaImplicitInterface();
} else {
return true;
}
}
std::ostream &DummyArgument::Dump(std::ostream &o) const {
if (!name.empty()) {
o << name << '=';
@ -328,6 +395,45 @@ bool FunctionResult::IsAssumedLengthCharacter() const {
}
}
bool FunctionResult::CanBeReturnedViaImplicitInterface() const {
if (attrs.test(Attr::Pointer) || attrs.test(Attr::Allocatable)) {
return false; // 15.4.2.2(4)(b)
} else if (const auto *typeAndShape{GetTypeAndShape()}) {
if (typeAndShape->Rank() > 0) {
return false; // 15.4.2.2(4)(a)
} else {
const DynamicType &type{typeAndShape->type()};
switch (type.category()) {
case TypeCategory::Character:
if (!type.IsAssumedLengthCharacter()) {
if (const auto *param{type.charLength()}) {
if (const auto &expr{param->GetExplicit()}) {
return IsConstantExpr(*expr); // 15.4.2.2(4)(c)
}
}
}
return false;
case TypeCategory::Derived:
if (!type.IsPolymorphic()) {
const auto &spec{type.GetDerivedTypeSpec()};
for (const auto &pair : spec.parameters()) {
if (const auto &expr{pair.second.GetExplicit()}) {
if (!IsConstantExpr(*expr)) {
return false; // 15.4.2.2(4)(c)
}
}
}
return true;
}
return false;
default: return true;
}
}
} else {
return false; // 15.4.2.2(4)(b) - procedure pointer
}
}
std::ostream &FunctionResult::Dump(std::ostream &o) const {
attrs.Dump(o, EnumToString);
std::visit(
@ -360,6 +466,15 @@ std::optional<Procedure> Procedure::Characterize(
{semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
{semantics::Attr::BIND_C, Procedure::Attr::BindC},
});
auto SetFunctionResult{[&](const semantics::DeclTypeSpec *type) {
if (type != nullptr) {
if (auto resultType{DynamicType::From(*type)}) {
result.functionResult = FunctionResult{*resultType};
return true;
}
}
return false;
}};
return std::visit(
common::visitors{
[&](const semantics::SubprogramDetails &subp)
@ -400,15 +515,9 @@ std::optional<Procedure> Procedure::Characterize(
} else {
result.attrs.set(Procedure::Attr::ImplicitInterface);
if (symbol.test(semantics::Symbol::Flag::Function)) {
const semantics::DeclTypeSpec *type{interface.type()};
if (!type) {
if (!SetFunctionResult(interface.type())) {
return std::nullopt;
}
auto resultType{DynamicType::From(*type)};
if (!resultType) {
return std::nullopt;
}
result.functionResult = FunctionResult{*resultType};
} else {
// subroutine, not function
if (interface.type() != nullptr) {
@ -443,6 +552,40 @@ std::optional<Procedure> Procedure::Characterize(
symbol.details());
}
std::optional<Procedure> Procedure::Characterize(
const ProcedureDesignator &proc, const IntrinsicProcTable &intrinsics) {
if (const auto *symbol{proc.GetSymbol()}) {
if (auto result{characteristics::Procedure::Characterize(
symbol->GetUltimate(), intrinsics)}) {
return result;
}
} else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
return intrinsic->characteristics.value();
}
return std::nullopt;
}
std::optional<Procedure> Procedure::Characterize(
const ProcedureRef &ref, const IntrinsicProcTable &intrinsics) {
return Characterize(ref.proc(), intrinsics);
}
bool Procedure::CanBeCalledViaImplicitInterface() const {
if (attrs.test(Attr::Elemental) || attrs.test(Attr::BindC)) {
return false; // 15.4.2.2(5,6)
} else if (IsFunction() &&
!functionResult->CanBeReturnedViaImplicitInterface()) {
return false;
} else {
for (const DummyArgument &arg : dummyArguments) {
if (!arg.CanBePassedViaImplicitInterface()) {
return false;
}
}
return true;
}
}
std::ostream &Procedure::Dump(std::ostream &o) const {
attrs.Dump(o, EnumToString);
if (functionResult.has_value()) {
@ -722,7 +865,9 @@ bool DistinguishUtils::IsTkrCompatible(
bool DistinguishUtils::IsTkrCompatible(
const TypeAndShape &x, const TypeAndShape &y) {
return x.type().IsTkCompatibleWith(y.type()) &&
(x.IsAssumedRank() || y.IsAssumedRank() || x.Rank() == y.Rank());
(x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
y.attrs().test(TypeAndShape::Attr::AssumedRank) ||
x.Rank() == y.Rank());
}
// Return the argument at the given index, ignoring the passed arg

52
flang/lib/evaluate/characteristics.h
View File

@ -54,10 +54,18 @@ bool DistinguishableOpOrAssign(const Procedure &, const Procedure &);
class TypeAndShape {
public:
explicit TypeAndShape(DynamicType t) : type_{t} {}
TypeAndShape(DynamicType t, int rank) : type_{t}, shape_(rank) {}
TypeAndShape(DynamicType t, Shape &&s) : type_{t}, shape_{std::move(s)} {}
ENUM_CLASS(Attr, AssumedRank, AssumedShape, AssumedSize, Coarray)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
explicit TypeAndShape(DynamicType t) : type_{t} { AcquireLEN(); }
TypeAndShape(DynamicType t, int rank) : type_{t}, shape_(rank) {
AcquireLEN();
}
TypeAndShape(DynamicType t, Shape &&s) : type_{t}, shape_{std::move(s)} {
AcquireLEN();
}
DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(TypeAndShape)
bool operator==(const TypeAndShape &) const;
static std::optional<TypeAndShape> Characterize(const semantics::Symbol &);
static std::optional<TypeAndShape> Characterize(
@ -78,9 +86,14 @@ public:
type_ = t;
return *this;
}
const std::optional<Expr<SomeInteger>> &LEN() const { return LEN_; }
TypeAndShape &set_LEN(Expr<SomeInteger> &&len) {
LEN_ = std::move(len);
return *this;
}
const Shape &shape() const { return shape_; }
const Attrs &attrs() const { return attrs_; }
bool IsAssumedRank() const { return isAssumedRank_; }
int Rank() const { return GetRank(shape_); }
bool IsCompatibleWith(
parser::ContextualMessages &, const TypeAndShape &) const;
@ -89,13 +102,34 @@ public:
private:
void AcquireShape(const semantics::ObjectEntityDetails &);
void AcquireLEN();
protected:
DynamicType type_;
std::optional<Expr<SomeInteger>> LEN_;
Shape shape_;
bool isAssumedRank_{false};
Attrs attrs_;
};
template<typename T>
std::optional<TypeAndShape> GetTypeAndShape(
const Expr<T> &expr, FoldingContext &context) {
if (auto type{expr.GetType()}) {
if (auto shape{GetShape(context, expr)}) {
TypeAndShape result{*type, std::move(*shape)};
if (type->category() == TypeCategory::Character) {
if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(expr)}) {
if (auto length{chExpr->LEN()}) {
result.set_LEN(Expr<SomeInteger>{std::move(*length)});
}
}
}
return result;
}
}
return std::nullopt;
}
// 15.3.2.2
struct DummyDataObject {
ENUM_CLASS(Attr, Optional, Allocatable, Asynchronous, Contiguous, Value,
@ -107,6 +141,7 @@ struct DummyDataObject {
explicit DummyDataObject(DynamicType t) : type{t} {}
bool operator==(const DummyDataObject &) const;
static std::optional<DummyDataObject> Characterize(const semantics::Symbol &);
bool CanBePassedViaImplicitInterface() const;
std::ostream &Dump(std::ostream &) const;
TypeAndShape type;
std::vector<Expr<SubscriptInteger>> coshape;
@ -146,6 +181,7 @@ struct DummyArgument {
const semantics::Symbol &, const IntrinsicProcTable &);
bool IsOptional() const;
void SetOptional(bool = true);
bool CanBePassedViaImplicitInterface() const;
std::ostream &Dump(std::ostream &) const;
// name and pass are not characteristics and so does not participate in
// operator== but are needed to determine if procedures are distinguishable
@ -181,6 +217,7 @@ struct FunctionResult {
return std::get_if<TypeAndShape>(&u);
}
void SetType(DynamicType t) { std::get<TypeAndShape>(u).set_type(t); }
bool CanBeReturnedViaImplicitInterface() const;
std::ostream &Dump(std::ostream &) const;
@ -201,6 +238,10 @@ struct Procedure {
// "unrestricted specific intrinsic function".
static std::optional<Procedure> Characterize(
const semantics::Symbol &, const IntrinsicProcTable &);
static std::optional<Procedure> Characterize(
const ProcedureDesignator &, const IntrinsicProcTable &);
static std::optional<Procedure> Characterize(
const ProcedureRef &, const IntrinsicProcTable &);
bool IsFunction() const { return functionResult.has_value(); }
bool IsSubroutine() const { return !IsFunction(); }
@ -210,6 +251,7 @@ struct Procedure {
bool HasExplicitInterface() const {
return !attrs.test(Attr::ImplicitInterface);
}
bool CanBeCalledViaImplicitInterface() const;
std::ostream &Dump(std::ostream &) const;
std::optional<FunctionResult> functionResult;

199
flang/lib/evaluate/check-call.cc Normal file
View File

@ -0,0 +1,199 @@
// 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.
#include "check-call.h"
#include "characteristics.h"
#include "shape.h"
#include "tools.h"
#include "../parser/message.h"
#include <map>
#include <string>
using namespace Fortran::parser::literals;
namespace Fortran::evaluate {
static void CheckImplicitInterfaceArg(
ActualArgument &arg, parser::ContextualMessages &messages) {
if (const auto &kw{arg.keyword}) {
messages.Say(*kw,
"Keyword '%s=' cannot appear in a reference to a procedure with an implicit interface"_err_en_US,
*kw);
}
if (auto type{arg.GetType()}) {
if (type->IsAssumedType()) {
messages.Say(
"Assumed type argument requires an explicit interface"_err_en_US);
} else if (type->IsPolymorphic()) {
messages.Say(
"Polymorphic argument requires an explicit interface"_err_en_US);
} else if (type->category() == TypeCategory::Derived) {
auto &derived{type->GetDerivedTypeSpec()};
if (!derived.parameters().empty()) {
messages.Say(
"Parameterized derived type argument requires an explicit interface"_err_en_US);
}
}
}
if (const auto *expr{arg.UnwrapExpr()}) {
if (auto named{ExtractNamedEntity(*expr)}) {
const semantics::Symbol &symbol{named->GetLastSymbol()};
if (symbol.Corank() > 0) {
messages.Say(
"Coarray argument requires an explicit interface"_err_en_US);
}
if (const auto *details{
symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
if (details->IsAssumedRank()) {
messages.Say(
"Assumed rank argument requires an explicit interface"_err_en_US);
}
}
if (symbol.attrs().test(semantics::Attr::ASYNCHRONOUS)) {
messages.Say(
"ASYNCHRONOUS argument requires an explicit interface"_err_en_US);
}
if (symbol.attrs().test(semantics::Attr::VOLATILE)) {
messages.Say(
"VOLATILE argument requires an explicit interface"_err_en_US);
}
}
}
}
static void CheckExplicitInterfaceArg(const ActualArgument &arg,
const characteristics::DummyArgument &dummy, FoldingContext &context) {
std::visit(
common::visitors{
[&](const characteristics::DummyDataObject &object) {
if (const auto *expr{arg.UnwrapExpr()}) {
if (auto type{characteristics::GetTypeAndShape(*expr, context)}) {
object.type.IsCompatibleWith(context.messages(), *type);
} else {
// TODO
}
} else {
// TODO
}
},
[&](const characteristics::DummyProcedure &) {
// TODO check effective procedure compatibility
},
[&](const characteristics::AlternateReturn &) {
// TODO check alternate return
},
},
dummy.u);
}
static void RearrangeArguments(const characteristics::Procedure &proc,
ActualArguments &actuals, parser::ContextualMessages &messages) {
CHECK(proc.HasExplicitInterface());
if (actuals.size() < proc.dummyArguments.size()) {
actuals.resize(proc.dummyArguments.size());
} else if (actuals.size() > proc.dummyArguments.size()) {
messages.Say(
"Too many actual arguments (%zd) passed to procedure that expects only %zd"_err_en_US,
actuals.size(), proc.dummyArguments.size());
}
std::map<std::string, ActualArgument> kwArgs;
for (auto &x : actuals) {
if (x.has_value()) {
if (x->keyword.has_value()) {
auto emplaced{
kwArgs.try_emplace(x->keyword->ToString(), std::move(*x))};
if (!emplaced.second) {
messages.Say(*x->keyword,
"Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US,
*x->keyword);
}
x.reset();
}
}
}
if (!kwArgs.empty()) {
int index{0};
for (const auto &dummy : proc.dummyArguments) {
if (!dummy.name.empty()) {
auto iter{kwArgs.find(dummy.name)};
if (iter != kwArgs.end()) {
ActualArgument &x{iter->second};
if (actuals[index].has_value()) {
messages.Say(*x.keyword,
"Keyword argument '%s=' has already been specified positionally (#%d) in this procedure reference"_err_en_US,
*x.keyword, index + 1);
} else {
actuals[index] = std::move(x);
}
kwArgs.erase(iter);
}
}
++index;
}
for (auto &bad : kwArgs) {
ActualArgument &x{bad.second};
messages.Say(*x.keyword,
"Argument keyword '%s=' is not recognized for this procedure reference"_err_en_US,
*x.keyword);
}
}
}
void CheckArguments(const characteristics::Procedure &proc,
ActualArguments &actuals, FoldingContext &context,
bool treatingExternalAsImplicit) {
parser::Messages buffer;
parser::ContextualMessages messages{context.messages().at(), &buffer};
FoldingContext localContext{context, messages};
if (proc.HasExplicitInterface()) {
RearrangeArguments(proc, actuals, messages);
int index{0};
for (auto &x : actuals) {
const auto &dummy{proc.dummyArguments[index++]};
if (x.has_value()) {
CheckExplicitInterfaceArg(*x, dummy, localContext);
} else if (!dummy.IsOptional()) {
if (dummy.name.empty()) {
messages.Say(
"Dummy argument #%d is not OPTIONAL and is not associated with an effective argument in this procedure reference"_err_en_US,
index);
} else {
messages.Say(
"Dummy argument '%s' (#%d) is not OPTIONAL and is not associated with an effective argument in this procedure reference"_err_en_US,
dummy.name, index);
}
}
if (treatingExternalAsImplicit) {
CheckImplicitInterfaceArg(*x, context.messages());
}
}
} else {
for (auto &x : actuals) {
if (x.has_value()) {
CheckImplicitInterfaceArg(*x, context.messages());
}
}
}
if (!buffer.empty()) {
if (treatingExternalAsImplicit) {
if (auto *msg{context.messages().Say(
"Warning: if the procedure's interface were explicit, this reference would be in error:"_en_US)}) {
buffer.AttachTo(*msg);
}
} else if (auto *msgs{context.messages().messages()}) {
msgs->Merge(std::move(buffer));
}
}
}
}

39
flang/lib/evaluate/check-call.h Normal file
View File

@ -0,0 +1,39 @@
// 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.
// Constraint checking for procedure references
#ifndef FORTRAN_EVALUATE_CHECK_CALL_H_
#define FORTRAN_EVALUATE_CHECK_CALL_H_
#include "call.h"
namespace Fortran::parser {
class ContextualMessages;
}
namespace Fortran::evaluate::characteristics {
struct Procedure;
}
namespace Fortran::evaluate {
class FoldingContext;
// The Boolean flag argument should be true when the called procedure
// does not actually have an explicit interface at the call site, but
// its characteristics are known because it is a subroutine or function
// defined at the top level in the same source file.
void CheckArguments(const characteristics::Procedure &, ActualArguments &,
FoldingContext &, bool treatingExternalAsImplicit = false);
}
#endif

135
flang/lib/evaluate/check-expression.cc
View File

@ -14,6 +14,7 @@
#include "check-expression.h"
#include "traverse.h"
#include "type.h"
#include "../semantics/symbol.h"
#include "../semantics/tools.h"
@ -34,8 +35,7 @@ public:
using Base::operator();
template<int KIND> bool operator()(const TypeParamInquiry<KIND> &inq) const {
return inq.parameter().template get<semantics::TypeParamDetails>().attr() ==
common::TypeParamAttr::Kind;
return IsKindTypeParameter(inq.parameter());
}
bool operator()(const semantics::Symbol &symbol) const {
return IsNamedConstant(symbol);
@ -70,24 +70,44 @@ template<typename A> bool IsConstantExpr(const A &x) {
return IsConstantExprHelper{}(x);
}
template bool IsConstantExpr(const Expr<SomeType> &);
template bool IsConstantExpr(const Expr<SomeInteger> &);
// Object pointer initialization checking predicate IsInitialDataTarget().
// This code determines whether an expression is allowable as the static
// data address used to initialize a pointer with "=> x". See C765.
// The caller is responsible for checking the base object symbol's
// characteristics (TARGET, SAVE, &c.) since this code can't use GetUltimate().
struct IsInitialDataTargetHelper
: public AllTraverse<IsInitialDataTargetHelper> {
using Base = AllTraverse<IsInitialDataTargetHelper>;
using Base::operator();
IsInitialDataTargetHelper() : Base{*this} {}
explicit IsInitialDataTargetHelper(parser::ContextualMessages &m)
: Base{*this}, messages_{m} {}
bool operator()(const BOZLiteralConstant &) const { return false; }
bool operator()(const NullPointer &) const { return true; }
template<typename T> bool operator()(const Constant<T> &) const {
return false;
}
bool operator()(const semantics::Symbol &) const { return true; }
bool operator()(const semantics::Symbol &symbol) const {
const Symbol &ultimate{symbol.GetUltimate()};
if (IsAllocatable(ultimate)) {
messages_.Say(
"An initial data target may not be a reference to an ALLOCATABLE '%s'"_err_en_US,
ultimate.name());
} else if (ultimate.Corank() > 0) {
messages_.Say(
"An initial data target may not be a reference to a coarray '%s'"_err_en_US,
ultimate.name());
} else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {
messages_.Say(
"An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
ultimate.name());
} else if (!IsSaved(ultimate)) {
messages_.Say(
"An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
ultimate.name());
}
return true;
}
bool operator()(const StaticDataObject &) const { return false; }
template<int KIND> bool operator()(const TypeParamInquiry<KIND> &) const {
return false;
@ -125,10 +145,14 @@ struct IsInitialDataTargetHelper
return (*this)(x.left());
}
bool operator()(const Relational<SomeType> &) const { return false; }
private:
parser::ContextualMessages &messages_;
};
bool IsInitialDataTarget(const Expr<SomeType> &x) {
return IsInitialDataTargetHelper{}(x);
bool IsInitialDataTarget(
const Expr<SomeType> &x, parser::ContextualMessages &messages) {
return IsInitialDataTargetHelper{messages}(x);
}
// Specification expression validation (10.1.11(2), C1010)
@ -222,11 +246,7 @@ template<typename A>
void CheckSpecificationExpr(const A &x, parser::ContextualMessages &messages,
const semantics::Scope &scope) {
if (auto why{CheckSpecificationExprHelper{scope}(x)}) {
std::stringstream ss;
ss << x;
messages.Say("The expression (%s) cannot be used as a "
"specification expression (%s)"_err_en_US,
ss.str(), *why);
messages.Say("Invalid specification expression: %s"_err_en_US, *why);
}
}
@ -237,4 +257,93 @@ template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
template void CheckSpecificationExpr(
const std::optional<Expr<SubscriptInteger>> &, parser::ContextualMessages &,
const semantics::Scope &);
// IsSimplyContiguous() -- 9.5.4
class IsSimplyContiguousHelper
: public AnyTraverse<IsSimplyContiguousHelper, std::optional<bool>> {
public:
using Result = std::optional<bool>; // tri-state
using Base = AnyTraverse<IsSimplyContiguousHelper, Result>;
explicit IsSimplyContiguousHelper(const IntrinsicProcTable &t)
: Base{*this}, table_{t} {}
using Base::operator();
Result operator()(const semantics::Symbol &symbol) const {
if (symbol.attrs().test(semantics::Attr::CONTIGUOUS)) {
return true;
} else if (semantics::IsPointer(symbol)) {
return false;
} else if (const auto *details{
symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
return !details->IsAssumedShape() && !details->IsAssumedRank();
} else {
return false;
}
}
Result operator()(const ArrayRef &x) const {
if (x.base().Rank() > 0 || !CheckSubscripts(x.subscript())) {
return false;
} else {
return (*this)(x.base());
}
}
Result operator()(const CoarrayRef &x) const {
return CheckSubscripts(x.subscript());
}
Result operator()(const Component &) const { return false; }
Result operator()(const ComplexPart &) const { return false; }
Result operator()(const Substring &) const { return false; }
template<typename T> Result operator()(const FunctionRef<T> &x) const {
if (auto chars{
characteristics::Procedure::Characterize(x.proc(), table_)}) {
if (chars->functionResult.has_value()) {
const auto &result{*chars->functionResult};
return !result.IsProcedurePointer() &&
result.attrs.test(characteristics::FunctionResult::Attr::Pointer) &&
result.attrs.test(
characteristics::FunctionResult::Attr::Contiguous);
}
}
return false;
}
private:
static bool CheckSubscripts(const std::vector<Subscript> &subscript) {
bool anyTriplet{false};
for (auto j{subscript.size()}; j-- > 0;) {
if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
if (!triplet->IsStrideOne()) {
return false;
} else if (anyTriplet) {
if (triplet->lower().has_value() || triplet->upper().has_value()) {
return false; // all triplets before the last one must be just ":"
}
} else {
anyTriplet = true;
}
} else if (anyTriplet || subscript[j].Rank() > 0) {
return false;
}
}
return true;
}
const IntrinsicProcTable &table_;
};
template<typename A>
bool IsSimplyContiguous(const A &x, const IntrinsicProcTable &table) {
if (IsVariable(x)) {
if (auto known{IsSimplyContiguousHelper{table}(x)}) {
return *known;
}
}
return false;
}
template bool IsSimplyContiguous(
const Expr<SomeType> &, const IntrinsicProcTable &);
}

13
flang/lib/evaluate/check-expression.h
View File

@ -29,16 +29,18 @@ class Scope;
}
namespace Fortran::evaluate {
class IntrinsicProcTable;
// Predicate: true when an expression is a constant expression (in the
// strict sense of the Fortran standard); it may not (yet) be a hard
// constant value.
template<typename A> bool IsConstantExpr(const A &);
extern template bool IsConstantExpr(const Expr<SomeType> &);
extern template bool IsConstantExpr(const Expr<SomeInteger> &);
// Predicate: true when an expression is an object designator with
// Checks whether an expression is an object designator with
// constant addressing and no vector-valued subscript.
bool IsInitialDataTarget(const Expr<SomeType> &);
bool IsInitialDataTarget(const Expr<SomeType> &, parser::ContextualMessages &);
// Check whether an expression is a specification expression
// (10.1.11(2), C1010). Constant expressions are always valid
@ -54,5 +56,12 @@ extern template void CheckSpecificationExpr(
extern template void CheckSpecificationExpr(
const std::optional<Expr<SubscriptInteger>> &x,
parser::ContextualMessages &, const semantics::Scope &);
// Simple contiguity (9.5.4)
template<typename A>
bool IsSimplyContiguous(const A &, const IntrinsicProcTable &);
extern template bool IsSimplyContiguous(
const Expr<SomeType> &, const IntrinsicProcTable &);
}
#endif

34
flang/lib/evaluate/formatting.cc
View File

@ -440,26 +440,24 @@ std::string SomeDerived::AsFortran() const {
}
std::string DerivedTypeSpecAsFortran(const semantics::DerivedTypeSpec &spec) {
if (spec.HasActualParameters()) {
std::stringstream ss;
ss << spec.name().ToString();
char ch{'('};
for (const auto &[name, value] : spec.parameters()) {
ss << ch << name.ToString() << '=';
ch = ',';
if (value.isAssumed()) {
ss << '*';
} else if (value.isDeferred()) {
ss << ':';
} else {
value.GetExplicit()->AsFortran(ss);
}
std::stringstream ss;
ss << spec.name().ToString();
char ch{'('};
for (const auto &[name, value] : spec.parameters()) {
ss << ch << name.ToString() << '=';
ch = ',';
if (value.isAssumed()) {
ss << '*';
} else if (value.isDeferred()) {
ss << ':';
} else {
value.GetExplicit()->AsFortran(ss);
}
ss << ')';
return ss.str();
} else {
return spec.name().ToString();
}
if (ch != '(') {
ss << ')';
}
return ss.str();
}
std::ostream &EmitVar(std::ostream &o, const Symbol &symbol) {

159
flang/lib/evaluate/intrinsics.cc
View File

@ -67,10 +67,10 @@ static constexpr CategorySet IntOrRealType{IntType | RealType};
static constexpr CategorySet FloatingType{RealType | ComplexType};
static constexpr CategorySet NumericType{IntType | RealType | ComplexType};
static constexpr CategorySet RelatableType{IntType | RealType | CharType};
static constexpr CategorySet DerivedType{TypeCategory::Derived};
static constexpr CategorySet IntrinsicType{
IntType | RealType | ComplexType | CharType | LogicalType};
static constexpr CategorySet AnyType{
IntrinsicType | CategorySet{TypeCategory::Derived}};
static constexpr CategorySet AnyType{IntrinsicType | DerivedType};
ENUM_CLASS(KindCode, none, defaultIntegerKind,
defaultRealKind, // is also the default COMPLEX kind
@ -123,7 +123,8 @@ static constexpr TypePattern AnyChar{CharType, KindCode::any};
static constexpr TypePattern AnyLogical{LogicalType, KindCode::any};
static constexpr TypePattern AnyRelatable{RelatableType, KindCode::any};
static constexpr TypePattern AnyIntrinsic{IntrinsicType, KindCode::any};
static constexpr TypePattern Anything{AnyType, KindCode::any};
static constexpr TypePattern ExtensibleDerived{DerivedType, KindCode::any};
static constexpr TypePattern AnyData{AnyType, KindCode::any};
// Type is irrelevant, but not BOZ (for PRESENT(), OPTIONAL(), &c.)
static constexpr TypePattern Addressable{AnyType, KindCode::addressable};
@ -264,8 +265,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{"aint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal},
{"all", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical,
Rank::dimReduced},
{"allocated", {{"array", Anything, Rank::array}}, DefaultLogical},
{"allocated", {{"scalar", Anything, Rank::scalar}}, DefaultLogical},
{"allocated", {{"array", AnyData, Rank::array}}, DefaultLogical},
{"allocated", {{"scalar", AnyData, Rank::scalar}}, DefaultLogical},
{"anint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal},
{"any", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical,
Rank::dimReduced},
@ -378,6 +379,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{"erfc_scaled", {{"x", SameReal}}, SameReal},
{"exp", {{"x", SameFloating}}, SameFloating},
{"exponent", {{"x", AnyReal}}, DefaultInt},
{"extends_type_of",
{{"a", ExtensibleDerived, Rank::anyOrAssumedRank},
{"mold", ExtensibleDerived, Rank::anyOrAssumedRank}},
DefaultLogical, Rank::scalar},
{"findloc",
{{"array", AnyNumeric, Rank::array},
{"value", AnyNumeric, Rank::scalar}, RequiredDIM, OptionalMASK,
@ -455,11 +460,11 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{"is_iostat_eor", {{"i", AnyInt}}, DefaultLogical},
{"kind", {{"x", AnyIntrinsic}}, DefaultInt},
{"lbound",
{{"array", Anything, Rank::anyOrAssumedRank}, RequiredDIM,
{{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM,
SubscriptDefaultKIND},
KINDInt, Rank::scalar},
{"lbound",
{{"array", Anything, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
{{"array", AnyData, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
KINDInt, Rank::vector},
{"leadz", {{"i", AnyInt}}, DefaultInt},
{"len", {{"string", AnyChar, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
@ -587,7 +592,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
Rank::scalar},
{"range", {{"x", AnyNumeric, Rank::anyOrAssumedRank}}, DefaultInt,
Rank::scalar},
{"rank", {{"a", Anything, Rank::anyOrAssumedRank}}, DefaultInt,
{"rank", {{"a", AnyData, Rank::anyOrAssumedRank}}, DefaultInt,
Rank::scalar},
{"real", {{"a", AnyNumeric, Rank::elementalOrBOZ}, DefaultingKIND},
KINDReal},
@ -605,6 +610,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{"order", AnyInt, Rank::vector, Optionality::optional}},
SameType, Rank::shaped},
{"rrspacing", {{"x", SameReal}}, SameReal},
{"same_type_as",
{{"a", ExtensibleDerived, Rank::anyOrAssumedRank},
{"b", ExtensibleDerived, Rank::anyOrAssumedRank}},
DefaultLogical, Rank::scalar},
{"scale", {{"x", SameReal}, {"i", AnyInt}}, SameReal},
{"scan",
{{"string", SameChar}, {"set", SameChar},
@ -632,7 +641,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
DefaultInt, Rank::scalar},
{"set_exponent", {{"x", SameReal}, {"i", AnyInt}}, SameReal},
{"shape",
{{"source", Anything, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
{{"source", AnyData, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
KINDInt, Rank::vector},
{"shifta", {{"i", SameInt}, {"shift", AnyInt}}, SameInt},
{"shiftl", {{"i", SameInt}, {"shift", AnyInt}}, SameInt},
@ -641,7 +650,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{"sin", {{"x", SameFloating}}, SameFloating},
{"sinh", {{"x", SameFloating}}, SameFloating},
{"size",
{{"array", Anything, Rank::anyOrAssumedRank}, OptionalDIM,
{{"array", AnyData, Rank::anyOrAssumedRank}, OptionalDIM,
SubscriptDefaultKIND},
KINDInt, Rank::scalar},
{"spacing", {{"x", SameReal}}, SameReal},
@ -651,8 +660,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
SameType, Rank::rankPlus1},
{"sqrt", {{"x", SameFloating}}, SameFloating},
{"storage_size",
{{"a", Anything, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
KINDInt, Rank::scalar},
{{"a", AnyData, Rank::anyOrAssumedRank}, SubscriptDefaultKIND}, KINDInt,
Rank::scalar},
{"sum", {{"array", SameNumeric, Rank::array}, OptionalDIM, OptionalMASK},
SameNumeric, Rank::dimReduced},
{"tan", {{"x", SameFloating}}, SameFloating},
@ -660,24 +669,24 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{"tiny", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, Rank::scalar},
{"trailz", {{"i", AnyInt}}, DefaultInt},
{"transfer",
{{"source", Anything, Rank::known}, {"mold", SameType, Rank::scalar}},
{{"source", AnyData, Rank::known}, {"mold", SameType, Rank::scalar}},
SameType, Rank::scalar},
{"transfer",
{{"source", Anything, Rank::known}, {"mold", SameType, Rank::array}},
{{"source", AnyData, Rank::known}, {"mold", SameType, Rank::array}},
SameType, Rank::vector},
{"transfer",
{{"source", Anything, Rank::anyOrAssumedRank},
{{"source", AnyData, Rank::anyOrAssumedRank},
{"mold", SameType, Rank::anyOrAssumedRank},
{"size", AnyInt, Rank::scalar}},
SameType, Rank::vector},
{"transpose", {{"matrix", SameType, Rank::matrix}}, SameType, Rank::matrix},
{"trim", {{"string", SameChar, Rank::scalar}}, SameChar, Rank::scalar},
{"ubound",
{{"array", Anything, Rank::anyOrAssumedRank}, RequiredDIM,
{{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM,
SubscriptDefaultKIND},
KINDInt, Rank::scalar},
{"ubound",
{{"array", Anything, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
{{"array", AnyData, Rank::anyOrAssumedRank}, SubscriptDefaultKIND},
KINDInt, Rank::vector},
{"unpack",
{{"vector", SameType, Rank::vector}, {"mask", AnyLogical, Rank::array},
@ -695,7 +704,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
// NUM_IMAGES, STOPPED_IMAGES, TEAM_NUMBER, THIS_IMAGE,
// COSHAPE
// TODO: Object characteristic inquiry functions
// EXTENDS_TYPE_OF, IS_CONTIGUOUS, SAME_TYPE
// IS_CONTIGUOUS
// TODO: Non-standard intrinsic functions
// AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT,
// COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL,
@ -886,11 +895,69 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
{{"tanh", {{"x", DefaultReal}}, DefaultReal}},
};
// TODO: Intrinsic subroutines
// MVBITS (elemental), CPU_TIME, DATE_AND_TIME, EVENT_QUERY,
// EXECUTE_COMMAND_LINE, GET_COMMAND, GET_COMMAND_ARGUMENT,
// GET_ENVIRONMENT_VARIABLE, MOVE_ALLOC, RANDOM_INIT, RANDOM_NUMBER,
// RANDOM_SEED, SYSTEM_CLOCK
static const IntrinsicInterface intrinsicSubroutine[]{
{"cpu_time", {{"time", AnyReal, Rank::scalar}}, {}},
{"date_and_time",
{{"date", DefaultChar, Rank::scalar, Optionality::optional},
{"time", DefaultChar, Rank::scalar, Optionality::optional},
{"zone", DefaultChar, Rank::scalar, Optionality::optional},
{"values", AnyInt, Rank::vector, Optionality::optional}},
{}},
{"execute_command_line",
{{"command", DefaultChar, Rank::scalar},
{"wait", AnyLogical, Rank::scalar, Optionality::optional},
{"exitstat", AnyInt, Rank::scalar, Optionality::optional},
{"cmdstat", AnyInt, Rank::scalar, Optionality::optional},
{"cmdmsg", DefaultChar, Rank::scalar, Optionality::optional}},
{}},
{"get_command",
{{"command", DefaultChar, Rank::scalar, Optionality::optional},
{"length", AnyInt, Rank::scalar, Optionality::optional},
{"status", AnyInt, Rank::scalar, Optionality::optional},
{"errmsg", DefaultChar, Rank::scalar, Optionality::optional}},
{}},
{"get_command_argument",
{{"number", AnyInt, Rank::scalar},
{"value", DefaultChar, Rank::scalar, Optionality::optional},
{"length", AnyInt, Rank::scalar, Optionality::optional},
{"status", AnyInt, Rank::scalar, Optionality::optional},
{"errmsg", DefaultChar, Rank::scalar, Optionality::optional}},
{}},
{"get_environment_variable",
{{"name", DefaultChar, Rank::scalar},
{"value", DefaultChar, Rank::scalar, Optionality::optional},
{"length", AnyInt, Rank::scalar, Optionality::optional},
{"status", AnyInt, Rank::scalar, Optionality::optional},
{"trim_name", AnyLogical, Rank::scalar, Optionality::optional},
{"errmsg", DefaultChar, Rank::scalar, Optionality::optional}},
{}},
{"move_alloc",
{{"from", SameType, Rank::known}, {"to", SameType, Rank::known},
{"stat", AnyInt, Rank::scalar, Optionality::optional},
{"errmsg", DefaultChar, Rank::scalar, Optionality::optional}},
{}},
{"mvbits",
{{"from", SameInt}, {"frompos", AnyInt}, {"len", AnyInt},
{"to", SameInt}, {"topos", AnyInt}},
{}}, // elemental
{"random_init",
{{"repeatable", AnyLogical, Rank::scalar},
{"image_distinct", AnyLogical, Rank::scalar}},
{}},
{"random_number", {{"harvest", AnyReal, Rank::known}}, {}},
{"random_seed",
{{"size", DefaultInt, Rank::scalar, Optionality::optional},
{"put", DefaultInt, Rank::vector, Optionality::optional},
{"get", DefaultInt, Rank::vector, Optionality::optional}},
{}}, // TODO: at most one argument can be present
{"system_clock",
{{"count", AnyInt, Rank::scalar, Optionality::optional},
{"count_rate", AnyIntOrReal, Rank::scalar, Optionality::optional},
{"count_max", AnyInt, Rank::scalar, Optionality::optional}},
{}},
};
// TODO: Intrinsic subroutine EVENT_QUERY
// TODO: Atomic intrinsic subroutines: ATOMIC_ADD &al.
// TODO: Collective intrinsic subroutines: CO_BROADCAST &al.
@ -1364,9 +1431,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
}
}
// Characterize the specific intrinsic function.
characteristics::TypeAndShape typeAndShape{resultType.value(), resultRank};
characteristics::FunctionResult funcResult{std::move(typeAndShape)};
// Characterize the specific intrinsic procedure.
characteristics::DummyArguments dummyArgs;
std::optional<int> sameDummyArg;
for (std::size_t j{0}; j < dummies; ++j) {
@ -1391,6 +1456,8 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
}
} else {
CHECK(arg->GetAssumedTypeDummy() != nullptr);
dummyArgs.emplace_back(std::string{d.keyword},
characteristics::DummyDataObject{DynamicType::AssumedType()});
}
} else {
// optional argument is absent
@ -1411,11 +1478,19 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
if (elementalRank > 0) {
attrs.set(characteristics::Procedure::Attr::Elemental);
}
characteristics::Procedure chars{
std::move(funcResult), std::move(dummyArgs), attrs};
return SpecificCall{
SpecificIntrinsic{name, std::move(chars)}, std::move(rearranged)};
if (call.isSubroutineCall) {
return SpecificCall{
SpecificIntrinsic{
name, characteristics::Procedure{std::move(dummyArgs), attrs}},
std::move(rearranged)};
} else {
characteristics::TypeAndShape typeAndShape{resultType.value(), resultRank};
characteristics::FunctionResult funcResult{std::move(typeAndShape)};
characteristics::Procedure chars{
std::move(funcResult), std::move(dummyArgs), attrs};
return SpecificCall{
SpecificIntrinsic{name, std::move(chars)}, std::move(rearranged)};
}
}
class IntrinsicProcTable::Implementation {
@ -1428,6 +1503,9 @@ public:
for (const SpecificIntrinsicInterface &f : specificIntrinsicFunction) {
specificFuncs_.insert(std::make_pair(std::string{f.name}, &f));
}
for (const IntrinsicInterface &f : intrinsicSubroutine) {
subroutines_.insert(std::make_pair(std::string{f.name}, &f));
}
}
bool IsIntrinsic(const std::string &) const;
@ -1448,6 +1526,7 @@ private:
common::IntrinsicTypeDefaultKinds defaults_;
std::multimap<std::string, const IntrinsicInterface *> genericFuncs_;
std::multimap<std::string, const SpecificIntrinsicInterface *> specificFuncs_;
std::multimap<std::string, const IntrinsicInterface *> subroutines_;
};
bool IntrinsicProcTable::Implementation::IsIntrinsic(
@ -1460,6 +1539,10 @@ bool IntrinsicProcTable::Implementation::IsIntrinsic(
if (genericRange.first != genericRange.second) {
return true;
}
auto subrRange{subroutines_.equal_range(name)};
if (subrRange.first != subrRange.second) {
return true;
}
// special cases
return name == "null"; // TODO more
}
@ -1602,10 +1685,18 @@ static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface,
std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
const CallCharacteristics &call, ActualArguments &arguments,
FoldingContext &context, const IntrinsicProcTable &intrinsics) const {
std::string name{call.name.ToString()};
if (call.isSubroutineCall) {
parser::Messages buffer;
auto subrRange{subroutines_.equal_range(name)};
for (auto iter{subrRange.first}; iter != subrRange.second; ++iter) {
if (auto specificCall{
iter->second->Match(call, defaults_, arguments, context)}) {
return specificCall;
}
}
return std::nullopt; // TODO
}
std::string name{call.name.ToString()};
// Special case: NULL()
// All special cases handled here before the table probes below must
@ -1830,6 +1921,10 @@ std::ostream &IntrinsicProcTable::Implementation::Dump(std::ostream &o) const {
}
o << '\n';
}
o << "subroutines:\n";
for (const auto &iter : subroutines_) {
iter.second->Dump(o << iter.first << ": ") << '\n';
}
return o;
}

4
flang/lib/evaluate/shape.h
View File

@ -43,8 +43,6 @@ using Shape = std::vector<MaybeExtentExpr>;
bool IsImpliedShape(const Symbol &);
bool IsExplicitShape(const Symbol &);
template<typename A> std::optional<Shape> GetShape(FoldingContext &, const A &);
// Conversions between various representations of shapes.
Shape AsShape(const Constant<ExtentType> &);
std::optional<Shape> AsShape(FoldingContext &, ExtentExpr &&);
@ -87,6 +85,8 @@ MaybeExtentExpr GetSize(Shape &&);
bool ContainsAnyImpliedDoIndex(const ExtentExpr &);
// GetShape()
template<typename A> std::optional<Shape> GetShape(FoldingContext &, const A &);
class GetShapeHelper
: public AnyTraverse<GetShapeHelper, std::optional<Shape>> {
public:

181
flang/lib/evaluate/type.cc
View File

@ -109,18 +109,16 @@ bool DynamicType::IsAssumedLengthCharacter() const {
charLength_->isAssumed();
}
static const semantics::DerivedTypeSpec *GetParentTypeSpec(
const semantics::DerivedTypeSpec &spec) {
const semantics::Symbol &typeSymbol{spec.typeSymbol()};
static const semantics::Symbol *FindParentComponent(
const semantics::DerivedTypeSpec &derived) {
const semantics::Symbol &typeSymbol{derived.typeSymbol()};
if (const semantics::Scope * scope{typeSymbol.scope()}) {
const auto &dtDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
if (auto extends{dtDetails.GetParentComponentName()}) {
if (auto iter{scope->find(*extends)}; iter != scope->cend()) {
if (const Symbol & symbol{*iter->second};
symbol.test(Symbol::Flag::ParentComp)) {
return &symbol.get<semantics::ObjectEntityDetails>()
.type()
->derivedTypeSpec();
return &symbol;
}
}
}
@ -128,23 +126,166 @@ static const semantics::DerivedTypeSpec *GetParentTypeSpec(
return nullptr;
}
static bool IsAncestorTypeOf(const semantics::DerivedTypeSpec *ancestor,
const semantics::DerivedTypeSpec *spec) {
if (ancestor == nullptr) {
return false;
} else if (spec == nullptr) {
return false;
} else if (spec->typeSymbol() == ancestor->typeSymbol()) {
return true;
static const semantics::DerivedTypeSpec *GetParentTypeSpec(
const semantics::DerivedTypeSpec &derived) {
if (const semantics::Symbol * parent{FindParentComponent(derived)}) {
return &parent->get<semantics::ObjectEntityDetails>()
.type()
->derivedTypeSpec();
} else {
return IsAncestorTypeOf(ancestor, GetParentTypeSpec(*spec));
return nullptr;
}
}
static const semantics::Symbol *FindComponent(
const semantics::DerivedTypeSpec &derived, parser::CharBlock name) {
if (const auto *scope{derived.scope()}) {
auto iter{scope->find(name)};
if (iter != scope->end()) {
return iter->second;
} else if (const auto *parent{GetParentTypeSpec(derived)}) {
return FindComponent(*parent, name);
}
}
return nullptr;
}
// Compares two derived type representations to see whether they both
// represent the "same type" in the sense of section 7.5.2.4.
using SetOfDerivedTypePairs =
std::set<std::pair<const semantics::DerivedTypeSpec *,
const semantics::DerivedTypeSpec *>>;
static bool AreSameComponent(const semantics::Symbol &,
const semantics::Symbol &, SetOfDerivedTypePairs &inProgress);
static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
const semantics::DerivedTypeSpec &y, SetOfDerivedTypePairs &inProgress) {
const auto &xSymbol{x.typeSymbol()};
const auto &ySymbol{y.typeSymbol()};
if (&x == &y || xSymbol == ySymbol) {
return true;
}
auto thisQuery{std::make_pair(&x, &y)};
if (inProgress.find(thisQuery) != inProgress.end()) {
return true; // recursive use of types in components
}
inProgress.insert(thisQuery);
const auto &xDetails{xSymbol.get<semantics::DerivedTypeDetails>()};
const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()};
if (xSymbol.name() != ySymbol.name()) {
return false;
}
if (!(xDetails.sequence() && yDetails.sequence()) &&
!(xSymbol.attrs().test(semantics::Attr::BIND_C) &&
ySymbol.attrs().test(semantics::Attr::BIND_C))) {
// PGI does not enforce this requirement; all other Fortran
// processors do with a hard error when violations are caught.
return false;
}
// Compare the component lists in their orders of declaration.
auto xEnd{xDetails.componentNames().cend()};
auto yComponentName{yDetails.componentNames().cbegin()};
auto yEnd{yDetails.componentNames().cend()};
for (auto xComponentName{xDetails.componentNames().cbegin()};
xComponentName != xEnd; ++xComponentName, ++yComponentName) {
if (yComponentName == yEnd || *xComponentName != *yComponentName ||
xSymbol.scope() == nullptr || ySymbol.scope() == nullptr) {
return false;
}
const auto xLookup{xSymbol.scope()->find(*xComponentName)};
const auto yLookup{ySymbol.scope()->find(*yComponentName)};
if (xLookup == xSymbol.scope()->end() ||
yLookup == ySymbol.scope()->end() ||
!AreSameComponent(
DEREF(xLookup->second), DEREF(yLookup->second), inProgress)) {
return false;
}
}
return yComponentName == yEnd;
}
static bool AreSameComponent(const semantics::Symbol &x,
const semantics::Symbol &y,
SetOfDerivedTypePairs & /* inProgress - not yet used */) {
if (x.attrs() != y.attrs()) {
return false;
}
if (x.attrs().test(semantics::Attr::PRIVATE)) {
return false;
}
#if 0 // TODO
if (const auto *xObject{x.detailsIf<semantics::ObjectEntityDetails>()}) {
if (const auto *yObject{y.detailsIf<semantics::ObjectEntityDetails>()}) {
#else
if (x.has<semantics::ObjectEntityDetails>()) {
if (y.has<semantics::ObjectEntityDetails>()) {
#endif
// TODO: compare types, type parameters, bounds, &c.
return true;
} else {
return false;
}
} else {
// TODO: non-object components
return true;
}
}
static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
const semantics::DerivedTypeSpec *y, bool isPolymorphic) {
if (x == nullptr || y == nullptr) {
return false;
} else {
SetOfDerivedTypePairs inProgress;
if (AreSameDerivedType(*x, *y, inProgress)) {
return true;
} else {
return isPolymorphic &&
AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true);
}
}
}
bool IsKindTypeParameter(const semantics::Symbol &symbol) {
const auto *param{symbol.detailsIf<semantics::TypeParamDetails>()};
return param && param->attr() == common::TypeParamAttr::Kind;
}
static bool IsKindTypeParameter(
const semantics::DerivedTypeSpec &derived, parser::CharBlock name) {
const semantics::Symbol *symbol{FindComponent(derived, name)};
return symbol && IsKindTypeParameter(*symbol);
}
bool DynamicType::IsTypeCompatibleWith(const DynamicType &that) const {
return *this == that || IsUnlimitedPolymorphic() ||
(IsPolymorphic() && derived_ != nullptr &&
IsAncestorTypeOf(derived_, that.derived_));
if (derived_ != nullptr) {
if (!AreCompatibleDerivedTypes(derived_, that.derived_, IsPolymorphic())) {
return false;
}
// The values of derived type KIND parameters must match.
for (const auto &[name, param] : derived_->parameters()) {
if (IsKindTypeParameter(*derived_, name)) {
bool ok{false};
if (auto myValue{ToInt64(param.GetExplicit())}) {
if (const auto *thatParam{that.derived_->FindParameter(name)}) {
if (auto thatValue{ToInt64(thatParam->GetExplicit())}) {
ok = *myValue == *thatValue;
}
}
}
if (!ok) {
return false;
}
}
}
return true;
} else if (category_ == that.category_ && kind_ == that.kind_) {
// CHARACTER length is not checked here
return true;
} else {
return IsUnlimitedPolymorphic();
}
}
// Do the kind type parameters of type1 have the same values as the
@ -172,10 +313,8 @@ bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
} else if (!derived_ || !that.derived_ ||
!IsKindCompatible(*derived_, *that.derived_)) {
return false; // kind params don't match
} else if (!IsPolymorphic()) {
return derived_->typeSymbol() == that.derived_->typeSymbol();
} else {
return IsAncestorTypeOf(derived_, that.derived_);
return AreCompatibleDerivedTypes(derived_, that.derived_, IsPolymorphic());
}
}

7
flang/lib/evaluate/type.h
View File

@ -55,7 +55,7 @@ template<TypeCategory CATEGORY, int KIND = 0> class Type;
using SubscriptInteger = Type<TypeCategory::Integer, 8>;
using CInteger = Type<TypeCategory::Integer, 4>;
using LogicalResult = Type<TypeCategory::Logical, 1>;
using LogicalResult = Type<TypeCategory::Logical, 4>;
using LargestReal = Type<TypeCategory::Real, 16>;
// A predicate that is true when a kind value is a kind that could possibly
@ -161,7 +161,7 @@ public:
return *derived_;
}
// 7.3.2.3 type compatibility.
// 7.3.2.3 & 15.5.2.4 type compatibility.
// x.IsTypeCompatibleWith(y) is true if "x => y" or passing actual y to
// dummy argument x would be valid. Be advised, this is not a reflexive
// relation.
@ -448,6 +448,9 @@ int SelectedIntKind(std::int64_t precision = 0);
int SelectedRealKind(
std::int64_t precision = 0, std::int64_t range = 0, std::int64_t radix = 2);
// Utilities
bool IsKindTypeParameter(const semantics::Symbol &);
// For generating "[extern] template class", &c. boilerplate
#define EXPAND_FOR_EACH_INTEGER_KIND(M, P, S) \
M(P, S, 1) M(P, S, 2) M(P, S, 4) M(P, S, 8) M(P, S, 16)

8
flang/lib/parser/prescan.cc
View File

@ -227,14 +227,12 @@ void Prescanner::Statement() {
TokenSequence Prescanner::TokenizePreprocessorDirective() {
CHECK(nextLine_ < limit_ && !inPreprocessorDirective_);
auto saveAt{at_};
inPreprocessorDirective_ = true;
BeginSourceLineAndAdvance();
TokenSequence tokens;
while (NextToken(tokens)) {
}
inPreprocessorDirective_ = false;
at_ = saveAt;
return tokens;
}
@ -806,8 +804,10 @@ bool Prescanner::SkipCommentLine(bool afterAmpersand) {
lineClass.kind == LineClassification::Kind::PreprocessorDirective) {
// Allow conditional compilation directives (e.g., #ifdef) to affect
// continuation lines.
// Allow other preprocessor directives, too, except #include,
// #define, & #undef.
// Allow other preprocessor directives, too, except #include
// (when it does not follow '&'), #define, and #undef (because
// they cannot be allowed to affect preceding text on a
// continued line).
preprocessor_.Directive(TokenizePreprocessorDirective(), this);
return true;
} else if (afterAmpersand &&

7
flang/lib/semantics/assignment.cc
View File

@ -58,7 +58,8 @@ void CheckPointerAssignment(parser::ContextualMessages &messages,
} else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) {
funcName = intrinsic->name;
}
if (auto proc{Characterize(f.proc(), intrinsics)}) {
if (auto proc{
characteristics::Procedure::Characterize(f.proc(), intrinsics)}) {
std::optional<parser::MessageFixedText> error;
if (const auto &funcResult{proc->functionResult}) {
const auto *frProc{funcResult->IsProcedurePointer()};
@ -189,13 +190,13 @@ void CheckPointerAssignment(parser::ContextualMessages &messages,
const IntrinsicProcTable &intrinsics, const Symbol &lhs,
const ProcedureDesignator &d) {
CheckPointerAssignment(messages, intrinsics, lhs, d.GetName(), false,
Characterize(d, intrinsics));
characteristics::Procedure::Characterize(d, intrinsics));
}
void CheckPointerAssignment(parser::ContextualMessages &messages,
const IntrinsicProcTable &intrinsics, const Symbol &lhs,
const ProcedureRef &ref) {
auto chars{Characterize(ref, intrinsics)};
auto chars{characteristics::Procedure::Characterize(ref, intrinsics)};
if (chars.has_value()) {
if (chars->functionResult.has_value()) {
if (const auto *proc{chars->functionResult->IsProcedurePointer()}) {

185
flang/lib/semantics/expression.cc
View File

@ -19,6 +19,7 @@
#include "symbol.h"
#include "tools.h"
#include "../common/idioms.h"
#include "../evaluate/check-call.h"
#include "../evaluate/common.h"
#include "../evaluate/fold.h"
#include "../evaluate/tools.h"
@ -1437,9 +1438,21 @@ MaybeExpr ExpressionAnalyzer::Analyze(
return AsMaybeExpr(Expr<SomeDerived>{std::move(result)});
}
std::optional<ProcedureDesignator>
ExpressionAnalyzer::AnalyzeProcedureComponentRef(
const parser::ProcComponentRef &pcr) {
static const semantics::WithPassArg *GetPassInfo(
const semantics::Symbol &symbol) {
if (const auto *binding{symbol.detailsIf<semantics::ProcBindingDetails>()}) {
return binding;
} else if (const auto *proc{
symbol.detailsIf<semantics::ProcEntityDetails>()}) {
return proc;
} else {
return nullptr;
}
}
auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
const parser::ProcComponentRef &pcr, ActualArguments &&arguments)
-> std::optional<CalleeAndArguments> {
const parser::StructureComponent &sc{pcr.v.thing};
const auto &name{sc.component.source};
if (MaybeExpr base{Analyze(sc.base)}) {
@ -1456,20 +1469,44 @@ ExpressionAnalyzer::AnalyzeProcedureComponentRef(
ExtractDataRef(std::move(*dtExpr))}) {
if (auto component{CreateComponent(
std::move(*dataRef), *sym, *dtSpec->scope())}) {
return ProcedureDesignator{std::move(*component)};
if (const auto *pass{GetPassInfo(*sym)}) {
if (auto passIndex{pass->passIndex()}) {
// There's a PASS argument by which the base of the procedure
// component reference must be passed. Append or insert it to
// the list of effective arguments.
auto iter{arguments.begin()};
int at{0};
while (iter < arguments.end() && at < *passIndex) {
if (iter->has_value() && (*iter)->keyword.has_value()) {
iter = arguments.end();
break;
}
++iter;
++at;
}
ActualArgument passed{AsGenericExpr(std::move(*dtExpr))};
if (iter == arguments.end() && pass->passName().has_value()) {
passed.keyword = *pass->passName();
}
arguments.emplace(iter, std::move(passed));
}
}
return CalleeAndArguments{
ProcedureDesignator{std::move(*component)},
std::move(arguments)};
} else {
Say(name,
"procedure component is not in scope of derived TYPE(%s)"_err_en_US,
"Procedure component is not in scope of derived TYPE(%s)"_err_en_US,
dtSpec->typeSymbol().name());
}
} else {
Say(name,
"base of procedure component reference must be a data reference"_err_en_US);
"Base of procedure component reference must be a data reference"_err_en_US);
}
}
} else {
Say(name,
"base of procedure component reference is not a derived type object"_err_en_US);
"Base of procedure component reference is not a derived type object"_err_en_US);
}
}
}
@ -1477,8 +1514,9 @@ ExpressionAnalyzer::AnalyzeProcedureComponentRef(
return std::nullopt;
}
auto ExpressionAnalyzer::Procedure(const parser::ProcedureDesignator &pd,
ActualArguments &arguments) -> std::optional<CalleeAndArguments> {
auto ExpressionAnalyzer::GetCalleeAndArguments(
const parser::ProcedureDesignator &pd, ActualArguments &&arguments,
bool isSubroutine) -> std::optional<CalleeAndArguments> {
return std::visit(
common::visitors{
[&](const parser::Name &n) -> std::optional<CalleeAndArguments> {
@ -1488,7 +1526,8 @@ auto ExpressionAnalyzer::Procedure(const parser::ProcedureDesignator &pd,
const Symbol &symbol{n.symbol->GetUltimate()};
if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
if (std::optional<SpecificCall> specificCall{
context_.intrinsics().Probe(CallCharacteristics{n.source},
context_.intrinsics().Probe(
CallCharacteristics{n.source, isSubroutine},
arguments, GetFoldingContext())}) {
return CalleeAndArguments{ProcedureDesignator{std::move(
specificCall->specificIntrinsic)},
@ -1497,50 +1536,38 @@ auto ExpressionAnalyzer::Procedure(const parser::ProcedureDesignator &pd,
return std::nullopt;
}
}
if (const auto *scope{symbol.scope()}) {
if (scope->sourceRange().Contains(n.source)) {
if (symbol.attrs().test(
semantics::Attr::NON_RECURSIVE)) { // 15.6.2.1(3)
if (auto *msg{Say(
"NON_RECURSIVE procedure '%s' cannot call itself"_err_en_US,
n.source)}) {
msg->Attach(
symbol.name(), "definition of '%s'"_en_US, n.source);
}
} else if (IsAssumedLengthCharacterFunction(
symbol)) { // 15.6.2.1(3)
if (auto *msg{Say(
"Assumed-length CHARACTER(*) function '%s' cannot call itself"_err_en_US,
n.source)}) {
msg->Attach(
symbol.name(), "definition of '%s'"_en_US, n.source);
}
}
}
}
if (symbol.HasExplicitInterface()) {
// TODO: check actual arguments vs. interface
} else {
// TODO: call with implicit interface
}
CheckForBadRecursion(n.source, symbol);
return CalleeAndArguments{
ProcedureDesignator{*n.symbol}, std::move(arguments)};
},
[&](const parser::ProcComponentRef &pcr)
-> std::optional<CalleeAndArguments> {
if (std::optional<ProcedureDesignator> proc{
AnalyzeProcedureComponentRef(pcr)}) {
// TODO distinguish PCR from TBP
// TODO optional PASS argument for TBP
return CalleeAndArguments{std::move(*proc), std::move(arguments)};
} else {
return std::nullopt;
}
return AnalyzeProcedureComponentRef(pcr, std::move(arguments));
},
},
pd.u);
}
void ExpressionAnalyzer::CheckForBadRecursion(
parser::CharBlock callSite, const semantics::Symbol &proc) {
if (const auto *scope{proc.scope()}) {
if (scope->sourceRange().Contains(callSite)) {
parser::Message *msg{nullptr};
if (proc.attrs().test(semantics::Attr::NON_RECURSIVE)) { // 15.6.2.1(3)
msg = Say("NON_RECURSIVE procedure '%s' cannot call itself"_err_en_US,
callSite);
} else if (IsAssumedLengthCharacterFunction(proc)) { // 15.6.2.1(3)
msg = Say(
"Assumed-length CHARACTER(*) function '%s' cannot call itself"_err_en_US,
callSite);
}
if (msg != nullptr) {
msg->Attach(proc.name(), "definition of '%s'"_en_US, callSite);
}
}
}
}
template<typename A> static const Symbol *AssumedTypeDummy(const A &x) {
if (const auto *designator{
std::get_if<common::Indirection<parser::Designator>>(&x.u)}) {
@ -1609,12 +1636,16 @@ MaybeExpr ExpressionAnalyzer::AnalyzeCall(
auto save{GetContextualMessages().SetLocation(call.source)};
if (auto arguments{AnalyzeArguments(call, isSubroutine)}) {
// TODO: map non-intrinsic generic procedure to specific procedure
if (std::optional<CalleeAndArguments> callee{Procedure(
std::get<parser::ProcedureDesignator>(call.t), *arguments)}) {
if (std::optional<CalleeAndArguments> callee{
GetCalleeAndArguments(std::get<parser::ProcedureDesignator>(call.t),
std::move(*arguments), isSubroutine)}) {
if (isSubroutine) {
// TODO
CheckCall(call.source, callee->procedureDesignator, callee->arguments);
// TODO: Package the subroutine call as an expr in the parse tree
} else {
return MakeFunctionRef(std::move(*callee));
return MakeFunctionRef(call.source,
std::move(callee->procedureDesignator),
std::move(callee->arguments));
}
}
}
@ -1665,6 +1696,36 @@ std::optional<ActualArguments> ExpressionAnalyzer::AnalyzeArguments(
return arguments;
}
static bool IsExternalCalledImplicitly(
parser::CharBlock callSite, const ProcedureDesignator &proc) {
if (const auto *symbol{proc.GetSymbol()}) {
return !callSite.empty() && symbol->has<semantics::SubprogramDetails>() &&
(symbol->owner().IsGlobal() ||
(symbol->owner().parent().IsGlobal() &&
!symbol->owner().sourceRange().Contains(callSite)));
} else {
return false;
}
}
std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
parser::CharBlock callSite, const ProcedureDesignator &proc,
ActualArguments &arguments) {
auto chars{
characteristics::Procedure::Characterize(proc, context_.intrinsics())};
if (chars.has_value()) {
bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)};
if (treatExternalAsImplicit && !chars->CanBeCalledViaImplicitInterface()) {
Say(callSite,
"References to the procedure '%s' require an explicit interface"_en_US,
DEREF(proc.GetSymbol()).name());
}
CheckArguments(
*chars, arguments, GetFoldingContext(), treatExternalAsImplicit);
}
return chars;
}
// Unary operations
MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Parentheses &x) {
@ -2189,14 +2250,14 @@ bool ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at,
return true;
}
MaybeExpr ExpressionAnalyzer::MakeFunctionRef(
MaybeExpr ExpressionAnalyzer::MakeFunctionRef(parser::CharBlock callSite,
ProcedureDesignator &&proc, ActualArguments &&arguments) {
if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&proc.u)}) {
if (intrinsic->name == "null" && arguments.empty()) {
return Expr<SomeType>{NullPointer{}};
}
}
if (auto chars{Characterize(proc, context_.intrinsics())}) {
if (auto chars{CheckCall(callSite, proc, arguments)}) {
if (chars->functionResult.has_value()) {
const auto &result{*chars->functionResult};
if (result.IsProcedurePointer()) {
@ -2235,40 +2296,18 @@ MaybeExpr ExpressionAnalyzer::MakeFunctionRef(
return std::nullopt;
}
MaybeExpr ExpressionAnalyzer::MakeFunctionRef(CalleeAndArguments &&callee) {
return MakeFunctionRef(
std::move(callee.procedureDesignator), std::move(callee.arguments));
}
MaybeExpr ExpressionAnalyzer::MakeFunctionRef(
parser::CharBlock intrinsic, ActualArguments &&arguments) {
if (std::optional<SpecificCall> specificCall{
context_.intrinsics().Probe(CallCharacteristics{intrinsic}, arguments,
context_.foldingContext())}) {
return MakeFunctionRef(
return MakeFunctionRef(intrinsic,
ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
std::move(specificCall->arguments));
} else {
return std::nullopt;
}
}
std::optional<characteristics::Procedure> Characterize(
const ProcedureDesignator &proc, const IntrinsicProcTable &intrinsics) {
if (const auto *symbol{proc.GetSymbol()}) {
return characteristics::Procedure::Characterize(
symbol->GetUltimate(), intrinsics);
} else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
return intrinsic->characteristics.value();
} else {
return std::nullopt;
}
}
std::optional<characteristics::Procedure> Characterize(
const ProcedureRef &ref, const IntrinsicProcTable &intrinsics) {
return Characterize(ref.proc(), intrinsics);
}
}
namespace Fortran::semantics {

26
flang/lib/semantics/expression.h
View File

@ -311,24 +311,31 @@ private:
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 &);
struct CalleeAndArguments {
ProcedureDesignator procedureDesignator;
ActualArguments arguments;
};
std::optional<CalleeAndArguments> AnalyzeProcedureComponentRef(
const parser::ProcComponentRef &, ActualArguments &&);
std::optional<ActualArgument> AnalyzeActualArgument(const parser::Expr &);
MaybeExpr AnalyzeCall(const parser::Call &, bool isSubroutine);
std::optional<ActualArguments> AnalyzeArguments(
const parser::Call &, bool isSubroutine);
std::optional<CalleeAndArguments> Procedure(
const parser::ProcedureDesignator &, ActualArguments &);
std::optional<characteristics::Procedure> CheckCall(
parser::CharBlock, const ProcedureDesignator &, ActualArguments &);
std::optional<CalleeAndArguments> GetCalleeAndArguments(
const parser::ProcedureDesignator &, ActualArguments &&,
bool isSubroutine);
void CheckForBadRecursion(parser::CharBlock, const semantics::Symbol &);
bool EnforceTypeConstraint(parser::CharBlock, const MaybeExpr &, TypeCategory,
bool defaultKind = false);
MaybeExpr MakeFunctionRef(ProcedureDesignator &&, ActualArguments &&);
MaybeExpr MakeFunctionRef(CalleeAndArguments &&);
MaybeExpr MakeFunctionRef(
parser::CharBlock, ProcedureDesignator &&, ActualArguments &&);
MaybeExpr MakeFunctionRef(parser::CharBlock intrinsic, ActualArguments &&);
semantics::SemanticsContext &context_;
@ -354,11 +361,6 @@ void ConformabilityCheck(
left.Rank(), right.Rank());
}
}
std::optional<characteristics::Procedure> Characterize(
const ProcedureDesignator &, const IntrinsicProcTable &);
std::optional<characteristics::Procedure> Characterize(
const ProcedureRef &, const IntrinsicProcTable &);
} // namespace Fortran::evaluate
namespace Fortran::semantics {

58
flang/lib/semantics/mod-file.cc
View File

@ -41,10 +41,10 @@ using namespace parser::literals;
// that the module file is decoded as UTF-8 even if source files
// are using another encoding.
struct ModHeader {
static constexpr const char *bom{"\xef\xbb\xbf"};
static constexpr const char *magic{"!mod$ v1 sum:"};
static constexpr const char bom[3 + 1]{"\xef\xbb\xbf"};
static constexpr int magicLen{13};
static constexpr int sumLen{16};
static constexpr const char magic[magicLen + 1]{"!mod$ v1 sum:"};
static constexpr char terminator{'\n'};
static constexpr int len{magicLen + 1 + sumLen};
};
@ -56,7 +56,8 @@ static void PutObjectEntity(std::ostream &, const Symbol &);
static void PutProcEntity(std::ostream &, const Symbol &);
static void PutPassName(std::ostream &, const std::optional<SourceName> &);
static void PutTypeParam(std::ostream &, const Symbol &);
static void PutEntity(std::ostream &, const Symbol &, std::function<void()>);
static void PutEntity(
std::ostream &, const Symbol &, std::function<void()>, Attrs);
static void PutInit(std::ostream &, const Symbol &, const MaybeExpr &);
static void PutInit(std::ostream &, const MaybeIntExpr &);
static void PutBound(std::ostream &, const Bound &);
@ -216,7 +217,11 @@ void ModFileWriter::PutSymbol(
typeBindings << '(' << x.symbol().name() << ')';
}
PutPassName(typeBindings, x.passName());
PutAttrs(typeBindings, symbol->attrs());
auto attrs{symbol->attrs()};
if (x.passName().has_value()) {
attrs.reset(Attr::PASS);
}
PutAttrs(typeBindings, attrs);
typeBindings << "::" << symbol->name();
if (!deferred && x.symbol().name() != symbol->name()) {
typeBindings << "=>" << x.symbol().name();
@ -496,7 +501,8 @@ void PutShape(std::ostream &os, const ArraySpec &shape, char open, char close) {
void PutObjectEntity(std::ostream &os, const Symbol &symbol) {
auto &details{symbol.get<ObjectEntityDetails>()};
PutEntity(os, symbol, [&]() { PutType(os, DEREF(symbol.GetType())); });
PutEntity(os, symbol, [&]() { PutType(os, DEREF(symbol.GetType())); },
symbol.attrs());
PutShape(os, details.shape(), '(', ')');
PutShape(os, details.coshape(), '[', ']');
PutInit(os, symbol, details.init());
@ -509,16 +515,22 @@ void PutProcEntity(std::ostream &os, const Symbol &symbol) {
}
const auto &details{symbol.get<ProcEntityDetails>()};
const ProcInterface &interface{details.interface()};
PutEntity(os, symbol, [&]() {
os << "procedure(";
if (interface.symbol()) {
os << interface.symbol()->name();
} else if (interface.type()) {
PutType(os, *interface.type());
}
os << ')';
PutPassName(os, details.passName());
});
Attrs attrs{symbol.attrs()};
if (details.passName().has_value()) {
attrs.reset(Attr::PASS);
}
PutEntity(os, symbol,
[&]() {
os << "procedure(";
if (interface.symbol()) {
os << interface.symbol()->name();
} else if (interface.type()) {
PutType(os, *interface.type());
}
os << ')';
PutPassName(os, details.passName());
},
attrs);
os << '\n';
}
@ -530,10 +542,12 @@ void PutPassName(std::ostream &os, const std::optional<SourceName> &passName) {
void PutTypeParam(std::ostream &os, const Symbol &symbol) {
auto &details{symbol.get<TypeParamDetails>()};
PutEntity(os, symbol, [&]() {
PutType(os, DEREF(symbol.GetType()));
PutLower(os << ',', common::EnumToString(details.attr()));
});
PutEntity(os, symbol,
[&]() {
PutType(os, DEREF(symbol.GetType()));
PutLower(os << ',', common::EnumToString(details.attr()));
},
symbol.attrs());
PutInit(os, details.init());
os << '\n';
}
@ -566,8 +580,8 @@ void PutBound(std::ostream &os, const Bound &x) {
// Write an entity (object or procedure) declaration.
// writeType is called to write out the type.
void PutEntity(
std::ostream &os, const Symbol &symbol, std::function<void()> writeType) {
void PutEntity(std::ostream &os, const Symbol &symbol,
std::function<void()> writeType, Attrs attrs) {
writeType();
MaybeExpr bindName;
std::visit(
@ -578,7 +592,7 @@ void PutEntity(
[&](const auto &) {},
},
symbol.details());
PutAttrs(os, symbol.attrs(), bindName);
PutAttrs(os, attrs, bindName);
os << "::" << symbol.name();
}

34
flang/lib/semantics/resolve-names.cc
View File

@ -5047,7 +5047,9 @@ const parser::Name *DeclarationVisitor::FindComponent(
// C764, C765
void DeclarationVisitor::CheckInitialDataTarget(
const Symbol &pointer, const SomeExpr &expr, SourceName source) {
if (!evaluate::IsInitialDataTarget(expr)) {
auto &messages{GetFoldingContext().messages()};
auto save{messages.SetLocation(source)};
if (!evaluate::IsInitialDataTarget(expr, messages)) {
Say(source,
"Pointer '%s' cannot be initialized with a reference to a designator with non-constant subscripts"_err_en_US,
pointer.name());
@ -5059,35 +5061,6 @@ void DeclarationVisitor::CheckInitialDataTarget(
pointer.name(), pointer.Rank(), expr.Rank());
return;
}
if (auto base{evaluate::GetBaseObject(expr)}) {
if (const Symbol * baseSym{base->symbol()}) {
const Symbol &ultimate{baseSym->GetUltimate()};
if (IsAllocatable(ultimate)) {
Say(source,
"Pointer '%s' cannot be initialized with a reference to an allocatable '%s'"_err_en_US,
pointer.name(), ultimate.name());
return;
}
if (ultimate.Corank() > 0) {
Say(source,
"Pointer '%s' cannot be initialized with a reference to a coarray '%s'"_err_en_US,
pointer.name(), ultimate.name());
return;
}
if (!ultimate.attrs().test(Attr::TARGET)) {
Say(source,
"Pointer '%s' cannot be initialized with a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
pointer.name(), ultimate.name());
return;
}
if (!IsSaved(ultimate)) {
Say(source,
"Pointer '%s' cannot be initialized with a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
pointer.name(), ultimate.name());
return;
}
}
}
// TODO: check type compatibility
// TODO: check non-deferred type parameter values
// TODO: check contiguity if pointer is CONTIGUOUS
@ -6028,6 +6001,7 @@ void ResolveNamesVisitor::SetPassArg(
}
}
details.set_passIndex(passArgIndex);
details.set_passName(passName.value());
}
// Resolve names in the execution part of this node and its children

13
flang/lib/semantics/symbol.cc
View File

@ -258,19 +258,6 @@ void Symbol::ReplaceName(const SourceName &name) {
name_ = name;
}
Symbol &Symbol::GetUltimate() {
return const_cast<Symbol &>(const_cast<const Symbol *>(this)->GetUltimate());
}
const Symbol &Symbol::GetUltimate() const {
if (const auto *details{detailsIf<UseDetails>()}) {
return details->symbol().GetUltimate();
} else if (const auto *details{detailsIf<HostAssocDetails>()}) {
return details->symbol().GetUltimate();
} else {
return *this;
}
}
void Symbol::SetType(const DeclTypeSpec &type) {
std::visit(
common::visitors{

15
flang/lib/semantics/symbol.h
View File

@ -500,8 +500,19 @@ public:
bool CanReplaceDetails(const Details &details) const;
// Follow use-associations and host-associations to get the ultimate entity.
Symbol &GetUltimate();
const Symbol &GetUltimate() const;
Symbol &GetUltimate() {
return const_cast<Symbol &>(
const_cast<const Symbol *>(this)->GetUltimate());
}
const Symbol &GetUltimate() const {
if (const auto *details{detailsIf<UseDetails>()}) {
return details->symbol().GetUltimate();
} else if (const auto *details{detailsIf<HostAssocDetails>()}) {
return details->symbol().GetUltimate();
} else {
return *this;
}
}
DeclTypeSpec *GetType() {
return const_cast<DeclTypeSpec *>(

3
flang/lib/semantics/type.h
View File

@ -227,7 +227,7 @@ private:
};
std::ostream &operator<<(std::ostream &, const ArraySpec &);
// Each DerivedTypeSpec has a typeSymbol that has DerivedTypeSpec.
// Each DerivedTypeSpec has a typeSymbol that has DerivedTypeDetails.
// The name may not match the symbol's name in case of a USE rename.
class DerivedTypeSpec {
public:
@ -243,7 +243,6 @@ public:
void ReplaceScope(const Scope &);
const ParameterMapType &parameters() const { return parameters_; }
bool HasActualParameters() const { return !parameters_.empty(); }
ParamValue &AddParamValue(SourceName, ParamValue &&);
ParamValue *FindParameter(SourceName);
const ParamValue *FindParameter(SourceName target) const {

5
flang/module/ieee_arithmetic.f90
View File

@ -153,12 +153,13 @@ module ieee_arithmetic
integer, parameter :: exponentBits = TOTALBITS - 1 - significand; \
integer, parameter :: maxExpo = shiftl(1, exponentBits) - 1; \
integer :: exponent, sign; \
logical :: nzSignificand, quiet; \
logical :: negative, nzSignificand, quiet; \
raw = transfer(x, raw); \
exponent = ibits(raw, significand, exponentBits); \
negative = btest(raw, TOTALBITS - 1); \
nzSignificand = ibits(raw, 0, significand) /= 0; \
quiet = btest(raw, significand - 1); \
ieee_class_a##RKIND = classify(exponent, maxExpo, nzSignificand, quiet); \
ieee_class_a##RKIND = classify(exponent, maxExpo, negative, nzSignificand, quiet); \
end function ieee_class_a##RKIND
_CLASSIFY(2,2,16,11,1)
_CLASSIFY(3,2,16,8,1)

46
flang/module/ieee_exceptions.f90
View File

@ -25,13 +25,14 @@ module ieee_exceptions
ieee_overflow = ieee_flag_type(2), &
ieee_divide_by_zero = ieee_flag_type(4), &
ieee_underflow = ieee_flag_type(8), &
ieee_inexact = ieee_flag_type(16)
ieee_inexact = ieee_flag_type(16), &
ieee_denorm = ieee_flag_type(32) ! PGI extension
type(ieee_flag_type), parameter :: &
ieee_usual(*) = [ &
ieee_overflow, ieee_divide_by_zero, ieee_invalid ], &
ieee_all(*) = [ &
ieee_usual, ieee_underflow, ieee_inexact ]
ieee_usual, ieee_underflow, ieee_inexact, ieee_denorm ]
type :: ieee_modes_type ! Fortran 2018, 17.7
private
@ -41,6 +42,15 @@ module ieee_exceptions
private
end type ieee_status_type
private :: ieee_support_flag_2, ieee_support_flag_3, &
ieee_support_flag_4, ieee_support_flag_8, ieee_support_flag_10, &
ieee_support_flag_16
interface ieee_support_flag
module procedure :: ieee_support_flag_2, ieee_support_flag_3, &
ieee_support_flag_4, ieee_support_flag_8, ieee_support_flag_10, &
ieee_support_flag_16
end interface
contains
subroutine ieee_get_flag(flag, flag_value)
type(ieee_flag_type), intent(in) :: flag
@ -78,10 +88,36 @@ module ieee_exceptions
type(ieee_status_type), intent(in) :: status
end subroutine ieee_set_status
pure logical function ieee_support_flag(flag, x)
pure logical function ieee_support_flag_2(flag, x)
type(ieee_flag_type), intent(in) :: flag
real, intent(in), optional :: x
end function ieee_support_flag
real(kind=2), intent(in) :: x(..)
ieee_support_flag_2 = .true.
end function
pure logical function ieee_support_flag_3(flag, x)
type(ieee_flag_type), intent(in) :: flag
real(kind=3), intent(in) :: x(..)
ieee_support_flag_3 = .true.
end function
pure logical function ieee_support_flag_4(flag, x)
type(ieee_flag_type), intent(in) :: flag
real(kind=4), intent(in) :: x(..)
ieee_support_flag_4 = .true.
end function
pure logical function ieee_support_flag_8(flag, x)
type(ieee_flag_type), intent(in) :: flag
real(kind=8), intent(in) :: x(..)
ieee_support_flag_8 = .true.
end function
pure logical function ieee_support_flag_10(flag, x)
type(ieee_flag_type), intent(in) :: flag
real(kind=10), intent(in) :: x(..)
ieee_support_flag_10 = .true.
end function
pure logical function ieee_support_flag_16(flag, x)
type(ieee_flag_type), intent(in) :: flag
real(kind=16), intent(in) :: x(..)
ieee_support_flag_16 = .true.
end function
pure logical function ieee_support_halting(flag)
type(ieee_flag_type), intent(in) :: flag

1
flang/test/semantics/CMakeLists.txt
View File

@ -169,6 +169,7 @@ set(ERROR_TESTS
blockconstruct03.f90
call01.f90
call02.f90
call13.f90
)
# These test files have expected symbols in the source

2
flang/test/semantics/call08.f90
View File

@ -54,7 +54,7 @@ module m
!ERROR: Effective argument associated with a CONTIGUOUS coarray dummy argument must be simply contiguous
call s03(x)
!ERROR: Effective argument associated with a CONTIGUOUS coarray dummy argument must be simply contiguous
call s04c3)
call s04(c3)
!ERROR: Effective argument associated with a CONTIGUOUS coarray dummy argument must be simply contiguous
call s04(x)
end subroutine

49
flang/test/semantics/call13.f90 Normal file
View File

@ -0,0 +1,49 @@
! 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.
! Test 15.4.2.2 constraints and restrictions for calls to implicit
! interfaces
subroutine s(assumedRank, coarray, class, classStar, typeStar)
type :: t
end type
real :: assumedRank(..), coarray[*]
class(t) :: class
class(*) :: classStar
type(*) :: typeStar
type :: pdt(len)
integer, len :: len
end type
type(pdt(1)) :: pdtx
!ERROR: Invalid specification expression: reference to impure function 'implicit01'
real :: array(implicit01()) ! 15.4.2.2(2)
!ERROR: Keyword 'keyword=' cannot appear in a reference to a procedure with an implicit interface
call implicit10(1, 2, keyword=3) ! 15.4.2.2(1)
!ERROR: Assumed rank argument requires an explicit interface
call implicit11(assumedRank) ! 15.4.2.2(3)(c)
!ERROR: Coarray argument requires an explicit interface
call implicit12(coarray) ! 15.4.2.2(3)(d)
!ERROR: Parameterized derived type argument requires an explicit interface
call implicit13(pdtx) ! 15.4.2.2(3)(e)
!ERROR: Polymorphic argument requires an explicit interface
call implicit14(class) ! 15.4.2.2(3)(f)
!ERROR: Polymorphic argument requires an explicit interface
call implicit15(classStar) ! 15.4.2.2(3)(f)
!ERROR: Assumed type argument requires an explicit interface
call implicit16(typeStar) ! 15.4.2.2(3)(f)
end subroutine

11
flang/test/semantics/doconcurrent01.f90
View File

@ -1,4 +1,4 @@
! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
! Copyright (c) 2018-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.
@ -20,7 +20,7 @@
! C1137
! An image control statement shall not appear within a DO CONCURRENT construct.
!
! C1136
! C1136
! A RETURN statement shall not appear within a DO CONCURRENT construct.
!
! (11.1.7.5), paragraph 4
@ -45,8 +45,9 @@ subroutine do_concurrent_test2(i,j,n,flag)
use ieee_exceptions
use iso_fortran_env, only: team_type
implicit none
integer :: i, n, flag, flag2
logical :: halting
integer :: i, n
type(ieee_flag_type) :: flag
logical :: flagValue, halting
type(team_type) :: j
do concurrent (i = 1:n)
!ERROR: image control statement not allowed in DO CONCURRENT
@ -55,7 +56,7 @@ subroutine do_concurrent_test2(i,j,n,flag)
critical
!ERROR: call to impure procedure in DO CONCURRENT not allowed
!ERROR: IEEE_GET_FLAG not allowed in DO CONCURRENT
call ieee_get_flag(flag, flag2)
call ieee_get_flag(flag, flagValue)
!ERROR: call to impure procedure in DO CONCURRENT not allowed
!ERROR: IEEE_GET_HALTING_MODE not allowed in DO CONCURRENT
call ieee_get_halting_mode(flag, halting)

12
flang/test/semantics/expr-errors02.f90
View File

@ -36,22 +36,22 @@ module m
modulefunc1 = n
end function
subroutine test(out, optional)
!ERROR: The expression (foo()) cannot be used as a specification expression (reference to impure function 'foo')
!ERROR: Invalid specification expression: reference to impure function 'foo'
type(t(foo())) :: x1
integer :: local
!ERROR: The expression (local) cannot be used as a specification expression (reference to local entity 'local')
!ERROR: Invalid specification expression: reference to local entity 'local'
type(t(local)) :: x2
!ERROR: The internal function 'internal' cannot be referenced in a specification expression
type(t(internal(0))) :: x3
integer, intent(out) :: out
!ERROR: The expression (out) cannot be used as a specification expression (reference to INTENT(OUT) dummy argument 'out')
!ERROR: Invalid specification expression: reference to INTENT(OUT) dummy argument 'out'
type(t(out)) :: x4
integer, intent(in), optional :: optional
!ERROR: The expression (optional) cannot be used as a specification expression (reference to OPTIONAL dummy argument 'optional')
!ERROR: Invalid specification expression: reference to OPTIONAL dummy argument 'optional'
type(t(optional)) :: x5
!ERROR: The expression (hasprocarg(realfunc)) cannot be used as a specification expression (dummy procedure argument)
!ERROR: Invalid specification expression: dummy procedure argument
type(t(hasProcArg(realfunc))) :: x6
!ERROR: The expression (coarray[1_8]) cannot be used as a specification expression (coindexed reference)
!ERROR: Invalid specification expression: coindexed reference
type(t(coarray[1])) :: x7
type(t(kind(foo()))) :: x101 ! ok
type(t(modulefunc1(0))) :: x102 ! ok

8
flang/test/semantics/init01.f90
View File

@ -21,13 +21,13 @@ subroutine test(j)
real, save :: x3
real, target :: x4
real, target, save :: x5(10)
!ERROR: Pointer 'p1' cannot be initialized with a reference to an allocatable 'x1'
!ERROR: An initial data target may not be a reference to an ALLOCATABLE 'x1'
real, pointer :: p1 => x1
!ERROR: Pointer 'p2' cannot be initialized with a reference to a coarray 'x2'
!ERROR: An initial data target may not be a reference to a coarray 'x2'
real, pointer :: p2 => x2
!ERROR: Pointer 'p3' cannot be initialized with a reference to an object 'x3' that lacks the TARGET attribute
!ERROR: An initial data target may not be a reference to an object 'x3' that lacks the TARGET attribute
real, pointer :: p3 => x3
!ERROR: Pointer 'p4' cannot be initialized with a reference to an object 'x4' that lacks the SAVE attribute
!ERROR: An initial data target may not be a reference to an object 'x4' that lacks the SAVE attribute
real, pointer :: p4 => x4
!ERROR: Pointer 'p5' cannot be initialized with a reference to a designator with non-constant subscripts
real, pointer :: p5 => x5(j)

4
flang/test/semantics/modfile08.f90
View File

@ -1,4 +1,4 @@
! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
! Copyright (c) 2018-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.
@ -45,7 +45,7 @@ end
! type::t
! procedure(),nopass,pointer::e
! procedure(real(4)),nopass,pointer::f
! procedure(s),pointer,private::g
! procedure(s),pass(x),pointer,private::g
! end type
!contains
! subroutine s(x)

4
flang/test/semantics/modfile10.f90
View File

@ -1,4 +1,4 @@
! Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved.
! Copyright (c) 2018-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.
@ -75,7 +75,7 @@ end module
! integer(4)::x
! contains
! final::c
! procedure,non_overridable,private::d
! procedure,pass(x),non_overridable,private::d
! procedure(a),deferred,nopass::e
! end type
! type::t3

2
flang/test/semantics/modfile14.f90
View File

@ -51,7 +51,7 @@ end
! contains
! procedure,nopass::s2
! procedure,nopass::s3
! procedure::r
! procedure,pass(dtv)::r
! generic::foo=>s2
! generic::read(formatted)=>r
! end type

2
flang/test/semantics/modfile15.f90
View File

@ -31,7 +31,7 @@ end module
!Expect: m.mod
!module m
! type::t
! procedure(a),pass,pointer::c
! procedure(a),pass(x),pointer::c
! procedure(a),pass(x),pointer::d
! contains
! procedure,pass(y)::a