From 2d76abcd0794bc7de8e4ce6903b8641482b13742 Mon Sep 17 00:00:00 2001 From: peter klausler Date: Thu, 21 Feb 2019 17:05:46 -0800 Subject: [PATCH] [flang] checkpoint Original-commit: flang-compiler/f18@a2b1c94ddbec8bd5c311ebb0c086b8aa7a032bf5 Reviewed-on: https://github.com/flang-compiler/f18/pull/304 Tree-same-pre-rewrite: false --- flang/documentation/f2018-grammar.txt | 2 +- flang/lib/parser/grammar.h | 5 +- flang/lib/semantics/resolve-names.cc | 67 ++++++++++++++++++++++- flang/lib/semantics/type.h | 3 +- flang/test/semantics/procinterface01.f90 | 94 ++++++++++++++++++++++++++++++++ 5 files changed, 164 insertions(+), 7 deletions(-) create mode 100644 flang/test/semantics/procinterface01.f90 diff --git a/flang/documentation/f2018-grammar.txt b/flang/documentation/f2018-grammar.txt index 4f08a31..6a74f16 100644 --- a/flang/documentation/f2018-grammar.txt +++ b/flang/documentation/f2018-grammar.txt @@ -83,7 +83,7 @@ R703 declaration-type-spec -> R704 intrinsic-type-spec -> integer-type-spec | REAL [kind-selector] | DOUBLE PRECISION | COMPLEX [kind-selector] | CHARACTER [char-selector] | - LOGICAL [kind-selector] + LOGICAL [kind-selector] @ DOUBLE COMPLEX R705 integer-type-spec -> INTEGER [kind-selector] R706 kind-selector -> ( [KIND =] scalar-int-constant-expr ) @ * scalar-int-constant-expr diff --git a/flang/lib/parser/grammar.h b/flang/lib/parser/grammar.h index 3b8bc03..79e4365 100644 --- a/flang/lib/parser/grammar.h +++ b/flang/lib/parser/grammar.h @@ -3222,8 +3222,9 @@ TYPE_PARSER("PROCEDURE" >> // R1513 proc-interface -> interface-name | declaration-type-spec // R1516 interface-name -> name -TYPE_PARSER(construct(declarationTypeSpec) || - construct(name)) +// N.B. Simple names of intrinsic types (e.g., "REAL") are ambiguous here. +TYPE_PARSER(construct(name / lookAhead(")"_tok)) || + construct(declarationTypeSpec)) // R1514 proc-attr-spec -> // access-spec | proc-language-binding-spec | INTENT ( intent-spec ) | diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc index 376122e..61a719f 100644 --- a/flang/lib/semantics/resolve-names.cc +++ b/flang/lib/semantics/resolve-names.cc @@ -374,6 +374,9 @@ private: // Manage a stack of Scopes class ScopeHandler : public ImplicitRulesVisitor { public: + using ImplicitRulesVisitor::Post; + using ImplicitRulesVisitor::Pre; + Scope &currScope() { return *currScope_; } // The enclosing scope, skipping blocks and derived types. Scope &InclusiveScope(); @@ -618,6 +621,8 @@ class DeclarationVisitor : public ArraySpecVisitor, public: using ArraySpecVisitor::Post; using ArraySpecVisitor::Pre; + using ScopeHandler::Post; + using ScopeHandler::Pre; void Post(const parser::EntityDecl &); void Post(const parser::ObjectDecl &); @@ -654,6 +659,7 @@ public: void Post(const parser::IntrinsicTypeSpec::Complex &); void Post(const parser::IntrinsicTypeSpec::Logical &); void Post(const parser::IntrinsicTypeSpec::Character &); + void Post(const parser::IntrinsicTypeSpec::NCharacter &); void Post(const parser::CharSelector::LengthAndKind &); void Post(const parser::CharLength &); void Post(const parser::LengthSelector &); @@ -677,6 +683,7 @@ public: void Post(const parser::ProcedureDeclarationStmt &); bool Pre(const parser::ProcComponentDefStmt &); void Post(const parser::ProcComponentDefStmt &); + bool Pre(const parser::ProcInterface &x); void Post(const parser::ProcInterface &x); void Post(const parser::ProcDecl &x); bool Pre(const parser::TypeBoundProcedurePart &); @@ -2683,6 +2690,15 @@ void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Character &x) { std::move(*charInfo_.length), std::move(*charInfo_.kind))); charInfo_ = {}; } +void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::NCharacter &x) { + if (!charInfo_.length) { + charInfo_.length = ParamValue{1}; + } + CHECK(!charInfo_.kind.has_value()); + SetDeclTypeSpec(currScope().MakeCharacterType( + std::move(*charInfo_.length), KindExpr{2 /* EUC_JP */})); + charInfo_ = {}; +} void DeclarationVisitor::Post(const parser::CharSelector::LengthAndKind &x) { charInfo_.kind = EvaluateSubscriptIntExpr(x.kind); if (x.length) { @@ -3019,6 +3035,48 @@ bool DeclarationVisitor::Pre(const parser::ProcComponentDefStmt &) { void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &) { interfaceName_ = nullptr; } +bool DeclarationVisitor::Pre(const parser::ProcInterface &x) { + if (auto *name{std::get_if(&x.u)}) { + if (const Symbol * symbol{FindSymbol(*name)}) { + if (symbol->HasExplicitInterface()) { + return true; + } + } + // Simple names (lacking parameters and size) of intrinsic types re + // ambiguous in Fortran when used as instances of proc-interface. + // The parser recognizes them as interface-names since they can be + // overridden. When they turn out (here) to not be names of explicit + // interfaces, we need to replace their parses. + auto &proc{const_cast(x)}; + if (name->source == "integer"s) { + proc.u = parser::IntrinsicTypeSpec{parser::IntegerTypeSpec{std::nullopt}}; + } else if (name->source == "real") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::Real{std::nullopt}}; + } else if (name->source == "doubleprecision") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::DoublePrecision{}}; + } else if (name->source == "complex") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::Complex{std::nullopt}}; + } else if (name->source == "character") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::Character{std::nullopt}}; + } else if (name->source == "logical") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::Logical{std::nullopt}}; + } else if (name->source == "doublecomplex") { + proc.u = + parser::IntrinsicTypeSpec{parser::IntrinsicTypeSpec::DoubleComplex{}}; + } else if (name->source == "ncharacter") { + proc.u = parser::IntrinsicTypeSpec{ + parser::IntrinsicTypeSpec::NCharacter{std::nullopt}}; + } else { + // TODO pmk: allow intrinsic function names from Table 16.2. + } + } + return true; +} void DeclarationVisitor::Post(const parser::ProcInterface &x) { if (auto *name{std::get_if(&x.u)}) { interfaceName_ = name; @@ -3029,11 +3087,14 @@ void DeclarationVisitor::Post(const parser::ProcDecl &x) { const auto &name{std::get(x.t)}; ProcInterface interface; if (interfaceName_) { - if (auto *symbol{FindExplicitInterface(*interfaceName_)}) { + if (const Symbol * symbol{FindExplicitInterface(*interfaceName_)}) { interface.set_symbol(*symbol); } - } else if (auto *type{GetDeclTypeSpec()}) { - interface.set_type(*type); + } + if (interface.symbol() == nullptr) { + if (auto *type{GetDeclTypeSpec()}) { + interface.set_type(*type); + } } auto attrs{HandleSaveName(name.source, GetAttrs())}; if (currScope().kind() != Scope::Kind::DerivedType) { diff --git a/flang/lib/semantics/type.h b/flang/lib/semantics/type.h index 8b4962c..d710673 100644 --- a/flang/lib/semantics/type.h +++ b/flang/lib/semantics/type.h @@ -317,7 +317,8 @@ std::ostream &operator<<(std::ostream &, const DeclTypeSpec &); // This represents a proc-interface in the declaration of a procedure or // procedure component. It comprises a symbol (representing the specific // interface), a decl-type-spec (representing the function return type), -// or neither. +// or one of a list of specific intrinsic function names. +// TODO pmk WIP here class ProcInterface { public: const Symbol *symbol() const { return symbol_; } diff --git a/flang/test/semantics/procinterface01.f90 b/flang/test/semantics/procinterface01.f90 new file mode 100644 index 0000000..e315a42d --- /dev/null +++ b/flang/test/semantics/procinterface01.f90 @@ -0,0 +1,94 @@ +! 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. + +! Tests for "proc-interface" semantics +! These cases are all valid. + +module module1 + abstract interface + real elemental function abstract1(x) + real, intent(in) :: x + end function abstract1 + end interface + interface + real elemental function explicit1(x) + real, intent(in) :: x + end function explicit1 + integer function logical(x) ! name is ambiguous vs. decl-type-spec + real, intent(in) :: x + end function logical + character(1) function tan(x) + real, intent(in) :: x + end function tan + end interface + type :: derived1 + procedure(abstract1), pointer, nopass :: p1 => nested1 + procedure(explicit1), pointer, nopass :: p2 => nested1 + procedure(logical), pointer, nopass :: p3 => nested2 + procedure(logical(kind=4)), pointer, nopass :: p4 => nested3 + procedure(complex), pointer, nopass :: p5 => nested4 + procedure(sin), pointer, nopass :: p6 => nested1 + procedure(sin), pointer, nopass :: p7 => cos + procedure(tan), pointer, nopass :: p8 => nested5 + end type derived1 + contains + real elemental function nested1(x) + real, intent(in) :: x + nested1 = x + 1. + end function nested1 + integer function nested2(x) + real, intent(in) :: x + nested2 = x + 2. + end function nested2 + logical function nested3(x) + real, intent(in) :: x + nested3 = x > 0 + end function nested3 + complex function nested4(x) + real, intent(in) :: x + nested4 = cmplx(x + 4., 6.) + end function nested4 + character function nested5(x) + real, intent(in) :: x + nested5 = 'a' + end function nested5 +end module module1 + +real elemental function explicit1(x) + real, intent(in) :: x + explicit1 = -x +end function explicit1 + +integer function logical(x) + real, intent(in) :: x + logical = x + 3. +end function logical + +real function tan(x) + real, intent(in) :: x + tan = x + 5. +end function tan + +program main + use module1 + type(derived1) :: instance + if (instance%p1(1.) /= 2.) print *, "p1 failed" + if (instance%p2(1.) /= 2.) print *, "p2 failed" + if (instance%p3(1.) /= 3) print *, "p3 failed" + if (.not. instance%p4(1.)) print *, "p4 failed" + if (instance%p5(1.) /= (5.,6.)) print *, "p5 failed" + if (instance%p6(1.) /= 2.) print *, "p6 failed" + if (instance%p7(0.) /= 1.) print *, "p7 failed" + if (instance%p8(1.) /= 'a') print *, "p8 failed" +end program main -- 2.7.4