From 0c3c39d30e3f166a6a1303337c5fd7eead720fd0 Mon Sep 17 00:00:00 2001 From: "Jinxin (Brian) Yang" Date: Tue, 28 Jan 2020 12:51:35 -0800 Subject: [PATCH 01/18] [OpenMP] Name Resolution for OpenMP constructs (#940) This is an extended framework based on the previous work that addresses the NR on OpenMP directives/clauses (b2ea520). In this change: * New `OmpVisitor` is created (ResolveNamesVisitor derives from it) to create necessary scopes for certain OpenMP constructs. This is along with the regular Fortran NR process. * Old `OmpVisitor` is adjusted and converted to a standalone visitor-- `OmpAttributeVisitor`. This is used to walk through the OpenMP constructs and do the NR for variables on the OpenMP directives or data references within the OpenMP constructs. "Do the NR" here means that based on the NR results of the regular Fortran NR, fix the symbols of `Names` related to the OpenMP constructs. Note that there is an `OmpContext` in this visitor (similar to the one in `OmpStructureChecker`), this is necessary when dealing with the nested OpenMP constructs in the future. Given an OpenMP code: ``` real*8 a, b a = 1. b = 2. !$omp parallel private(a) a = 3. b = 4. !$omp end parallel print *, a, b end ``` w/o -fopenmp: ``` real*8 a, b !REF: /MainProgram1/a a = 1. !REF: /MainProgram1/b b = 2. !!!! OMP parallel !REF: /MainProgram1/a a = 3. !REF: /MainProgram1/b b = 4. !!!! OMP end parallel !REF: /MainProgram1/a !REF: /MainProgram1/b print *, a, b end ``` w/ -fopenmp: ``` real*8 a, b !REF: /MainProgram1/a a = 1. !REF: /MainProgram1/b b = 2. !$omp parallel private(a) <-- new Symbol for 'a' created !DEF: /MainProgram1/Block1/a (OmpPrivate) HostAssoc REAL(8) a = 3. <-- fix the old symbol with new Symbol in parallel scope !REF: /MainProgram1/b b = 4. <-- do nothing because by default it is shared in this scope !$omp end parallel !REF: /MainProgram1/a !REF: /MainProgram1/b print *, a, b end ``` Please note that this is a framework update, there are still many things on the TODO list for finishing the NR for OpenMP (based on the `OpenMP-semantics.md` design doc), which will be on top of this framework. Some TODO items: - Create a generic function to go through all the rules for deciding `predetermined`, `explicitly determined`, and `implicitly determined` data-sharing attributes. (This is the next biggest part) - Handle `Array Sections` and `Array or Structure Element`. - Take association into consideration for example Pointer association, `ASSOCIATE` construct, and etc. - Handle all the name resolution for directives/clauses that have `parser::Name`. * N.B. Extend `AddSourceRange` to apply to current and parent scopes - motivated by a few cases that need to call `AddSourceRange` for current & parent scopes; the extension should be safe - global scope is not included --- include/flang/parser/parse-tree.h | 6 + include/flang/semantics/symbol.h | 2 +- lib/parser/openmp-parsers.cpp | 24 +- lib/semantics/resolve-names.cpp | 679 ++++++++++++++++------- lib/semantics/scope.cpp | 5 +- test/semantics/CMakeLists.txt | 2 + test/semantics/omp-device-constructs.f90 | 2 +- test/semantics/omp-resolve05.f90 | 23 + test/semantics/omp-symbol07.f90 | 37 ++ 9 files changed, 569 insertions(+), 211 deletions(-) create mode 100644 test/semantics/omp-resolve05.f90 create mode 100644 test/semantics/omp-symbol07.f90 diff --git a/include/flang/parser/parse-tree.h b/include/flang/parser/parse-tree.h index 29638957f35b..57093e3903cb 100644 --- a/include/flang/parser/parse-tree.h +++ b/include/flang/parser/parse-tree.h @@ -3498,10 +3498,12 @@ struct OmpSectionsDirective { struct OmpBeginSectionsDirective { TUPLE_CLASS_BOILERPLATE(OmpBeginSectionsDirective); std::tuple t; + CharBlock source; }; struct OmpEndSectionsDirective { TUPLE_CLASS_BOILERPLATE(OmpEndSectionsDirective); std::tuple t; + CharBlock source; }; // [!$omp section] @@ -3742,21 +3744,25 @@ struct OpenMPStandaloneConstruct { struct OmpBeginLoopDirective { TUPLE_CLASS_BOILERPLATE(OmpBeginLoopDirective); std::tuple t; + CharBlock source; }; struct OmpEndLoopDirective { TUPLE_CLASS_BOILERPLATE(OmpEndLoopDirective); std::tuple t; + CharBlock source; }; struct OmpBeginBlockDirective { TUPLE_CLASS_BOILERPLATE(OmpBeginBlockDirective); std::tuple t; + CharBlock source; }; struct OmpEndBlockDirective { TUPLE_CLASS_BOILERPLATE(OmpEndBlockDirective); std::tuple t; + CharBlock source; }; struct OpenMPBlockConstruct { diff --git a/include/flang/semantics/symbol.h b/include/flang/semantics/symbol.h index 335e6ed936a5..faef1ca7af2b 100644 --- a/include/flang/semantics/symbol.h +++ b/include/flang/semantics/symbol.h @@ -467,7 +467,7 @@ class Symbol { // OpenMP miscellaneous flags OmpCommonBlock, OmpReduction, OmpDeclareSimd, OmpDeclareTarget, OmpThreadprivate, OmpDeclareReduction, OmpFlushed, OmpCriticalLock, - OmpIfSpecified); + OmpIfSpecified, OmpNone); using Flags = common::EnumSet; const Scope &owner() const { return *owner_; } diff --git a/lib/parser/openmp-parsers.cpp b/lib/parser/openmp-parsers.cpp index 076c3e8218a3..fd1b96191b24 100644 --- a/lib/parser/openmp-parsers.cpp +++ b/lib/parser/openmp-parsers.cpp @@ -280,8 +280,8 @@ TYPE_PARSER(sourced(construct(first( pure(OmpLoopDirective::Directive::TeamsDistributeSimd), "TEAMS DISTRIBUTE" >> pure(OmpLoopDirective::Directive::TeamsDistribute))))) -TYPE_PARSER(construct( - sourced(Parser{}), Parser{})) +TYPE_PARSER(sourced(construct( + sourced(Parser{}), Parser{}))) // 2.14.1 construct-type-clause -> PARALLEL | SECTIONS | DO | TASKGROUP TYPE_PARSER(sourced(construct( @@ -345,8 +345,8 @@ TYPE_PARSER(construct( "TEAMS" >> pure(OmpBlockDirective::Directive::Teams), "WORKSHARE" >> pure(OmpBlockDirective::Directive::Workshare)))) -TYPE_PARSER(construct( - sourced(Parser{}), Parser{})) +TYPE_PARSER(sourced(construct( + sourced(Parser{}), Parser{}))) TYPE_PARSER(construct( "INITIALIZER" >> parenthesized("OMP_PRIV =" >> expr))) @@ -482,12 +482,12 @@ TYPE_PARSER(construct( pure(OmpSectionsDirective::Directive::ParallelSections)))) // OMP BEGIN and END SECTIONS Directive -TYPE_PARSER(construct( - sourced(Parser{}), Parser{})) +TYPE_PARSER(sourced(construct( + sourced(Parser{}), Parser{}))) TYPE_PARSER( - startOmpLine >> construct( + startOmpLine >> sourced(construct( sourced("END"_tok >> Parser{}), - Parser{})) + Parser{}))) // OMP SECTION-BLOCK TYPE_PARSER(maybe(startOmpLine >> "SECTION"_tok / endOmpLine) >> @@ -512,15 +512,15 @@ TYPE_CONTEXT_PARSER("OpenMP construct"_en_US, // END OMP Block directives TYPE_PARSER( - startOmpLine >> construct( + startOmpLine >> sourced(construct( sourced("END"_tok >> Parser{}), - Parser{})) + Parser{}))) // END OMP Loop directives TYPE_PARSER( - startOmpLine >> construct( + startOmpLine >> sourced(construct( sourced("END"_tok >> Parser{}), - Parser{})) + Parser{}))) TYPE_PARSER(construct( Parser{} / endOmpLine)) diff --git a/lib/semantics/resolve-names.cpp b/lib/semantics/resolve-names.cpp index e6a9b7f9bfeb..ca8e26700128 100644 --- a/lib/semantics/resolve-names.cpp +++ b/lib/semantics/resolve-names.cpp @@ -8,6 +8,7 @@ #include "resolve-names.h" #include "assignment.h" +#include "check-omp-structure.h" #include "mod-file.h" #include "program-tree.h" #include "resolve-names-utils.h" @@ -444,12 +445,7 @@ class ScopeHandler : public ImplicitRulesVisitor { template bool Pre(const parser::Statement &x) { messageHandler().set_currStmtSource(x.source); - for (auto *scope = currScope_; scope; scope = &scope->parent()) { - scope->AddSourceRange(x.source); - if (scope->IsGlobal()) { - break; - } - } + currScope_->AddSourceRange(x.source); return true; } template void Post(const parser::Statement &) { @@ -786,6 +782,8 @@ class DeclarationVisitor : public ArraySpecVisitor, void CheckExplicitInterface(const parser::Name &); void CheckBindings(const parser::TypeBoundProcedureStmt::WithoutInterface &); + const parser::Name *ResolveDesignator(const parser::Designator &); + protected: bool BeginDecl(); void EndDecl(); @@ -814,7 +812,6 @@ class DeclarationVisitor : public ArraySpecVisitor, // or nullptr in case of error. const parser::Name *ResolveStructureComponent( const parser::StructureComponent &); - const parser::Name *ResolveDesignator(const parser::Designator &); const parser::Name *ResolveDataRef(const parser::DataRef &); const parser::Name *ResolveVariable(const parser::Variable &); const parser::Name *ResolveName(const parser::Name &); @@ -1045,43 +1042,132 @@ class ConstructVisitor : public virtual DeclarationVisitor { void PopAssociation(); }; -// Resolve OpenMP construct entities and statement (TODO) entities +// Create scopes for OpenMP constructs class OmpVisitor : public virtual DeclarationVisitor { public: - static const parser::Name *GetDesignatorNameIfDataRef( - const parser::Designator &designator) { - const auto *dataRef{std::get_if(&designator.u)}; - return dataRef ? std::get_if(&dataRef->u) : nullptr; - } + void AddOmpSourceRange(const parser::CharBlock &); - bool Pre(const parser::OpenMPBlockConstruct &) { - PushScope(Scope::Kind::Block, nullptr); + static bool NeedsScope(const parser::OpenMPBlockConstruct &); + + bool Pre(const parser::OpenMPBlockConstruct &); + void Post(const parser::OpenMPBlockConstruct &); + bool Pre(const parser::OmpBeginBlockDirective &x) { + AddOmpSourceRange(x.source); return true; } - void Post(const parser::OpenMPBlockConstruct &) { PopScope(); } - bool Pre(const parser::OmpBeginBlockDirective &) { - ClearDataSharingAttributeObjects(); + void Post(const parser::OmpBeginBlockDirective &) { + messageHandler().set_currStmtSource(std::nullopt); + } + bool Pre(const parser::OmpEndBlockDirective &x) { + AddOmpSourceRange(x.source); return true; } + void Post(const parser::OmpEndBlockDirective &) { + messageHandler().set_currStmtSource(std::nullopt); + } bool Pre(const parser::OpenMPLoopConstruct &) { PushScope(Scope::Kind::Block, nullptr); return true; } void Post(const parser::OpenMPLoopConstruct &) { PopScope(); } - bool Pre(const parser::OmpBeginLoopDirective &) { - ClearDataSharingAttributeObjects(); + bool Pre(const parser::OmpBeginLoopDirective &x) { + AddOmpSourceRange(x.source); + return true; + } + void Post(const parser::OmpBeginLoopDirective &) { + messageHandler().set_currStmtSource(std::nullopt); + } + bool Pre(const parser::OmpEndLoopDirective &x) { + AddOmpSourceRange(x.source); + return true; + } + void Post(const parser::OmpEndLoopDirective &) { + messageHandler().set_currStmtSource(std::nullopt); + } + + bool Pre(const parser::OpenMPSectionsConstruct &) { + PushScope(Scope::Kind::Block, nullptr); + return true; + } + void Post(const parser::OpenMPSectionsConstruct &) { PopScope(); } + bool Pre(const parser::OmpBeginSectionsDirective &x) { + AddOmpSourceRange(x.source); + return true; + } + void Post(const parser::OmpBeginSectionsDirective &) { + messageHandler().set_currStmtSource(std::nullopt); + } + bool Pre(const parser::OmpEndSectionsDirective &x) { + AddOmpSourceRange(x.source); return true; } + void Post(const parser::OmpEndSectionsDirective &) { + messageHandler().set_currStmtSource(std::nullopt); + } +}; + +bool OmpVisitor::NeedsScope(const parser::OpenMPBlockConstruct &x) { + const auto &beginBlockDir{std::get(x.t)}; + const auto &beginDir{std::get(beginBlockDir.t)}; + switch (beginDir.v) { + case parser::OmpBlockDirective::Directive::TargetData: + case parser::OmpBlockDirective::Directive::Master: + case parser::OmpBlockDirective::Directive::Ordered: return false; + default: return true; + } +} - bool Pre(const parser::OpenMPThreadprivate &x) { +void OmpVisitor::AddOmpSourceRange(const parser::CharBlock &source) { + messageHandler().set_currStmtSource(source); + currScope().AddSourceRange(source); +} + +bool OmpVisitor::Pre(const parser::OpenMPBlockConstruct &x) { + if (NeedsScope(x)) { PushScope(Scope::Kind::Block, nullptr); - const auto &list{std::get(x.t)}; - ResolveOmpObjectList(list, Symbol::Flag::OmpThreadprivate); + } + return true; +} + +void OmpVisitor::Post(const parser::OpenMPBlockConstruct &x) { + if (NeedsScope(x)) { PopScope(); - return false; } +} + +// Data-sharing and Data-mapping attributes for data-refs in OpenMP construct +class OmpAttributeVisitor { +public: + explicit OmpAttributeVisitor( + SemanticsContext &context, ResolveNamesVisitor &resolver) + : context_{context}, resolver_{resolver} {} + + template void Walk(const A &x) { parser::Walk(x, *this); } + + template bool Pre(const A &) { return true; } + template void Post(const A &) {} + + bool Pre(const parser::OpenMPBlockConstruct &); + void Post(const parser::OpenMPBlockConstruct &) { PopContext(); } + void Post(const parser::OmpBeginBlockDirective &) { + GetContext().withinConstruct = true; + } + + bool Pre(const parser::OpenMPLoopConstruct &); + void Post(const parser::OpenMPLoopConstruct &) { PopContext(); } + void Post(const parser::OmpBeginLoopDirective &) { + GetContext().withinConstruct = true; + } + + bool Pre(const parser::OpenMPSectionsConstruct &); + void Post(const parser::OpenMPSectionsConstruct &) { PopContext(); } + + bool Pre(const parser::OpenMPThreadprivate &); + void Post(const parser::OpenMPThreadprivate &) { PopContext(); } + // 2.15.3 Data-Sharing Attribute Clauses + void Post(const parser::OmpDefaultClause &); bool Pre(const parser::OmpClause::Shared &x) { ResolveOmpObjectList(x.v, Symbol::Flag::OmpShared); return false; @@ -1099,7 +1185,60 @@ class OmpVisitor : public virtual DeclarationVisitor { return false; } + void Post(const parser::Name &); + private: + struct OmpContext { + OmpContext(const parser::CharBlock &source, OmpDirective d, Scope &s) + : directiveSource{source}, directive{d}, scope{s} {} + parser::CharBlock directiveSource; + OmpDirective directive; + Scope &scope; + // TODO: default DSA is implicitly determined in different ways + Symbol::Flag defaultDSA{Symbol::Flag::OmpShared}; + // variables on Data-sharing attribute clauses + std::map objectWithDSA; + bool withinConstruct{false}; + }; + // back() is the top of the stack + OmpContext &GetContext() { + CHECK(!ompContext_.empty()); + return ompContext_.back(); + } + void PushContext(const parser::CharBlock &source, OmpDirective dir) { + ompContext_.emplace_back(source, dir, context_.FindScope(source)); + } + void PopContext() { ompContext_.pop_back(); } + void SetContextDirectiveSource(parser::CharBlock &dir) { + GetContext().directiveSource = dir; + } + void SetContextDirectiveEnum(OmpDirective dir) { + GetContext().directive = dir; + } + const Scope &currScope() { return GetContext().scope; } + void SetContextDefaultDSA(Symbol::Flag flag) { + GetContext().defaultDSA = flag; + } + void AddToContextObjectWithDSA(const Symbol &symbol, Symbol::Flag flag) { + GetContext().objectWithDSA.emplace(&symbol, flag); + } + bool IsObjectWithDSA(const Symbol &symbol) { + auto it{GetContext().objectWithDSA.find(&symbol)}; + return it != GetContext().objectWithDSA.end(); + } + + Symbol &MakeAssocSymbol(const SourceName &name, Symbol &prev) { + const auto pair{ + GetContext().scope.try_emplace(name, Attrs{}, HostAssocDetails{prev})}; + return *pair.first->second; + } + + static const parser::Name *GetDesignatorNameIfDataRef( + const parser::Designator &designator) { + const auto *dataRef{std::get_if(&designator.u)}; + return dataRef ? std::get_if(&dataRef->u) : nullptr; + } + static constexpr Symbol::Flags dataSharingAttributeFlags{ Symbol::Flag::OmpShared, Symbol::Flag::OmpPrivate, Symbol::Flag::OmpFirstPrivate, Symbol::Flag::OmpLastPrivate, @@ -1121,185 +1260,23 @@ class OmpVisitor : public virtual DeclarationVisitor { } bool HasDataSharingAttributeObject(const Symbol &); - // TODO: resolve variables referenced in the OpenMP region void ResolveOmpObjectList(const parser::OmpObjectList &, Symbol::Flag); void ResolveOmpObject(const parser::OmpObject &, Symbol::Flag); - Symbol &ResolveOmp(const parser::Name &, Symbol::Flag); - Symbol &ResolveOmp(Symbol &, Symbol::Flag); + Symbol *ResolveOmp(const parser::Name &, Symbol::Flag); + Symbol *ResolveOmp(Symbol &, Symbol::Flag); Symbol *ResolveOmpCommonBlockName(const parser::Name *); - Symbol &DeclarePrivateAccessEntity(const parser::Name &, Symbol::Flag); - Symbol &DeclarePrivateAccessEntity(Symbol &, Symbol::Flag); - Symbol &DeclareOrMarkOtherAccessEntity(const parser::Name &, Symbol::Flag); - Symbol &DeclareOrMarkOtherAccessEntity(Symbol &, Symbol::Flag); + Symbol *DeclarePrivateAccessEntity(const parser::Name &, Symbol::Flag); + Symbol *DeclarePrivateAccessEntity(Symbol &, Symbol::Flag); + Symbol *DeclareOrMarkOtherAccessEntity(const parser::Name &, Symbol::Flag); + Symbol *DeclareOrMarkOtherAccessEntity(Symbol &, Symbol::Flag); void CheckMultipleAppearances( const parser::Name &, const Symbol &, Symbol::Flag); - SymbolSet dataSharingAttributeObjects_; // on one directive -}; - -bool OmpVisitor::HasDataSharingAttributeObject(const Symbol &object) { - auto it{dataSharingAttributeObjects_.find(object)}; - return it != dataSharingAttributeObjects_.end(); -} - -Symbol *OmpVisitor::ResolveOmpCommonBlockName(const parser::Name *name) { - if (auto *prev{name ? currScope().parent().FindCommonBlock(name->source) - : nullptr}) { - name->symbol = prev; - return prev; - } else { - return nullptr; - } -} -void OmpVisitor::ResolveOmpObjectList( - const parser::OmpObjectList &ompObjectList, Symbol::Flag ompFlag) { - for (const auto &ompObject : ompObjectList.v) { - ResolveOmpObject(ompObject, ompFlag); - } -} - -void OmpVisitor::ResolveOmpObject( - const parser::OmpObject &ompObject, Symbol::Flag ompFlag) { - std::visit( - common::visitors{ - [&](const parser::Designator &designator) { - if (const auto *name{GetDesignatorNameIfDataRef(designator)}) { - auto &symbol{ResolveOmp(*name, ompFlag)}; - if (dataSharingAttributeFlags.test(ompFlag)) { - CheckMultipleAppearances(*name, symbol, ompFlag); - } - } else if (const auto *name{ResolveDesignator(designator)}; - name && name->symbol) { - // Array sections to be changed to substrings as needed - if (AnalyzeExpr(context(), designator)) { - if (std::holds_alternative(designator.u)) { - Say(designator.source, - "Substrings are not allowed on OpenMP " - "directives or clauses"_err_en_US); - return; - } - } - // other checks, more TBD - if (const auto *details{ - name->symbol->detailsIf()}) { - if (details->IsArray()) { - // TODO: check Array Sections - } else if (name->symbol->owner().IsDerivedType()) { - // TODO: check Structure Component - } - } - } - }, - [&](const parser::Name &name) { // common block - if (auto *symbol{ResolveOmpCommonBlockName(&name)}) { - CheckMultipleAppearances( - name, *symbol, Symbol::Flag::OmpCommonBlock); - // 2.15.3 When a named common block appears in a list, it has the - // same meaning as if every explicit member of the common block - // appeared in the list - for (const Symbol &object : - symbol->get().objects()) { - Symbol &mutableObject{const_cast(object)}; - ResolveOmp(mutableObject, ompFlag); - } - } else { - Say(name.source, // 2.15.3 - "COMMON block must be declared in the same scoping unit " - "in which the OpenMP directive or clause appears"_err_en_US); - } - }, - }, - ompObject.u); -} - -Symbol &OmpVisitor::ResolveOmp(const parser::Name &name, Symbol::Flag ompFlag) { - if (ompFlagsRequireNewSymbol.test(ompFlag)) { - return DeclarePrivateAccessEntity(name, ompFlag); - } else { - return DeclareOrMarkOtherAccessEntity(name, ompFlag); - } -} - -Symbol &OmpVisitor::ResolveOmp(Symbol &symbol, Symbol::Flag ompFlag) { - if (ompFlagsRequireNewSymbol.test(ompFlag)) { - return DeclarePrivateAccessEntity(symbol, ompFlag); - } else { - return DeclareOrMarkOtherAccessEntity(symbol, ompFlag); - } -} - -Symbol &OmpVisitor::DeclarePrivateAccessEntity( - const parser::Name &name, Symbol::Flag ompFlag) { - Symbol &prev{FindOrDeclareEnclosingEntity(name)}; - if (prev.owner() != currScope()) { - auto &symbol{MakeSymbol(name, HostAssocDetails{prev})}; - symbol.set(ompFlag); - name.symbol = &symbol; // override resolution to parent - return symbol; - } else { - prev.set(ompFlag); - return prev; - } -} - -Symbol &OmpVisitor::DeclarePrivateAccessEntity( - Symbol &object, Symbol::Flag ompFlag) { - if (object.owner() != currScope() && - !FindInScope(currScope(), object.name())) { - auto &symbol{MakeSymbol(object.name(), Attrs{}, HostAssocDetails{object})}; - symbol.set(ompFlag); - return symbol; - } else { - object.set(ompFlag); - return object; - } -} - -Symbol &OmpVisitor::DeclareOrMarkOtherAccessEntity( - const parser::Name &name, Symbol::Flag ompFlag) { - Symbol &prev{FindOrDeclareEnclosingEntity(name)}; - name.symbol = &prev; - if (ompFlagsRequireMark.test(ompFlag)) { - prev.set(ompFlag); - } - return prev; -} - -Symbol &OmpVisitor::DeclareOrMarkOtherAccessEntity( - Symbol &object, Symbol::Flag ompFlag) { - if (ompFlagsRequireMark.test(ompFlag)) { - object.set(ompFlag); - } - return object; -} - -static bool WithMultipleAppearancesException( - const Symbol &symbol, Symbol::Flag ompFlag) { - return (ompFlag == Symbol::Flag::OmpFirstPrivate && - symbol.test(Symbol::Flag::OmpLastPrivate)) || - (ompFlag == Symbol::Flag::OmpLastPrivate && - symbol.test(Symbol::Flag::OmpFirstPrivate)); -} - -void OmpVisitor::CheckMultipleAppearances( - const parser::Name &name, const Symbol &symbol, Symbol::Flag ompFlag) { - const auto *target{&symbol}; - if (ompFlagsRequireNewSymbol.test(ompFlag)) { - if (const auto *details{symbol.detailsIf()}) { - target = &details->symbol(); - } - } - if (HasDataSharingAttributeObject(*target) && - !WithMultipleAppearancesException(symbol, ompFlag)) { - Say(name.source, - "'%s' appears in more than one data-sharing clause " - "on the same OpenMP directive"_err_en_US, - name.ToString()); - } else { - AddDataSharingAttributeObject(*target); - } -} + SemanticsContext &context_; + ResolveNamesVisitor &resolver_; + std::vector ompContext_; // used as a stack +}; // Walk the parse tree and resolve names to symbols. class ResolveNamesVisitor : public virtual ScopeHandler, @@ -5730,6 +5707,7 @@ bool ResolveNamesVisitor::Pre(const parser::ProgramUnit &x) { ResolveSpecificationParts(root); FinishSpecificationParts(root); ResolveExecutionParts(root); + OmpAttributeVisitor{context(), *this}.Walk(x); return false; } @@ -5915,6 +5893,315 @@ class DeferredCheckVisitor { bool pushedScope_{false}; }; +bool OmpAttributeVisitor::Pre(const parser::OpenMPBlockConstruct &x) { + const auto &beginBlockDir{std::get(x.t)}; + const auto &beginDir{std::get(beginBlockDir.t)}; + switch (beginDir.v) { + case parser::OmpBlockDirective::Directive::Master: + PushContext(beginDir.source, OmpDirective::MASTER); + break; + case parser::OmpBlockDirective::Directive::Ordered: + PushContext(beginDir.source, OmpDirective::ORDERED); + break; + case parser::OmpBlockDirective::Directive::Parallel: + PushContext(beginDir.source, OmpDirective::PARALLEL); + break; + case parser::OmpBlockDirective::Directive::Single: + PushContext(beginDir.source, OmpDirective::SINGLE); + break; + case parser::OmpBlockDirective::Directive::Target: + PushContext(beginDir.source, OmpDirective::TARGET); + break; + case parser::OmpBlockDirective::Directive::TargetData: + PushContext(beginDir.source, OmpDirective::TARGET_DATA); + break; + case parser::OmpBlockDirective::Directive::Task: + PushContext(beginDir.source, OmpDirective::TASK); + break; + case parser::OmpBlockDirective::Directive::Teams: + PushContext(beginDir.source, OmpDirective::TEAMS); + break; + case parser::OmpBlockDirective::Directive::Workshare: + PushContext(beginDir.source, OmpDirective::WORKSHARE); + break; + default: + // TODO others + break; + } + ClearDataSharingAttributeObjects(); + return true; +} + +bool OmpAttributeVisitor::Pre(const parser::OpenMPLoopConstruct &x) { + const auto &beginLoopDir{std::get(x.t)}; + const auto &beginDir{std::get(beginLoopDir.t)}; + switch (beginDir.v) { + case parser::OmpLoopDirective::Directive::Distribute: + PushContext(beginDir.source, OmpDirective::DISTRIBUTE); + break; + case parser::OmpLoopDirective::Directive::Do: + PushContext(beginDir.source, OmpDirective::DO); + break; + case parser::OmpLoopDirective::Directive::DoSimd: + PushContext(beginDir.source, OmpDirective::DO_SIMD); + break; + case parser::OmpLoopDirective::Directive::ParallelDo: + PushContext(beginDir.source, OmpDirective::PARALLEL_DO); + break; + case parser::OmpLoopDirective::Directive::ParallelDoSimd: + PushContext(beginDir.source, OmpDirective::PARALLEL_DO_SIMD); + break; + case parser::OmpLoopDirective::Directive::Simd: + PushContext(beginDir.source, OmpDirective::SIMD); + break; + case parser::OmpLoopDirective::Directive::Taskloop: + PushContext(beginDir.source, OmpDirective::TASKLOOP); + break; + case parser::OmpLoopDirective::Directive::TaskloopSimd: + PushContext(beginDir.source, OmpDirective::TASKLOOP_SIMD); + break; + default: + // TODO others + break; + } + ClearDataSharingAttributeObjects(); + return true; +} + +bool OmpAttributeVisitor::Pre(const parser::OpenMPSectionsConstruct &x) { + const auto &beginSectionsDir{ + std::get(x.t)}; + const auto &beginDir{ + std::get(beginSectionsDir.t)}; + switch (beginDir.v) { + case parser::OmpSectionsDirective::Directive::ParallelSections: + PushContext(beginDir.source, OmpDirective::PARALLEL_SECTIONS); + break; + case parser::OmpSectionsDirective::Directive::Sections: + PushContext(beginDir.source, OmpDirective::SECTIONS); + break; + default: break; + } + ClearDataSharingAttributeObjects(); + return true; +} + +bool OmpAttributeVisitor::Pre(const parser::OpenMPThreadprivate &x) { + PushContext(x.source, OmpDirective::THREADPRIVATE); + const auto &list{std::get(x.t)}; + ResolveOmpObjectList(list, Symbol::Flag::OmpThreadprivate); + return false; +} + +void OmpAttributeVisitor::Post(const parser::OmpDefaultClause &x) { + if (!ompContext_.empty()) { + switch (x.v) { + case parser::OmpDefaultClause::Type::Private: + SetContextDefaultDSA(Symbol::Flag::OmpPrivate); + break; + case parser::OmpDefaultClause::Type::Firstprivate: + SetContextDefaultDSA(Symbol::Flag::OmpFirstPrivate); + break; + case parser::OmpDefaultClause::Type::Shared: + SetContextDefaultDSA(Symbol::Flag::OmpShared); + break; + case parser::OmpDefaultClause::Type::None: + SetContextDefaultDSA(Symbol::Flag::OmpNone); + break; + } + } +} + +// For OpenMP constructs, check all the data-refs within the constructs +// and adjust the symbol for each Name if necessary +void OmpAttributeVisitor::Post(const parser::Name &name) { + auto *symbol{name.symbol}; + if (symbol && !ompContext_.empty() && GetContext().withinConstruct) { + if (!symbol->owner().IsDerivedType() && !symbol->has() && + !IsObjectWithDSA(*symbol)) { + // TODO: create a separate function to go through the rules for + // predetermined, explicitly determined, and implicitly + // determined data-sharing attributes (2.15.1.1). + if (Symbol * found{currScope().FindSymbol(name.source)}) { + if (IsObjectWithDSA(*found)) { + name.symbol = found; // adjust the symbol within region + } else if (GetContext().defaultDSA == Symbol::Flag::OmpNone) { + context_.Say(name.source, + "The DEFAULT(NONE) clause requires that '%s' must be listed in " + "a data-sharing attribute clause"_err_en_US, + symbol->name()); + } + } + } + } // within OpenMP construct +} + +bool OmpAttributeVisitor::HasDataSharingAttributeObject(const Symbol &object) { + auto it{dataSharingAttributeObjects_.find(object)}; + return it != dataSharingAttributeObjects_.end(); +} + +Symbol *OmpAttributeVisitor::ResolveOmpCommonBlockName( + const parser::Name *name) { + if (auto *prev{name + ? GetContext().scope.parent().FindCommonBlock(name->source) + : nullptr}) { + name->symbol = prev; + return prev; + } else { + return nullptr; + } +} + +void OmpAttributeVisitor::ResolveOmpObjectList( + const parser::OmpObjectList &ompObjectList, Symbol::Flag ompFlag) { + for (const auto &ompObject : ompObjectList.v) { + ResolveOmpObject(ompObject, ompFlag); + } +} + +void OmpAttributeVisitor::ResolveOmpObject( + const parser::OmpObject &ompObject, Symbol::Flag ompFlag) { + std::visit( + common::visitors{ + [&](const parser::Designator &designator) { + if (const auto *name{GetDesignatorNameIfDataRef(designator)}) { + if (auto *symbol{ResolveOmp(*name, ompFlag)}) { + AddToContextObjectWithDSA(*symbol, ompFlag); + if (dataSharingAttributeFlags.test(ompFlag)) { + CheckMultipleAppearances(*name, *symbol, ompFlag); + } + } + } else if (const auto *designatorName{ + resolver_.ResolveDesignator(designator)}; + designatorName->symbol) { + // Array sections to be changed to substrings as needed + if (AnalyzeExpr(context_, designator)) { + if (std::holds_alternative(designator.u)) { + context_.Say(designator.source, + "Substrings are not allowed on OpenMP " + "directives or clauses"_err_en_US); + } + } + // other checks, more TBD + if (const auto *details{designatorName->symbol + ->detailsIf()}) { + if (details->IsArray()) { + // TODO: check Array Sections + } else if (designatorName->symbol->owner().IsDerivedType()) { + // TODO: check Structure Component + } + } + } + }, + [&](const parser::Name &name) { // common block + if (auto *symbol{ResolveOmpCommonBlockName(&name)}) { + CheckMultipleAppearances( + name, *symbol, Symbol::Flag::OmpCommonBlock); + // 2.15.3 When a named common block appears in a list, it has the + // same meaning as if every explicit member of the common block + // appeared in the list + for (const Symbol &object : + symbol->get().objects()) { + Symbol &mutableObject{const_cast(object)}; + if (auto *resolvedObject{ResolveOmp(mutableObject, ompFlag)}) { + AddToContextObjectWithDSA(*resolvedObject, ompFlag); + } + } + } else { + context_.Say(name.source, // 2.15.3 + "COMMON block must be declared in the same scoping unit " + "in which the OpenMP directive or clause appears"_err_en_US); + } + }, + }, + ompObject.u); +} + +Symbol *OmpAttributeVisitor::ResolveOmp( + const parser::Name &name, Symbol::Flag ompFlag) { + if (ompFlagsRequireNewSymbol.test(ompFlag)) { + return DeclarePrivateAccessEntity(name, ompFlag); + } else { + return DeclareOrMarkOtherAccessEntity(name, ompFlag); + } +} + +Symbol *OmpAttributeVisitor::ResolveOmp(Symbol &symbol, Symbol::Flag ompFlag) { + if (ompFlagsRequireNewSymbol.test(ompFlag)) { + return DeclarePrivateAccessEntity(symbol, ompFlag); + } else { + return DeclareOrMarkOtherAccessEntity(symbol, ompFlag); + } +} + +Symbol *OmpAttributeVisitor::DeclarePrivateAccessEntity( + const parser::Name &name, Symbol::Flag ompFlag) { + if (!name.symbol) { + return nullptr; // not resolved by Name Resolution step, do nothing + } + name.symbol = DeclarePrivateAccessEntity(*name.symbol, ompFlag); + return name.symbol; +} + +Symbol *OmpAttributeVisitor::DeclarePrivateAccessEntity( + Symbol &object, Symbol::Flag ompFlag) { + if (object.owner() != currScope()) { + auto &symbol{MakeAssocSymbol(object.name(), object)}; + symbol.set(ompFlag); + return &symbol; + } else { + object.set(ompFlag); + return &object; + } +} + +Symbol *OmpAttributeVisitor::DeclareOrMarkOtherAccessEntity( + const parser::Name &name, Symbol::Flag ompFlag) { + Symbol *prev{currScope().FindSymbol(name.source)}; + if (!name.symbol || !prev) { + return nullptr; + } else if (prev != name.symbol) { + name.symbol = prev; + } + return DeclareOrMarkOtherAccessEntity(*prev, ompFlag); +} + +Symbol *OmpAttributeVisitor::DeclareOrMarkOtherAccessEntity( + Symbol &object, Symbol::Flag ompFlag) { + if (ompFlagsRequireMark.test(ompFlag)) { + object.set(ompFlag); + } + return &object; +} + +static bool WithMultipleAppearancesException( + const Symbol &symbol, Symbol::Flag ompFlag) { + return (ompFlag == Symbol::Flag::OmpFirstPrivate && + symbol.test(Symbol::Flag::OmpLastPrivate)) || + (ompFlag == Symbol::Flag::OmpLastPrivate && + symbol.test(Symbol::Flag::OmpFirstPrivate)); +} + +void OmpAttributeVisitor::CheckMultipleAppearances( + const parser::Name &name, const Symbol &symbol, Symbol::Flag ompFlag) { + const auto *target{&symbol}; + if (ompFlagsRequireNewSymbol.test(ompFlag)) { + if (const auto *details{symbol.detailsIf()}) { + target = &details->symbol(); + } + } + if (HasDataSharingAttributeObject(*target) && + !WithMultipleAppearancesException(symbol, ompFlag)) { + context_.Say(name.source, + "'%s' appears in more than one data-sharing clause " + "on the same OpenMP directive"_err_en_US, + name.ToString()); + } else { + AddDataSharingAttributeObject(*target); + } +} + // Perform checks and completions that need to happen after all of // the specification parts but before any of the execution parts. void ResolveNamesVisitor::FinishSpecificationParts(const ProgramTree &node) { diff --git a/lib/semantics/scope.cpp b/lib/semantics/scope.cpp index 96400b626f03..9db599560650 100644 --- a/lib/semantics/scope.cpp +++ b/lib/semantics/scope.cpp @@ -244,7 +244,10 @@ Scope *Scope::FindScope(parser::CharBlock source) { } void Scope::AddSourceRange(const parser::CharBlock &source) { - sourceRange_.ExtendToCover(source); + for (auto *scope = this; !scope->IsGlobal(); + scope = &scope->parent()) { + scope->sourceRange_.ExtendToCover(source); + } } std::ostream &operator<<(std::ostream &os, const Scope &scope) { diff --git a/test/semantics/CMakeLists.txt b/test/semantics/CMakeLists.txt index 1765b4367ef0..5dfbcb2bf928 100644 --- a/test/semantics/CMakeLists.txt +++ b/test/semantics/CMakeLists.txt @@ -163,6 +163,7 @@ set(ERROR_TESTS omp-resolve02.f90 omp-resolve03.f90 omp-resolve04.f90 + omp-resolve05.f90 omp-clause-validity01.f90 omp-loop-association.f90 # omp-nested01.f90 @@ -227,6 +228,7 @@ set(SYMBOL_TESTS omp-symbol04.f90 omp-symbol05.f90 omp-symbol06.f90 + omp-symbol07.f90 kinds01.f90 kinds03.f90 procinterface01.f90 diff --git a/test/semantics/omp-device-constructs.f90 b/test/semantics/omp-device-constructs.f90 index ca9468707253..118e49c9afc9 100644 --- a/test/semantics/omp-device-constructs.f90 +++ b/test/semantics/omp-device-constructs.f90 @@ -91,7 +91,7 @@ program main !$omp end teams !ERROR: At most one DEFAULT clause can appear on the TEAMS directive - !$omp teams default(shared) default(none) + !$omp teams default(shared) default(private) do i = 1, N a = 3.14 enddo diff --git a/test/semantics/omp-resolve05.f90 b/test/semantics/omp-resolve05.f90 new file mode 100644 index 000000000000..0ba4fd816d92 --- /dev/null +++ b/test/semantics/omp-resolve05.f90 @@ -0,0 +1,23 @@ +!OPTIONS: -fopenmp + +! 2.15.3 Data-Sharing Attribute Clauses +! 2.15.3.1 default Clause + +subroutine default_none() + integer a(3) + + A = 1 + B = 2 + !$omp parallel default(none) private(c) + !ERROR: The DEFAULT(NONE) clause requires that 'a' must be listed in a data-sharing attribute clause + A(1:2) = 3 + !ERROR: The DEFAULT(NONE) clause requires that 'b' must be listed in a data-sharing attribute clause + B = 4 + C = 5 + !$omp end parallel +end subroutine default_none + +program mm + call default_none() + !TODO: private, firstprivate, shared +end diff --git a/test/semantics/omp-symbol07.f90 b/test/semantics/omp-symbol07.f90 new file mode 100644 index 000000000000..170452959e01 --- /dev/null +++ b/test/semantics/omp-symbol07.f90 @@ -0,0 +1,37 @@ +!OPTIONS: -fopenmp + +! Generic tests +! 1. subroutine or function calls should not be fixed for DSA or DMA + +!DEF: /foo (Function) Subprogram REAL(4) +!DEF: /foo/rnum ObjectEntity REAL(4) +function foo(rnum) + !REF: /foo/rnum + real rnum + !REF: /foo/rnum + rnum = rnum+1. +end function foo +!DEF: /function_call_in_region EXTERNAL (Subroutine) Subprogram +subroutine function_call_in_region + implicit none + !DEF: /function_call_in_region/foo (Function) ProcEntity REAL(4) + real foo + !DEF: /function_call_in_region/a ObjectEntity REAL(4) + real :: a = 0. + !DEF: /function_call_in_region/b ObjectEntity REAL(4) + real :: b = 5. + !$omp parallel default(none) private(a) shared(b) + !DEF: /function_call_in_region/Block1/a (OmpPrivate) HostAssoc REAL(4) + !REF: /function_call_in_region/foo + !REF: /function_call_in_region/b + a = foo(b) + !$omp end parallel + !REF: /function_call_in_region/a + !REF: /function_call_in_region/b + print *, a, b +end subroutine function_call_in_region +!DEF: /mm MainProgram +program mm + !REF: /function_call_in_region + call function_call_in_region +end program mm From 3f37e0dbaf32f1127553be2149915cab1b93cdcf Mon Sep 17 00:00:00 2001 From: Jinxin Yang Date: Tue, 28 Jan 2020 13:58:14 -0800 Subject: [PATCH 02/18] Remove `default` case for OmpSectionsDirective (only two enum values) --- lib/semantics/resolve-names.cpp | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/semantics/resolve-names.cpp b/lib/semantics/resolve-names.cpp index ca8e26700128..5ab1424b246f 100644 --- a/lib/semantics/resolve-names.cpp +++ b/lib/semantics/resolve-names.cpp @@ -5980,7 +5980,6 @@ bool OmpAttributeVisitor::Pre(const parser::OpenMPSectionsConstruct &x) { case parser::OmpSectionsDirective::Directive::Sections: PushContext(beginDir.source, OmpDirective::SECTIONS); break; - default: break; } ClearDataSharingAttributeObjects(); return true; From d2294ff511aebd64889df57d02325bd6fcdf914a Mon Sep 17 00:00:00 2001 From: Pete Steinfeld Date: Mon, 27 Jan 2020 14:12:35 -0800 Subject: [PATCH 03/18] Semantic checks for deallocating entities with IMPURE FINAL procedures You cannot call an IMPURE procedure in a DO CONCURRENT construct. One way that can happen is if an entity with an IMPURE FINAL procedure gets deallocated. Similar to the checks for deallocating coarrays, there are three ways that an entity can get deallocated that are applicable to DO CONCURRENT constructs -- an actual DEALLOCATE statement, block exit, and assignment. This change depends on the utility function `HasImpureFinal()` in tools.h to determine if an entity has a derived type with an IMPURE FINAL procedure. In the course of testing this change, I realized that this check is incorrect, but the code specific to DO CONCURRENT is independent of the check, so I might as well implement it. --- include/flang/semantics/tools.h | 2 +- lib/semantics/check-do.cpp | 68 ++++++++++++++++++++------- lib/semantics/tools.cpp | 4 +- test/semantics/doconcurrent08.f90 | 76 +++++++++++++++++++++++++++++-- 4 files changed, 128 insertions(+), 22 deletions(-) diff --git a/include/flang/semantics/tools.h b/include/flang/semantics/tools.h index 5f56325cc913..59e41700c211 100644 --- a/include/flang/semantics/tools.h +++ b/include/flang/semantics/tools.h @@ -48,7 +48,7 @@ const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &); const DeclTypeSpec *FindParentTypeSpec(const DeclTypeSpec &); const DeclTypeSpec *FindParentTypeSpec(const Scope &); const DeclTypeSpec *FindParentTypeSpec(const Symbol &); - + // Return the Symbol of the variable of a construct association, if it exists const Symbol *GetAssociationRoot(const Symbol &); diff --git a/lib/semantics/check-do.cpp b/lib/semantics/check-do.cpp index 96c8ba73f35a..75acd1b887f6 100644 --- a/lib/semantics/check-do.cpp +++ b/lib/semantics/check-do.cpp @@ -95,15 +95,33 @@ class DoConcurrentBodyEnforce { return true; } + template bool Pre(const parser::UnlabeledStatement &stmt) { + currentStatementSourcePosition_ = stmt.source; + return true; + } + // C1140 -- Can't deallocate a polymorphic entity in a DO CONCURRENT. // Deallocation can be caused by exiting a block that declares an allocatable // entity, assignment to an allocatable variable, or an actual DEALLOCATE // statement // // Note also that the deallocation of a derived type entity might cause the - // invocation of an IMPURE final subroutine. + // invocation of an IMPURE final subroutine. (C1139) // + // Only to be called for symbols with ObjectEntityDetails + static bool HasImpureFinal(const Symbol &symbol) { + if (const Symbol * root{GetAssociationRoot(symbol)}) { + CHECK(root->has()); + if (const DeclTypeSpec * symType{root->GetType()}) { + if (const DerivedTypeSpec * derived{symType->AsDerived()}) { + return semantics::HasImpureFinal(*derived); + } + } + } + return false; + } + // Predicate for deallocations caused by block exit and direct deallocation static bool DeallocateAll(const Symbol &) { return true; } @@ -143,6 +161,21 @@ class DoConcurrentBodyEnforce { return false; } + void SayDeallocateWithImpureFinal(const Symbol &entity, const char *reason) { + context_.SayWithDecl(entity, currentStatementSourcePosition_, + "Deallocation of an entity with an IMPURE FINAL procedure" + " caused by %s not allowed in DO CONCURRENT"_err_en_US, + reason); + } + + void SayDeallocateOfPolymorph( + parser::CharBlock location, const Symbol &entity, const char *reason) { + context_.SayWithDecl(entity, location, + "Deallocation of a polymorphic entity caused by %s" + " not allowed in DO CONCURRENT"_err_en_US, + reason); + } + // Deallocation caused by block exit // Allocatable entities and all of their allocatable subcomponents will be // deallocated. This test is different from the other two because it does @@ -154,16 +187,16 @@ class DoConcurrentBodyEnforce { const Scope &blockScope{context_.FindScope(endBlockStmt.source)}; const Scope &doScope{context_.FindScope(doConcurrentSourcePosition_)}; if (DoesScopeContain(&doScope, blockScope)) { + const char *reason{"block exit"}; for (auto &pair : blockScope) { - Symbol &entity{*pair.second}; + const Symbol &entity{*pair.second}; if (IsAllocatable(entity) && !entity.attrs().test(Attr::SAVE) && MightDeallocatePolymorphic(entity, DeallocateAll)) { - context_.SayWithDecl(entity, endBlockStmt.source, - "Deallocation of a polymorphic entity caused by block" - " exit not allowed in DO CONCURRENT"_err_en_US); + SayDeallocateOfPolymorph(endBlockStmt.source, entity, reason); + } + if (HasImpureFinal(entity)) { + SayDeallocateWithImpureFinal(entity, reason); } - // TODO: Check for deallocation of a variable with an IMPURE FINAL - // subroutine } } } @@ -173,12 +206,12 @@ class DoConcurrentBodyEnforce { void Post(const parser::AssignmentStmt &stmt) { const auto &variable{std::get(stmt.t)}; if (const Symbol * entity{GetLastName(variable).symbol}) { + const char *reason{"assignment"}; if (MightDeallocatePolymorphic(*entity, DeallocateNonCoarray)) { - context_.SayWithDecl(*entity, variable.GetSource(), - "Deallocation of a polymorphic entity caused by " - "assignment not allowed in DO CONCURRENT"_err_en_US); - // TODO: Check for deallocation of a variable with an IMPURE FINAL - // subroutine + SayDeallocateOfPolymorph(variable.GetSource(), *entity, reason); + } + if (HasImpureFinal(*entity)) { + SayDeallocateWithImpureFinal(*entity, reason); } } } @@ -191,17 +224,18 @@ class DoConcurrentBodyEnforce { std::get>(stmt.t)}; for (const auto &allocateObject : allocateObjectList) { const parser::Name &name{GetLastName(allocateObject)}; + const char *reason{"a DEALLOCATE statement"}; if (name.symbol) { const Symbol &entity{*name.symbol}; const DeclTypeSpec *entityType{entity.GetType()}; if ((entityType && entityType->IsPolymorphic()) || // POINTER case MightDeallocatePolymorphic(entity, DeallocateAll)) { - context_.SayWithDecl(entity, currentStatementSourcePosition_, - "Deallocation of a polymorphic entity not allowed in DO" - " CONCURRENT"_err_en_US); + SayDeallocateOfPolymorph( + currentStatementSourcePosition_, entity, reason); + } + if (HasImpureFinal(entity)) { + SayDeallocateWithImpureFinal(entity, reason); } - // TODO: Check for deallocation of a variable with an IMPURE FINAL - // subroutine } } } diff --git a/lib/semantics/tools.cpp b/lib/semantics/tools.cpp index a39ff409db04..8e31a81a0573 100644 --- a/lib/semantics/tools.cpp +++ b/lib/semantics/tools.cpp @@ -508,7 +508,7 @@ const DeclTypeSpec *FindParentTypeSpec(const Symbol &symbol) { return nullptr; } -// When an construct association maps to a variable, and that variable +// When a construct association maps to a variable, and that variable // is not an array with a vector-valued subscript, return the base // Symbol of that variable, else nullptr. Descends into other construct // associations when one associations maps to another. @@ -665,6 +665,8 @@ bool IsFinalizable(const DerivedTypeSpec &derived) { components.end(); } +// TODO The following function returns true for all types with FINAL procedures +// This is because we don't yet fill in the data for FinalProcDetails bool HasImpureFinal(const DerivedTypeSpec &derived) { ScopeComponentIterator components{derived}; return std::find_if( diff --git a/test/semantics/doconcurrent08.f90 b/test/semantics/doconcurrent08.f90 index b4b5d413e9a0..b42ab6160a9f 100644 --- a/test/semantics/doconcurrent08.f90 +++ b/test/semantics/doconcurrent08.f90 @@ -188,18 +188,88 @@ subroutine s3() do concurrent (i = 1:10) ! Bad because deallocation of a polymorphic entity -!ERROR: Deallocation of a polymorphic entity not allowed in DO CONCURRENT +!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT deallocate(polyVar) ! Bad, deallocation of an entity with a polymorphic component -!ERROR: Deallocation of a polymorphic entity not allowed in DO CONCURRENT +!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT deallocate(polyComponentVar) ! Bad, deallocation of a pointer to an entity with a polymorphic component -!ERROR: Deallocation of a polymorphic entity not allowed in DO CONCURRENT +!ERROR: Deallocation of a polymorphic entity caused by a DEALLOCATE statement not allowed in DO CONCURRENT deallocate(pointerPolyComponentVar) ! Deallocation of a nonpolymorphic entity deallocate(nonPolyVar) end do end subroutine s3 + +module m2 + type :: impureFinal + contains + final :: impureSub + end type + + type :: pureFinal + contains + final :: pureSub + end type + + contains + + impure subroutine impureSub(x) + type(impureFinal), intent(in) :: x + end subroutine + + pure subroutine pureSub(x) + type(pureFinal), intent(in) :: x + end subroutine + + subroutine s4() + type(impureFinal), allocatable :: ifVar, ifvar1 + type(pureFinal), allocatable :: pfVar + allocate(ifVar) + allocate(ifVar1) + allocate(pfVar) + + ! OK for an ordinary DO loop + do i = 1,10 + if (i .eq. 1) deallocate(ifVar) + end do + + ! OK to invoke a PURE FINAL procedure in a DO CONCURRENT + ! This case does not work currently because the compiler's test for + ! HasImpureFinal() in .../lib/semantics/tools.cc doesn't work correctly +! do concurrent (i = 1:10) +! if (i .eq. 1) deallocate(pfVar) +! end do + + ! Error to invoke an IMPURE FINAL procedure in a DO CONCURRENT + do concurrent (i = 1:10) + !ERROR: Deallocation of an entity with an IMPURE FINAL procedure caused by a DEALLOCATE statement not allowed in DO CONCURRENT + if (i .eq. 1) deallocate(ifVar) + end do + + do concurrent (i = 1:10) + if (i .eq. 1) then + block + type(impureFinal), allocatable :: ifVar + allocate(ifVar) + ! Error here because exiting this scope causes the finalization of + !ifvar which causes the invocation of an IMPURE FINAL procedure + !ERROR: Deallocation of an entity with an IMPURE FINAL procedure caused by block exit not allowed in DO CONCURRENT + end block + end if + end do + + do concurrent (i = 1:10) + if (i .eq. 1) then + ! Error here because the assignment statement causes the finalization + ! of ifvar which causes the invocation of an IMPURE FINAL procedure +!ERROR: Deallocation of an entity with an IMPURE FINAL procedure caused by assignment not allowed in DO CONCURRENT + ifvar = ifvar1 + end if + end do + end subroutine s4 + +end module m2 From aa0a0887325bd1fc6c3a1ad40fc6711d2e458a1c Mon Sep 17 00:00:00 2001 From: Tim Keith Date: Tue, 28 Jan 2020 15:06:03 -0800 Subject: [PATCH 04/18] Fix another bug checking simple contiguity The test still wasn't correct for structure components. If the last part-ref is a non-array or a single array element, but the whole ArrayRef has non-zero rank, it is not contiguous. Otherwise, if there are subscripts on the last part-ref they can be checked normally. Add some tests for cases that were previously failing, and also for cases with vector subscripts. --- lib/evaluate/check-expression.cpp | 29 +++++++++++++++++++-------- test/semantics/assign03.f90 | 33 +++++++++++++++++++++++++++++++ 2 files changed, 54 insertions(+), 8 deletions(-) diff --git a/lib/evaluate/check-expression.cpp b/lib/evaluate/check-expression.cpp index 34b9025abf25..b809211dbdb4 100644 --- a/lib/evaluate/check-expression.cpp +++ b/lib/evaluate/check-expression.cpp @@ -277,11 +277,18 @@ class IsSimplyContiguousHelper } Result operator()(const ArrayRef &x) const { - return (x.base().IsSymbol() || x.base().Rank() == 0) && - CheckSubscripts(x.subscript()) && (*this)(x.base()); + const auto &symbol{x.GetLastSymbol()}; + if (!(*this)(symbol)) { + return false; + } else if (auto rank{CheckSubscripts(x.subscript())}) { + // a(:)%b(1,1) is not contiguous; a(1)%b(:,:) is + return *rank > 0 || x.Rank() == 0; + } else { + return false; + } } Result operator()(const CoarrayRef &x) const { - return CheckSubscripts(x.subscript()); + return CheckSubscripts(x.subscript()).has_value(); } Result operator()(const Component &x) const { return x.base().Rank() == 0 && (*this)(x.GetLastSymbol()); @@ -304,24 +311,30 @@ class IsSimplyContiguousHelper } private: - static bool CheckSubscripts(const std::vector &subscript) { + // If the subscripts can possibly be on a simply-contiguous array reference, + // return the rank. + static std::optional CheckSubscripts( + const std::vector &subscript) { bool anyTriplet{false}; + int rank{0}; for (auto j{subscript.size()}; j-- > 0;) { if (const auto *triplet{std::get_if(&subscript[j].u)}) { if (!triplet->IsStrideOne()) { - return false; + return std::nullopt; } else if (anyTriplet) { if (triplet->lower() || triplet->upper()) { - return false; // all triplets before the last one must be just ":" + // all triplets before the last one must be just ":" + return std::nullopt; } } else { anyTriplet = true; } + ++rank; } else if (anyTriplet || subscript[j].Rank() > 0) { - return false; + return std::nullopt; } } - return true; + return rank; } const IntrinsicProcTable &table_; diff --git a/test/semantics/assign03.f90 b/test/semantics/assign03.f90 index 08070fd3ac55..7c4895368c52 100644 --- a/test/semantics/assign03.f90 +++ b/test/semantics/assign03.f90 @@ -142,12 +142,22 @@ subroutine s10 end type type(t), target :: x type(t), target :: y(10,10) + integer :: v(10) p(1:16) => x%a + p(1:8) => x%a(:,3:4) p(1:1) => x%b ! We treat scalars as simply contiguous + p(1:1) => x%a(1,1) + p(1:1) => y(1,1)%a(1,1) + p(1:1) => y(:,1)%a(1,1) ! Rank 1 RHS !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous p(1:4) => x%a(::2,::2) !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous p(1:100) => y(:,:)%b + !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous + p(1:100) => y(:,:)%a(1,1) + !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous + !ERROR: An array section with a vector subscript may not be a pointer target + p(1:4) => x%a(:,v) end subroutine s11 @@ -155,8 +165,31 @@ subroutine s11 complex, pointer :: p(:) real, pointer :: q(:) p(1:100) => x(:,:) + q(1:10) => x(1,:)%im !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous q(1:100) => x(:,:)%re end + ! Check is_contiguous, which is usually the same as when pointer bounds + ! remapping is used. If it's not simply contiguous it's not constant so + ! an error is reported. + subroutine s12 + integer, pointer :: p(:) + type :: t + integer :: a(4, 4) + integer :: b + end type + type(t), target :: x + type(t), target :: y(10,10) + integer :: v(10) + logical, parameter :: l1 = is_contiguous(x%a(:,:)) + logical, parameter :: l2 = is_contiguous(y(1,1)%a(1,1)) + !ERROR: Must be a constant value + logical, parameter :: l3 = is_contiguous(y(:,1)%a(1,1)) + !ERROR: Must be a constant value + logical, parameter :: l4 = is_contiguous(x%a(:,v)) + !ERROR: Must be a constant value + logical, parameter :: l5 = is_contiguous(y(v,1)%a(1,1)) + end + end From 889f90913f280f285eb9960a0e0baadfd43a555f Mon Sep 17 00:00:00 2001 From: Pete Steinfeld Date: Wed, 15 Jan 2020 16:25:26 -0800 Subject: [PATCH 05/18] Explanation of how to implement a semantic check This is the story of implementing semantic checks for passing DO variables to functions with dummy arguments with INTENT(OUT) or INTENT(INOUT). --- documentation/ImplementingASemanticCheck.md | 833 ++++++++++++++++++++ 1 file changed, 833 insertions(+) create mode 100644 documentation/ImplementingASemanticCheck.md diff --git a/documentation/ImplementingASemanticCheck.md b/documentation/ImplementingASemanticCheck.md new file mode 100644 index 000000000000..cc5ff7f62667 --- /dev/null +++ b/documentation/ImplementingASemanticCheck.md @@ -0,0 +1,833 @@ + +# Introduction +I recently added a semantic check to the f18 compiler front end. This document +describes my thought process and the resulting implementation. + +For more information about the compiler, start with the +[compiler overview](Overview.md). + +# Problem definition + +In the 2018 Fortran standard, section 11.1.7.4.3, paragraph 2, states that: + +``` +Except for the incrementation of the DO variable that occurs in step (3), the DO variable +shall neither be redefined nor become undefined while the DO construct is active. +``` +One of the ways that DO variables might be redefined is if they are passed to +functions with dummy arguments whose `INTENT` is `INTENT(OUT)` or +`INTENT(INOUT)`. I implemented this semantic check. Specifically, I changed +the compiler to emit an error message if an active DO variable was passed to a +dummy argument of a FUNCTION with INTENT(OUT). Similarly, I had the compiler +emit a warning if an active DO variable was passed to a dummy argument with +INTENT(INOUT). Previously, I had implemented similar checks for SUBROUTINE +calls. + +# Creating a test + +My first step was to create a test case to cause the problem. I called it testfun.f90 and used it to check the behavior of other Fortran compilers. Here's the initial version: + +```fortran + subroutine s() + Integer :: ivar, jvar + + do ivar = 1, 10 + jvar = intentOutFunc(ivar) ! Error since ivar is a DO variable + end do + + contains + function intentOutFunc(dummyArg) + integer, intent(out) :: dummyArg + integer :: intentOutFunc + + dummyArg = 216 + end function intentOutFunc + end subroutine s +``` + +I verified that other Fortran compilers produced an error message at the point +of the call to `intentOutFunc()`: + +```fortran + jvar = intentOutFunc(ivar) ! Error since ivar is a DO variable +``` + + +I also used this program to produce a parse tree for the program using the command: +```bash + f18 -fdebug-dump-parse-tree -fparse-only testfun.f90 +``` + +Here's the relevant fragment of the parse tree produced by the compiler: + +``` +| | ExecutionPartConstruct -> ExecutableConstruct -> DoConstruct +| | | NonLabelDoStmt +| | | | LoopControl -> LoopBounds +| | | | | Scalar -> Name = 'ivar' +| | | | | Scalar -> Expr = '1_4' +| | | | | | LiteralConstant -> IntLiteralConstant = '1' +| | | | | Scalar -> Expr = '10_4' +| | | | | | LiteralConstant -> IntLiteralConstant = '10' +| | | Block +| | | | ExecutionPartConstruct -> ExecutableConstruct -> ActionStmt -> AssignmentStmt = 'jvar=intentoutfunc(ivar)' +| | | | | Variable -> Designator -> DataRef -> Name = 'jvar' +| | | | | Expr = 'intentoutfunc(ivar)' +| | | | | | FunctionReference -> Call +| | | | | | | ProcedureDesignator -> Name = 'intentoutfunc' +| | | | | | | ActualArgSpec +| | | | | | | | ActualArg -> Expr = 'ivar' +| | | | | | | | | Designator -> DataRef -> Name = 'ivar' +| | | EndDoStmt -> +``` + +Note that this fragment of the tree only shows four `parser::Expr` nodes, +but the full parse tree also contained a fifth `parser::Expr` node for the +constant 216 in the statement: + +```fortran + dummyArg = 216 +``` +# Analysis and implementation planning + +I then considered what I needed to do. I needed to detect situations where an +active DO variable was passed to a dummy argument with `INTENT(OUT)` or +`INTENT(INOUT)`. Once I detected such a situation, I needed to produce a +message that highlighted the erroneous source code. + +## Deciding where to add the code to the compiler +This new semantic check would depend on several types of information -- the +parse tree, source code location information, symbols, and expressions. Thus I +needed to put my new code in a place in the compiler after the parse tree had +been created, name resolution had already happened, and expression semantic +checking had already taken place. + +Most semantic checks for statements are implemented by walking the parse tree +and performing analysis on the nodes they visit. My plan was to use this +method. The infrastructure for walking the parse tree for statement semantic +checking is implemented in the files `lib/semantics/semantics.cpp`. +Here's a fragment of the declaration of the framework's parse tree visitor from +`lib/semantics/semantics.cpp`: + +```C++ + // A parse tree visitor that calls Enter/Leave functions from each checker + // class C supplied as template parameters. Enter is called before the node's + // children are visited, Leave is called after. No two checkers may have the + // same Enter or Leave function. Each checker must be constructible from + // SemanticsContext and have BaseChecker as a virtual base class. + template class SemanticsVisitor : public virtual C... { + public: + using C::Enter...; + using C::Leave...; + using BaseChecker::Enter; + using BaseChecker::Leave; + SemanticsVisitor(SemanticsContext &context) + : C{context}..., context_{context} {} + ... + +``` + +Since FUNCTION calls are a kind of expression, I was planning to base my +implementation on the contents of `parser::Expr` nodes. I would need to define +either an `Enter()` or `Leave()` function whose parameter was a `parser::Expr` +node. Here's the declaration I put into `lib/semantics/check-do.h`: + +```C++ + void Leave(const parser::Expr &); +``` +The `Enter()` functions get called at the time the node is first visited -- +that is, before its children. The `Leave()` function gets called after the +children are visited. For my check the visitation order didn't matter, so I +arbitrarily chose to implement the `Leave()` function to visit the parse tree +node. + +Since my semantic check was focused on DO CONCURRENT statements, I added it to +the file `lib/semantics/check-do.cpp` where most of the semantic checking for +DO statements already lived. + +## Taking advantage of prior work +When implementing a similar check for SUBROUTINE calls, I created a utility +functions in `lib/semantics/semantics.cpp` to emit messages if +a symbol corresponding to an active DO variable was being potentially modified: + +```C++ + void WarnDoVarRedefine(const parser::CharBlock &location, const Symbol &var); + void CheckDoVarRedefine(const parser::CharBlock &location, const Symbol &var); +``` + +The first function is intended for dummy arguments of `INTENT(INOUT)` and +the second for `INTENT(OUT)`. + +Thus I needed three pieces of +information -- +1. the source location of the erroneous text, +2. the `INTENT` of the associated dummy argument, and +3. the relevant symbol passed as the actual argument. + +The first and third are needed since they're required to call the utility +functions. The second is needed to determine whether to call them. + +## Finding the source location +The source code location information that I'd need for the error message must +come from the parse tree. I looked in the file +`include/flang/parser/parse-tree.h` and determined that a `struct Expr` +contained source location information since it had the field `CharBlock +source`. Thus, if I visited a `parser::Expr` node, I could get the source +location information for the associated expression. + +## Determining the `INTENT` +I knew that I could find the `INTENT` of the dummy argument associated with the +actual argument from the function called `dummyIntent()` in the class +`evaluate::ActualArgument` in the file `include/flang/evaluate/call.h`. So +if I could find an `evaluate::ActualArgument` in an expression, I could + determine the `INTENT` of the associated dummy argument. I knew that it was + valid to call `dummyIntent()` because the data on which `dummyIntent()` + depends is established during semantic processing for expressions, and the + semantic processing for expressions happens before semantic checking for DO + constructs. + +In my prior work on checking the INTENT of arguments for SUBROUTINE calls, +the parse tree held a node for the call (a `parser::CallStmt`) that contained +an `evaluate::ProcedureRef` node. +```C++ + struct CallStmt { + WRAPPER_CLASS_BOILERPLATE(CallStmt, Call); + mutable std::unique_ptr> + typedCall; // filled by semantics + }; +``` +The `evaluate::ProcedureRef` contains a list of `evaluate::ActualArgument` +nodes. I could then find the INTENT of a dummy argument from the +`evaluate::ActualArgument` node. + +For a FUNCTION call, though, there is no similar way to get from a parse tree +node to an `evaluate::ProcedureRef` node. But I knew that there was an +existing framework used in DO construct semantic checking that traversed an +`evaluate::Expr` node collecting `semantics::Symbol` nodes. I guessed that I'd +be able to use a similar framework to traverse an `evaluate::Expr` node to +find all of the `evaluate::ActualArgument` nodes. + +Note that there are two distinct data types in the compiler called `Expr`. One +is in the `parser` namespace. `parser::Expr` is defined in the file +`include/flang/parser/parse-tree.h`. It represents a parsed expression that +maps directly to the source code and has fields that specify any operators in +the expression, the operands, and the source position of the expression. + +The second `Expr` type is in the `evaluate` namespace. The `evaluate` +namespace contains many types associated with semantic checking of expressions. +`evaluate::Expr` is defined in the file `include/flang/evaluate/expression.h`. +It represents an expression after it has undergone semantic checking and +contains information that is only available after semantic analysis. This +information includes the Fortran type of the expression, whether it's a +reference to a function, whether it's an actual argument, etc. After an +expression has undergone semantic analysis, the field `typedExpr` in the +`parser::Expr` node is filled in with a pointer to the analyzed expression in +`evaluate::Expr`. + +All of the declarations associated with both FUNCTION and SUBROUTINE calls are +in `include/flang/evaluate/call.h`. An `evaluate::FunctionRef` inherits from +an `evaluate::ProcedureRef` which contains the list of +`evaluate::ActualArgument` nodes. But the relationship between an +`evaluate::FunctionRef` node and its associated arguments is not relevant. I +only needed to find the `evaluate::ActualArgument` nodes in an expression. +They hold all of the information I needed. + +So my plan was to start with the `parser::Expr` node and extract its +associated `evaluate::Expr` field. I would then traverse the +`evaluate::Expr` tree collecting all of the `evaluate::ActualArgument` +nodes. I would look at each of these nodes to determine the `INTENT` of +the associated dummy argument. + +This combination of the traversal framework and `dummyIntent()` would give +me the `INTENT` of all of the dummy arguments in a FUNCTION call. Thus, I +would have the second piece of information I needed. + +## Determining if the actual argument is a variable +I also guessed that I could determine if the `evaluate::ActualArgument` +consisted of a variable. + +Once I had a symbol for the variable, I could call one of the functions: +```C++ + void WarnDoVarRedefine(const parser::CharBlock &, const Symbol &); + void CheckDoVarRedefine(const parser::CharBlock &, const Symbol &); +``` +to emit the messages. + +If my plans worked out, this would give me the three pieces of information I +needed -- the source location of the erroneous text, the `INTENT` of the dummy +argument, and a symbol that I could use to determine whether the actual +argument was an active DO variable. + +# Implementation + +## Adding a parse tree visitor +I started my implementation by adding a visitor for `parser::Expr` nodes. +Since this analysis is part of DO construct checking, I did this in +`lib/semantics/check-do.cpp`. I added a print statement to the visitor to +verify that my new code was actually getting executed. + +In `lib/semantics/check-do.h`, I added the declaration for the visitor: + +```C++ + void Leave(const parser::Expr &); +``` + +In `lib/semantics/check-do.cpp`, I added an (almost empty) implementation: + +```C++ + void DoChecker::Leave(const parser::Expr &) { + std::cout << "In Leave for parser::Expr\n"; + } +``` + +I then built the compiler with these changes and ran it on my test program. +This time, I made sure to invoke semantic checking. Here's the command I used: +```bash + f18 -fdebug-resolve-names -fdebug-dump-parse-tree -funparse-with-symbols testfun.f90 +``` + +This produced the output: + +``` + In Leave for parser::Expr + In Leave for parser::Expr + In Leave for parser::Expr + In Leave for parser::Expr + In Leave for parser::Expr +``` + +This made sense since the parse tree contained five `parser::Expr` nodes. +So far, so good. Note that a `parse::Expr` node has a field with the +source position of the associated expression (`CharBlock source`). So I +now had one of the three pieces of information needed to detect and report +errors. + +## Collecting the actual arguments +To get the `INTENT` of the dummy arguments and the `semantics::Symbol` associated with the +actual argument, I needed to find all of the actual arguments embedded in an +expression that contained a FUNCTION call. So my next step was to write the +framework to walk the `evaluate::Expr` to gather all of the +`evaluate::ActualArgument` nodes. The code that I planned to model it on +was the existing infrastructure that collected all of the `semantics::Symbol` nodes from an +`evaluate::Expr`. I found this implementation in +`lib/evaluate/tools.cpp`: + +```C++ + struct CollectSymbolsHelper + : public SetTraverse { + using Base = SetTraverse; + CollectSymbolsHelper() : Base{*this} {} + using Base::operator(); + semantics::SymbolSet operator()(const Symbol &symbol) const { + return {symbol}; + } + }; + template semantics::SymbolSet CollectSymbols(const A &x) { + return CollectSymbolsHelper{}(x); + } +``` + +Note that the `CollectSymbols()` function returns a `semantics::Symbolset`, +which is declared in `include/flang/semantics/symbol.h`: + +```C++ + using SymbolSet = std::set; +``` + +This infrastructure yields a collection based on `std::set<>`. Using an +`std::set<>` means that if the same object is inserted twice, the +collection only gets one copy. This was the behavior that I wanted. + +Here's a sample invocation of `CollectSymbols()` that I found: +```C++ + if (const auto *expr{GetExpr(parsedExpr)}) { + for (const Symbol &symbol : evaluate::CollectSymbols(*expr)) { +``` + +I noted that a `SymbolSet` did not actually contain an +`std::set`. This wasn't surprising since we don't want to put the +full `semantics::Symbol` objects into the set. Ideally, we would be able to create an +`std::set` (a set of C++ references to symbols). But C++ doesn't +support sets that contain references. This limitation is part of the rationale +for the f18 implementation of type `common::Reference`, which is defined in + `include/flang/common/reference.h`. + +`SymbolRef`, the specialization of the template `common::Reference` for +`semantics::Symbol`, is declared in the file +`include/flang/semantics/symbol.h`: + +```C++ + using SymbolRef = common::Reference; +``` + +So to implement something that would collect `evaluate::ActualArgument` +nodes from an `evaluate::Expr`, I first defined the required types +`ActualArgumentRef` and `ActualArgumentSet`. Since these are being +used exclusively for DO construct semantic checking (currently), I put their +definitions into `lib/semantics/check-do.cpp`: + + +```C++ + namespace Fortran::evaluate { + using ActualArgumentRef = common::Reference; + } + + + using ActualArgumentSet = std::set; +``` + +Since `ActualArgument` is in the namespace `evaluate`, I put the +definition for `ActualArgumentRef` in that namespace, too. + +I then modeled the code to create an `ActualArgumentSet` after the code to +collect a `SymbolSet` and put it into `lib/semantics/check-do.cpp`: + + +```C++ + struct CollectActualArgumentsHelper + : public evaluate::SetTraverse { + using Base = SetTraverse; + CollectActualArgumentsHelper() : Base{*this} {} + using Base::operator(); + ActualArgumentSet operator()(const evaluate::ActualArgument &arg) const { + return ActualArgumentSet{arg}; + } + }; + + template ActualArgumentSet CollectActualArguments(const A &x) { + return CollectActualArgumentsHelper{}(x); + } + + template ActualArgumentSet CollectActualArguments(const SomeExpr &); +``` + +Unfortunately, when I tried to build this code, I got an error message saying +`std::set` requires the `<` operator to be defined for its contents. +To fix this, I added a definition for `<`. I didn't care how `<` was +defined, so I just used the address of the object: + +```C++ + inline bool operator<(ActualArgumentRef x, ActualArgumentRef y) { + return &*x < &*y; + } +``` + +I was surprised when this did not make the error message saying that I needed +the `<` operator go away. Eventually, I figured out that the definition of +the `<` operator needed to be in the `evaluate` namespace. Once I put +it there, everything compiled successfully. Here's the code that worked: + +```C++ + namespace Fortran::evaluate { + using ActualArgumentRef = common::Reference; + + inline bool operator<(ActualArgumentRef x, ActualArgumentRef y) { + return &*x < &*y; + } + } +``` + +I then modified my visitor for the parser::Expr to invoke my new collection +framework. To verify that it was actually doing something, I printed out the +number of `evaluate::ActualArgument` nodes that it collected. Note the +call to `GetExpr()` in the invocation of `CollectActualArguments()`. I +modeled this on similar code that collected a `SymbolSet` described above: + +```C++ + void DoChecker::Leave(const parser::Expr &parsedExpr) { + std::cout << "In Leave for parser::Expr\n"; + ActualArgumentSet argSet{CollectActualArguments(GetExpr(parsedExpr))}; + std::cout << "Number of arguments: " << argSet.size() << "\n"; + } +``` + +I compiled and tested this code on my little test program. Here's the output that I got: +``` + In Leave for parser::Expr + Number of arguments: 0 + In Leave for parser::Expr + Number of arguments: 0 + In Leave for parser::Expr + Number of arguments: 0 + In Leave for parser::Expr + Number of arguments: 1 + In Leave for parser::Expr + Number of arguments: 0 +``` + +So most of the `parser::Expr`nodes contained no actual arguments, but the +fourth expression in the parse tree walk contained a single argument. This may +seem wrong since the third `parser::Expr` node in the file contains the +`FunctionReference` node along with the arguments that we're gathering. +But since the tree walk function is being called upon leaving a +`parser::Expr` node, the function visits the `parser::Expr` node +associated with the `parser::ActualArg` node before it visits the +`parser::Expr` node associated with the `parser::FunctionReference` +node. + +So far, so good. + +## Finding the `INTENT` of the dummy argument +I now wanted to find the `INTENT` of the dummy argument associated with the +arguments in the set. As mentioned earlier, the type +`evaluate::ActualArgument` has a member function called `dummyIntent()` +that gives this value. So I augmented my code to print out the `INTENT`: + +```C++ + void DoChecker::Leave(const parser::Expr &parsedExpr) { + std::cout << "In Leave for parser::Expr\n"; + ActualArgumentSet argSet{CollectActualArguments(GetExpr(parsedExpr))}; + std::cout << "Number of arguments: " << argSet.size() << "\n"; + for (const evaluate::ActualArgumentRef &argRef : argSet) { + common::Intent intent{argRef->dummyIntent()}; + switch (intent) { + case common::Intent::In: std::cout << "INTENT(IN)\n"; break; + case common::Intent::Out: std::cout << "INTENT(OUT)\n"; break; + case common::Intent::InOut: std::cout << "INTENT(INOUT)\n"; break; + default: std::cout << "default INTENT\n"; + } + } + } +``` + +I then rebuilt my compiler and ran it on my test case. This produced the following output: + +``` + In Leave for parser::Expr + Number of arguments: 0 + In Leave for parser::Expr + Number of arguments: 0 + In Leave for parser::Expr + Number of arguments: 0 + In Leave for parser::Expr + Number of arguments: 1 + INTENT(OUT) + In Leave for parser::Expr + Number of arguments: 0 +``` + +I then modified my test case to convince myself that I was getting the correct +`INTENT` for `IN`, `INOUT`, and default cases. + +So far, so good. + +## Finding the symbols for arguments that are variables +The third and last piece of information I needed was to determine if a variable +was being passed as an actual argument. In such cases, I wanted to get the +symbol table node (`semantics::Symbol`) for the variable. My starting point was the +`evaluate::ActualArgument` node. + +I was unsure of how to do this, so I browsed through existing code to look for +how it treated `evaluate::ActualArgument` objects. Since most of the code that deals with the `evaluate` namespace is in the lib/evaluate directory, I looked there. I ran `grep` on all of the `.cpp` files looking for +uses of `ActualArgument`. One of the first hits I got was in `lib/evaluate/call.cpp` in the definition of `ActualArgument::GetType()`: + +```C++ +std::optional ActualArgument::GetType() const { + if (const Expr *expr{UnwrapExpr()}) { + return expr->GetType(); + } else if (std::holds_alternative(u_)) { + return DynamicType::AssumedType(); + } else { + return std::nullopt; + } +} +``` + +I noted the call to `UnwrapExpr()` that yielded a value of +`Expr`. So I guessed that I could use this member function to +get an `evaluate::Expr` on which I could perform further analysis. + +I also knew that the header file `include/flang/evaluate/tools.h` held many +utility functions for dealing with `evaluate::Expr` objects. I was hoping to +find something that would determine if an `evaluate::Expr` was a variable. So +I searched for `IsVariable` and got a hit immediately. +```C++ + template bool IsVariable(const A &x) { + if (auto known{IsVariableHelper{}(x)}) { + return *known; + } else { + return false; + } + } +``` + +But I actually needed more than just the knowledge that an `evaluate::Expr` was +a variable. I needed the `semantics::Symbol` associated with the variable. So +I searched in `include/flang/evaluate/tools.h` for functions that returned a +`semantics::Symbol`. I found the following: + +```C++ +// If an expression is simply a whole symbol data designator, +// extract and return that symbol, else null. +template const Symbol *UnwrapWholeSymbolDataRef(const A &x) { + if (auto dataRef{ExtractDataRef(x)}) { + if (const SymbolRef * p{std::get_if(&dataRef->u)}) { + return &p->get(); + } + } + return nullptr; +} +``` + +This was exactly what I wanted. DO variables must be whole symbols. So I +could try to extract a whole `semantics::Symbol` from the `evaluate::Expr` in my +`evaluate::ActualArgument`. If this extraction resulted in a `semantics::Symbol` +that wasn't a `nullptr`, I could then conclude if it was a variable that I +could pass to existing functions that would determine if it was an active DO +variable. + +I then modified the compiler to perform the analysis that I'd guessed would +work: + +```C++ + void DoChecker::Leave(const parser::Expr &parsedExpr) { + std::cout << "In Leave for parser::Expr\n"; + ActualArgumentSet argSet{CollectActualArguments(GetExpr(parsedExpr))}; + std::cout << "Number of arguments: " << argSet.size() << "\n"; + for (const evaluate::ActualArgumentRef &argRef : argSet) { + if (const SomeExpr * argExpr{argRef->UnwrapExpr()}) { + std::cout << "Got an unwrapped Expr\n"; + if (const Symbol * var{evaluate::UnwrapWholeSymbolDataRef(*argExpr)}) { + std::cout << "Found a whole variable: " << *var << "\n"; + } + } + common::Intent intent{argRef->dummyIntent()}; + switch (intent) { + case common::Intent::In: std::cout << "INTENT(IN)\n"; break; + case common::Intent::Out: std::cout << "INTENT(OUT)\n"; break; + case common::Intent::InOut: std::cout << "INTENT(INOUT)\n"; break; + default: std::cout << "default INTENT\n"; + } + } + } +``` + +Note the line that prints out the symbol table entry for the variable: + +```C++ + std::cout << "Found a whole variable: " << *var << "\n"; +``` + +The compiler defines the "<<" operator for `semantics::Symbol`, which is handy +for analyzing the compiler's behavior. + +Here's the result of running the modified compiler on my Fortran test case: + +``` + In Leave for parser::Expr + Number of arguments: 0 + In Leave for parser::Expr + Number of arguments: 0 + In Leave for parser::Expr + Number of arguments: 0 + In Leave for parser::Expr + Number of arguments: 1 + Got an unwrapped Expr + Found a whole variable: ivar: ObjectEntity type: INTEGER(4) + INTENT(OUT) + In Leave for parser::Expr + Number of arguments: 0 +``` + +Sweet. + +## Emitting the messages +At this point, using the source location information from the original +`parser::Expr`, I had enough information to plug into the exiting +interfaces for emitting messages for active DO variables. I modified the +compiler code accordingly: + + +```C++ + void DoChecker::Leave(const parser::Expr &parsedExpr) { + std::cout << "In Leave for parser::Expr\n"; + ActualArgumentSet argSet{CollectActualArguments(GetExpr(parsedExpr))}; + std::cout << "Number of arguments: " << argSet.size() << "\n"; + for (const evaluate::ActualArgumentRef &argRef : argSet) { + if (const SomeExpr * argExpr{argRef->UnwrapExpr()}) { + std::cout << "Got an unwrapped Expr\n"; + if (const Symbol * var{evaluate::UnwrapWholeSymbolDataRef(*argExpr)}) { + std::cout << "Found a whole variable: " << *var << "\n"; + common::Intent intent{argRef->dummyIntent()}; + switch (intent) { + case common::Intent::In: std::cout << "INTENT(IN)\n"; break; + case common::Intent::Out: + std::cout << "INTENT(OUT)\n"; + context_.CheckDoVarRedefine(parsedExpr.source, *var); + break; + case common::Intent::InOut: + std::cout << "INTENT(INOUT)\n"; + context_.WarnDoVarRedefine(parsedExpr.source, *var); + break; + default: std::cout << "default INTENT\n"; + } + } + } + } + } +``` + +I then ran this code on my test case, and miraculously, got the following +output: + +``` + In Leave for parser::Expr + Number of arguments: 0 + In Leave for parser::Expr + Number of arguments: 0 + In Leave for parser::Expr + Number of arguments: 0 + In Leave for parser::Expr + Number of arguments: 1 + Got an unwrapped Expr + Found a whole variable: ivar: ObjectEntity type: INTEGER(4) + INTENT(OUT) + In Leave for parser::Expr + Number of arguments: 0 + testfun.f90:6:12: error: Cannot redefine DO variable 'ivar' + jvar = intentOutFunc(ivar) + ^^^^^^^^^^^^^^^^^^^ + testfun.f90:5:6: Enclosing DO construct + do ivar = 1, 10 + ^^^^ +``` + +Even sweeter. + +# Improving the test case +At this point, my implementation seemed to be working. But I was concerned +about the limitations of my test case. So I augmented it to include arguments +other than `INTENT(OUT)` and more complex expressions. Luckily, my +augmented test did not reveal any new problems. + +Here's the test I ended up with: + +```Fortran + subroutine s() + + Integer :: ivar, jvar + + ! This one is OK + do ivar = 1, 10 + jvar = intentInFunc(ivar) + end do + + ! Error for passing a DO variable to an INTENT(OUT) dummy + do ivar = 1, 10 + jvar = intentOutFunc(ivar) + end do + + ! Error for passing a DO variable to an INTENT(OUT) dummy, more complex + ! expression + do ivar = 1, 10 + jvar = 83 + intentInFunc(intentOutFunc(ivar)) + end do + + ! Warning for passing a DO variable to an INTENT(INOUT) dummy + do ivar = 1, 10 + jvar = intentInOutFunc(ivar) + end do + + contains + function intentInFunc(dummyArg) + integer, intent(in) :: dummyArg + integer :: intentInFunc + + intentInFunc = 343 + end function intentInFunc + + function intentOutFunc(dummyArg) + integer, intent(out) :: dummyArg + integer :: intentOutFunc + + dummyArg = 216 + intentOutFunc = 343 + end function intentOutFunc + + function intentInOutFunc(dummyArg) + integer, intent(inout) :: dummyArg + integer :: intentInOutFunc + + dummyArg = 216 + intentInOutFunc = 343 + end function intentInOutFunc + + end subroutine s +``` + +# Submitting the pull request +At this point, my implementation seemed functionally complete, so I stripped out all of the debug statements, ran `clang-format` on it and reviewed it +to make sure that the names were clear. Here's what I ended up with: + +```C++ + void DoChecker::Leave(const parser::Expr &parsedExpr) { + ActualArgumentSet argSet{CollectActualArguments(GetExpr(parsedExpr))}; + for (const evaluate::ActualArgumentRef &argRef : argSet) { + if (const SomeExpr * argExpr{argRef->UnwrapExpr()}) { + if (const Symbol * var{evaluate::UnwrapWholeSymbolDataRef(*argExpr)}) { + common::Intent intent{argRef->dummyIntent()}; + switch (intent) { + case common::Intent::Out: + context_.CheckDoVarRedefine(parsedExpr.source, *var); + break; + case common::Intent::InOut: + context_.WarnDoVarRedefine(parsedExpr.source, *var); + break; + default:; // INTENT(IN) or default intent + } + } + } + } + } +``` + +I then created a pull request to get review comments. + +# Responding to pull request comments +I got feedback suggesting that I use an `if` statement rather than a +`case` statement. Another comment reminded me that I should look at the +code I'd previously writted to do a similar check for SUBROUTINE calls to see +if there was an opportunity to share code. This examination resulted in + converting my existing code to the following pair of functions: + + +```C++ + static void CheckIfArgIsDoVar(const evaluate::ActualArgument &arg, + const parser::CharBlock location, SemanticsContext &context) { + common::Intent intent{arg.dummyIntent()}; + if (intent == common::Intent::Out || intent == common::Intent::InOut) { + if (const SomeExpr * argExpr{arg.UnwrapExpr()}) { + if (const Symbol * var{evaluate::UnwrapWholeSymbolDataRef(*argExpr)}) { + if (intent == common::Intent::Out) { + context.CheckDoVarRedefine(location, *var); + } else { + context.WarnDoVarRedefine(location, *var); // INTENT(INOUT) + } + } + } + } + } + + void DoChecker::Leave(const parser::Expr &parsedExpr) { + if (const SomeExpr * expr{GetExpr(parsedExpr)}) { + ActualArgumentSet argSet{CollectActualArguments(*expr)}; + for (const evaluate::ActualArgumentRef &argRef : argSet) { + CheckIfArgIsDoVar(*argRef, parsedExpr.source, context_); + } + } + } +``` + +The function `CheckIfArgIsDoVar()` was shared with the checks for DO +variables being passed to SUBROUTINE calls. + +At this point, my pull request was approved, and I merged it and deleted the +associated branch. From 4542cb57082eaf578799c76482d4b706ae5da077 Mon Sep 17 00:00:00 2001 From: Jean Perier Date: Tue, 4 Feb 2020 10:30:16 -0800 Subject: [PATCH 06/18] Fix template step limit issue with clang While working on PR 959, I instanciated a `common::TupleToVariant` with ~50+ types inside the tuple. Clang would then crash after 1hr compilation with message: "constexpr evaluation hit maximum step limit; possible infinite loop" After investigating, it turned out clang handles very badly the way `common::AreTypesDistinctHelper` was implemented. Its "number of steps" was exponential with the number of types. This fix makes this number quadratic which solves the issue. --- include/flang/common/template.h | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/include/flang/common/template.h b/include/flang/common/template.h index c8a18e704fb4..460f1a8bdaed 100644 --- a/include/flang/common/template.h +++ b/include/flang/common/template.h @@ -153,15 +153,12 @@ template struct VariantToTupleHelper> { template using VariantToTuple = typename VariantToTupleHelper::type; -template -struct AreTypesDistinctHelper { +template struct AreTypesDistinctHelper { static constexpr bool value() { - if constexpr (std::is_same_v) { - return false; - } if constexpr (sizeof...(REST) > 0) { - return AreTypesDistinctHelper::value() && - AreTypesDistinctHelper::value(); + // extra () for clang-format + return ((... && !std::is_same_v)) && + AreTypesDistinctHelper::value(); } return true; } From c3f1774f8eee903928b7e46636edfb03425eabc0 Mon Sep 17 00:00:00 2001 From: peter klausler Date: Thu, 23 Jan 2020 16:59:27 -0800 Subject: [PATCH 07/18] Initial buffer framing code Address review comments Integer output data editing (I,B,O,Z) Full integer output formatting Stub out some work in progress Progress on E output data editing E, D, EN, and ES output editing done Fw.d output editing Real G output editing G output editing for reals Make environment a distinct module CHARACTER and LOGICAL output editing Minimal decimal representations for E0, F0, G0 editing Move real output editing code into its own file Fix/dodge some GCC build problems Prep work for external I/O statement state External HELLO, WORLD Fix build problem with GCC Add virtual destructors where needed Add new test --- lib/decimal/binary-to-decimal.cpp | 14 +- runtime/CMakeLists.txt | 3 + runtime/buffer.cpp | 23 ++ runtime/buffer.h | 178 ++++++++++++ runtime/environment.cpp | 37 +++ runtime/environment.h | 26 ++ runtime/file.cpp | 55 +++- runtime/file.h | 39 ++- runtime/format.cpp | 59 ++-- runtime/format.h | 28 +- runtime/io-api.cpp | 63 ++++- runtime/io-stmt.cpp | 192 ++++++++++--- runtime/io-stmt.h | 87 ++++-- runtime/main.cpp | 29 +- runtime/main.h | 17 +- runtime/memory.cpp | 5 - runtime/memory.h | 31 ++- runtime/numeric-output.h | 449 ++++++++++++++++++++++++++++++ runtime/stop.cpp | 8 + runtime/stop.h | 1 + runtime/tools.h | 11 + runtime/unit.cpp | 137 +++++++++ runtime/unit.h | 114 ++++++++ test/runtime/CMakeLists.txt | 8 + test/runtime/external-hello.cpp | 15 + test/runtime/format.cpp | 40 ++- test/runtime/hello.cpp | 332 +++++++++++++++++++++- 27 files changed, 1797 insertions(+), 204 deletions(-) create mode 100644 runtime/buffer.cpp create mode 100644 runtime/buffer.h create mode 100644 runtime/environment.cpp create mode 100644 runtime/environment.h create mode 100644 runtime/numeric-output.h create mode 100644 runtime/unit.cpp create mode 100644 runtime/unit.h create mode 100644 test/runtime/external-hello.cpp diff --git a/lib/decimal/binary-to-decimal.cpp b/lib/decimal/binary-to-decimal.cpp index fbc043eed374..ba061856b089 100644 --- a/lib/decimal/binary-to-decimal.cpp +++ b/lib/decimal/binary-to-decimal.cpp @@ -108,7 +108,7 @@ template ConversionToDecimalResult BigRadixFloatingPointNumber::ConvertToDecimal(char *buffer, std::size_t n, enum DecimalConversionFlags flags, int maxDigits) const { - if (n < static_cast(3 + digits_ * LOG10RADIX) || maxDigits < 1) { + if (n < static_cast(3 + digits_ * LOG10RADIX)) { return {nullptr, 0, 0, Overflow}; } char *start{buffer}; @@ -160,18 +160,21 @@ BigRadixFloatingPointNumber::ConvertToDecimal(char *buffer, while (p[-1] == '0') { --p; } - if (p <= start + maxDigits) { + char *end{start + maxDigits}; + if (maxDigits == 0) { + p = end; + } + if (p <= end) { *p = '\0'; return {buffer, static_cast(p - buffer), expo, Exact}; } else { // Apply a digit limit, possibly with rounding. - char *end{start + maxDigits}; bool incr{false}; switch (rounding_) { case RoundNearest: case RoundDefault: - incr = - *end > '5' || (*end == '5' && (p > end || ((p[-1] - '0') & 1) != 0)); + incr = *end > '5' || + (*end == '5' && (p > end + 1 || ((end[-1] - '0') & 1) != 0)); break; case RoundUp: incr = !isNegative_; break; case RoundDown: incr = isNegative_; break; @@ -190,6 +193,7 @@ BigRadixFloatingPointNumber::ConvertToDecimal(char *buffer, ++p[-1]; } } + *p = '\0'; return {buffer, static_cast(p - buffer), expo, Inexact}; } diff --git a/runtime/CMakeLists.txt b/runtime/CMakeLists.txt index a9a71b9f17ce..4c1ecf0be736 100644 --- a/runtime/CMakeLists.txt +++ b/runtime/CMakeLists.txt @@ -8,8 +8,10 @@ add_library(FortranRuntime ISO_Fortran_binding.cpp + buffer.cpp derived-type.cpp descriptor.cpp + environment.cpp file.cpp format.cpp io-api.cpp @@ -22,6 +24,7 @@ add_library(FortranRuntime tools.cpp transformational.cpp type-code.cpp + unit.cpp ) target_link_libraries(FortranRuntime diff --git a/runtime/buffer.cpp b/runtime/buffer.cpp new file mode 100644 index 000000000000..607bbfcc9ec2 --- /dev/null +++ b/runtime/buffer.cpp @@ -0,0 +1,23 @@ +//===-- runtime/buffer.cpp --------------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#include "buffer.h" +#include + +namespace Fortran::runtime::io { + +// Here's a very old trick for shifting circular buffer data cheaply +// without a need for a temporary array. +void LeftShiftBufferCircularly( + char *buffer, std::size_t bytes, std::size_t shift) { + // Assume that we start with "efgabcd" and the left shift is 3. + std::reverse(buffer, buffer + shift); // "gfeabcd" + std::reverse(buffer, buffer + bytes); // "dcbaefg" + std::reverse(buffer, buffer + bytes - shift); // "abcdefg" +} +} diff --git a/runtime/buffer.h b/runtime/buffer.h new file mode 100644 index 000000000000..a7b31848df8d --- /dev/null +++ b/runtime/buffer.h @@ -0,0 +1,178 @@ +//===-- runtime/buffer.h ----------------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +// External file buffering + +#ifndef FORTRAN_RUNTIME_BUFFER_H_ +#define FORTRAN_RUNTIME_BUFFER_H_ + +#include "io-error.h" +#include "memory.h" +#include +#include +#include + +namespace Fortran::runtime::io { + +void LeftShiftBufferCircularly(char *, std::size_t bytes, std::size_t shift); + +// Maintains a view of a contiguous region of a file in a memory buffer. +// The valid data in the buffer may be circular, but any active frame +// will also be contiguous in memory. The requirement stems from the need to +// preserve read data that may be reused by means of Tn/TLn edit descriptors +// without needing to position the file (which may not always be possible, +// e.g. a socket) and a general desire to reduce system call counts. +template class FileFrame { +public: + using FileOffset = std::int64_t; + + ~FileFrame() { FreeMemoryAndNullify(buffer_); } + + // The valid data in the buffer begins at buffer_[start_] and proceeds + // with possible wrap-around for length_ bytes. The current frame + // is offset by frame_ bytes into that region and is guaranteed to + // be contiguous for at least as many bytes as were requested. + + FileOffset FrameAt() const { return fileOffset_ + frame_; } + char *Frame() const { return buffer_ + start_ + frame_; } + std::size_t FrameLength() const { + return std::min( + static_cast(length_ - frame_), size_ - (start_ + frame_)); + } + + // Returns a short frame at a non-fatal EOF. Can return a long frame as well. + std::size_t ReadFrame( + FileOffset at, std::size_t bytes, IoErrorHandler &handler) { + Flush(handler); + Reallocate(bytes, handler); + if (at < fileOffset_ || at > fileOffset_ + length_) { + Reset(at); + } + frame_ = static_cast(at - fileOffset_); + if (start_ + frame_ + bytes > size_) { + DiscardLeadingBytes(frame_, handler); + if (start_ + bytes > size_) { + // Frame would wrap around; shift current data (if any) to force + // contiguity. + RUNTIME_CHECK(handler, length_ < size_); + if (start_ + length_ <= size_) { + // [......abcde..] -> [abcde........] + std::memmove(buffer_, buffer_ + start_, length_); + } else { + // [cde........ab] -> [abcde........] + auto n{start_ + length_ - size_}; // 3 for cde + auto gap{size_ - length_}; // 13 - 5 = 8 + RUNTIME_CHECK(handler, length_ >= n); + std::memmove(buffer_ + n, buffer_ + start_, length_ - n); // cdeab + LeftShiftBufferCircularly(buffer_, length_, n); // abcde + } + start_ = 0; + } + } + while (FrameLength() < bytes) { + auto next{start_ + length_}; + RUNTIME_CHECK(handler, next < size_); + auto minBytes{bytes - FrameLength()}; + auto maxBytes{size_ - next}; + auto got{Store().Read( + fileOffset_ + length_, buffer_ + next, minBytes, maxBytes, handler)}; + length_ += got; + RUNTIME_CHECK(handler, length_ < size_); + if (got < minBytes) { + break; // error or EOF & program can handle it + } + } + return FrameLength(); + } + + void WriteFrame(FileOffset at, std::size_t bytes, IoErrorHandler &handler) { + if (!dirty_ || at < fileOffset_ || at > fileOffset_ + length_ || + start_ + (at - fileOffset_) + bytes > size_) { + Flush(handler); + fileOffset_ = at; + Reallocate(bytes, handler); + } + dirty_ = true; + frame_ = at - fileOffset_; + length_ = std::max(length_, static_cast(frame_ + bytes)); + } + + void Flush(IoErrorHandler &handler) { + if (dirty_) { + while (length_ > 0) { + std::size_t chunk{std::min(static_cast(length_), + static_cast(size_ - start_))}; + std::size_t put{ + Store().Write(fileOffset_, buffer_ + start_, chunk, handler)}; + length_ -= put; + start_ += put; + fileOffset_ += put; + if (put < chunk) { + break; + } + } + Reset(fileOffset_); + } + } + +private: + STORE &Store() { return static_cast(*this); } + + void Reallocate(std::size_t bytes, Terminator &terminator) { + if (bytes > size_) { + char *old{buffer_}; + auto oldSize{size_}; + size_ = std::max(bytes, minBuffer); + buffer_ = + reinterpret_cast(AllocateMemoryOrCrash(terminator, size_)); + auto chunk{ + std::min(length_, static_cast(oldSize - start_))}; + std::memcpy(buffer_, old + start_, chunk); + start_ = 0; + std::memcpy(buffer_ + chunk, old, length_ - chunk); + FreeMemory(old); + } + } + + void Reset(FileOffset at) { + start_ = length_ = frame_ = 0; + fileOffset_ = at; + dirty_ = false; + } + + void DiscardLeadingBytes(std::size_t n, Terminator &terminator) { + RUNTIME_CHECK(terminator, length_ >= n); + length_ -= n; + if (length_ == 0) { + start_ = 0; + } else { + start_ += n; + if (start_ >= size_) { + start_ -= size_; + } + } + if (frame_ >= n) { + frame_ -= n; + } else { + frame_ = 0; + } + fileOffset_ += n; + } + + static constexpr std::size_t minBuffer{64 << 10}; + + char *buffer_{nullptr}; + std::size_t size_{0}; // current allocated buffer size + FileOffset fileOffset_{0}; // file offset corresponding to buffer valid data + std::int64_t start_{0}; // buffer_[] offset of valid data + std::int64_t length_{0}; // valid data length (can wrap) + std::int64_t frame_{0}; // offset of current frame in valid data + bool dirty_{false}; +}; +} +#endif // FORTRAN_RUNTIME_BUFFER_H_ diff --git a/runtime/environment.cpp b/runtime/environment.cpp new file mode 100644 index 000000000000..5ce55ab47459 --- /dev/null +++ b/runtime/environment.cpp @@ -0,0 +1,37 @@ +//===-- runtime/environment.cpp ---------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#include "environment.h" +#include +#include + +namespace Fortran::runtime { +ExecutionEnvironment executionEnvironment; + +void ExecutionEnvironment::Configure( + int ac, const char *av[], const char *env[]) { + argc = ac; + argv = av; + envp = env; + listDirectedOutputLineLengthLimit = 79; // PGI default + defaultOutputRoundingMode = common::RoundingMode::TiesToEven; // RP=RN + + if (auto *x{std::getenv("FORT_FMT_RECL")}) { + char *end; + auto n{std::strtol(x, &end, 10)}; + if (n > 0 && n < std::numeric_limits::max() && *end == '\0') { + listDirectedOutputLineLengthLimit = n; + } else { + std::fprintf( + stderr, "Fortran runtime: FORT_FMT_RECL=%s is invalid; ignored\n", x); + } + } + + // TODO: Set RP/ROUND='PROCESSOR_DEFINED' from environment +} +} diff --git a/runtime/environment.h b/runtime/environment.h new file mode 100644 index 000000000000..25a98959b741 --- /dev/null +++ b/runtime/environment.h @@ -0,0 +1,26 @@ +//===-- runtime/environment.h -----------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_RUNTIME_ENVIRONMENT_H_ +#define FORTRAN_RUNTIME_ENVIRONMENT_H_ + +#include "flang/common/Fortran.h" + +namespace Fortran::runtime { +struct ExecutionEnvironment { + void Configure(int argc, const char *argv[], const char *envp[]); + + int argc; + const char **argv; + const char **envp; + int listDirectedOutputLineLengthLimit; + common::RoundingMode defaultOutputRoundingMode; +}; +extern ExecutionEnvironment executionEnvironment; +} +#endif // FORTRAN_RUNTIME_ENVIRONMENT_H_ diff --git a/runtime/file.cpp b/runtime/file.cpp index 3936bcdfcfa6..f9c18c741734 100644 --- a/runtime/file.cpp +++ b/runtime/file.cpp @@ -22,13 +22,25 @@ void OpenFile::Open(const char *path, std::size_t pathLength, const char *status, std::size_t statusLength, const char *action, std::size_t actionLength, IoErrorHandler &handler) { CriticalSection criticalSection{lock_}; - RUNTIME_CHECK(handler, fd_ < 0); + RUNTIME_CHECK(handler, fd_ < 0); // TODO handle re-openings int flags{0}; static const char *actions[]{"READ", "WRITE", "READWRITE", nullptr}; switch (IdentifyValue(action, actionLength, actions)) { - case 0: flags = O_RDONLY; break; - case 1: flags = O_WRONLY; break; - case 2: flags = O_RDWR; break; + case 0: + flags = O_RDONLY; + mayRead_ = true; + mayWrite_ = false; + break; + case 1: + flags = O_WRONLY; + mayRead_ = false; + mayWrite_ = true; + break; + case 2: + mayRead_ = true; + mayWrite_ = true; + flags = O_RDWR; + break; default: handler.Crash( "Invalid ACTION='%.*s'", action, static_cast(actionLength)); @@ -82,6 +94,7 @@ void OpenFile::Open(const char *path, std::size_t pathLength, } } path_ = SaveDefaultCharacter(path, pathLength, handler); + pathLength_ = pathLength; if (!path_.get()) { handler.Crash( "FILE= is required unless STATUS='OLD' and unit is connected"); @@ -94,6 +107,17 @@ void OpenFile::Open(const char *path, std::size_t pathLength, knownSize_.reset(); } +void OpenFile::Predefine(int fd) { + CriticalSection criticalSection{lock_}; + fd_ = fd; + path_.reset(); + pathLength_ = 0; + position_ = 0; + knownSize_.reset(); + nextId_ = 0; + pending_.reset(); +} + void OpenFile::Close( const char *status, std::size_t statusLength, IoErrorHandler &handler) { CriticalSection criticalSection{lock_}; @@ -123,7 +147,7 @@ void OpenFile::Close( } } -std::size_t OpenFile::Read(Offset at, char *buffer, std::size_t minBytes, +std::size_t OpenFile::Read(FileOffset at, char *buffer, std::size_t minBytes, std::size_t maxBytes, IoErrorHandler &handler) { if (maxBytes == 0) { return 0; @@ -157,8 +181,8 @@ std::size_t OpenFile::Read(Offset at, char *buffer, std::size_t minBytes, return got; } -std::size_t OpenFile::Write( - Offset at, const char *buffer, std::size_t bytes, IoErrorHandler &handler) { +std::size_t OpenFile::Write(FileOffset at, const char *buffer, + std::size_t bytes, IoErrorHandler &handler) { if (bytes == 0) { return 0; } @@ -187,7 +211,7 @@ std::size_t OpenFile::Write( return put; } -void OpenFile::Truncate(Offset at, IoErrorHandler &handler) { +void OpenFile::Truncate(FileOffset at, IoErrorHandler &handler) { CriticalSection criticalSection{lock_}; CheckOpen(handler); if (!knownSize_ || *knownSize_ != at) { @@ -202,7 +226,7 @@ void OpenFile::Truncate(Offset at, IoErrorHandler &handler) { // to be claimed by a later WAIT statement. // TODO: True asynchronicity int OpenFile::ReadAsynchronously( - Offset at, char *buffer, std::size_t bytes, IoErrorHandler &handler) { + FileOffset at, char *buffer, std::size_t bytes, IoErrorHandler &handler) { CriticalSection criticalSection{lock_}; CheckOpen(handler); int iostat{0}; @@ -210,7 +234,7 @@ int OpenFile::ReadAsynchronously( #if _XOPEN_SOURCE >= 500 || _POSIX_C_SOURCE >= 200809L auto chunk{::pread(fd_, buffer + got, bytes - got, at)}; #else - auto chunk{RawSeek(at) ? ::read(fd_, buffer + got, bytes - got) : -1}; + auto chunk{Seek(at, handler) ? ::read(fd_, buffer + got, bytes - got) : -1}; #endif if (chunk == 0) { iostat = FORTRAN_RUNTIME_IOSTAT_END; @@ -231,8 +255,8 @@ int OpenFile::ReadAsynchronously( } // TODO: True asynchronicity -int OpenFile::WriteAsynchronously( - Offset at, const char *buffer, std::size_t bytes, IoErrorHandler &handler) { +int OpenFile::WriteAsynchronously(FileOffset at, const char *buffer, + std::size_t bytes, IoErrorHandler &handler) { CriticalSection criticalSection{lock_}; CheckOpen(handler); int iostat{0}; @@ -240,7 +264,8 @@ int OpenFile::WriteAsynchronously( #if _XOPEN_SOURCE >= 500 || _POSIX_C_SOURCE >= 200809L auto chunk{::pwrite(fd_, buffer + put, bytes - put, at)}; #else - auto chunk{RawSeek(at) ? ::write(fd_, buffer + put, bytes - put) : -1}; + auto chunk{ + Seek(at, handler) ? ::write(fd_, buffer + put, bytes - put) : -1}; #endif if (chunk >= 0) { at += chunk; @@ -298,7 +323,7 @@ void OpenFile::CheckOpen(Terminator &terminator) { RUNTIME_CHECK(terminator, fd_ >= 0); } -bool OpenFile::Seek(Offset at, IoErrorHandler &handler) { +bool OpenFile::Seek(FileOffset at, IoErrorHandler &handler) { if (at == position_) { return true; } else if (RawSeek(at)) { @@ -310,7 +335,7 @@ bool OpenFile::Seek(Offset at, IoErrorHandler &handler) { } } -bool OpenFile::RawSeek(Offset at) { +bool OpenFile::RawSeek(FileOffset at) { #ifdef _LARGEFILE64_SOURCE return ::lseek64(fd_, at, SEEK_SET) == 0; #else diff --git a/runtime/file.h b/runtime/file.h index 1c0a10d8f754..d5e521756653 100644 --- a/runtime/file.h +++ b/runtime/file.h @@ -14,7 +14,6 @@ #include "io-error.h" #include "lock.h" #include "memory.h" -#include "terminator.h" #include #include @@ -22,33 +21,43 @@ namespace Fortran::runtime::io { class OpenFile { public: - using Offset = std::uint64_t; + using FileOffset = std::int64_t; - Offset position() const { return position_; } + FileOffset position() const { return position_; } void Open(const char *path, std::size_t pathLength, const char *status, std::size_t statusLength, const char *action, std::size_t actionLength, IoErrorHandler &); + void Predefine(int fd); void Close(const char *action, std::size_t actionLength, IoErrorHandler &); + int fd() const { return fd_; } + bool mayRead() const { return mayRead_; } + bool mayWrite() const { return mayWrite_; } + bool mayPosition() const { return mayPosition_; } + void set_mayRead(bool yes) { mayRead_ = yes; } + void set_mayWrite(bool yes) { mayWrite_ = yes; } + void set_mayPosition(bool yes) { mayPosition_ = yes; } + // Reads data into memory; returns amount acquired. Synchronous. // Partial reads (less than minBytes) signify end-of-file. If the // buffer is larger than minBytes, and extra returned data will be // preserved for future consumption, set maxBytes larger than minBytes // to reduce system calls This routine handles EAGAIN/EWOULDBLOCK and EINTR. - std::size_t Read(Offset, char *, std::size_t minBytes, std::size_t maxBytes, - IoErrorHandler &); + std::size_t Read(FileOffset, char *, std::size_t minBytes, + std::size_t maxBytes, IoErrorHandler &); // Writes data. Synchronous. Partial writes indicate program-handled // error conditions. - std::size_t Write(Offset, const char *, std::size_t, IoErrorHandler &); + std::size_t Write(FileOffset, const char *, std::size_t, IoErrorHandler &); // Truncates the file - void Truncate(Offset, IoErrorHandler &); + void Truncate(FileOffset, IoErrorHandler &); // Asynchronous transfers - int ReadAsynchronously(Offset, char *, std::size_t, IoErrorHandler &); - int WriteAsynchronously(Offset, const char *, std::size_t, IoErrorHandler &); + int ReadAsynchronously(FileOffset, char *, std::size_t, IoErrorHandler &); + int WriteAsynchronously( + FileOffset, const char *, std::size_t, IoErrorHandler &); void Wait(int id, IoErrorHandler &); void WaitAll(IoErrorHandler &); @@ -61,15 +70,19 @@ class OpenFile { // lock_ must be held for these void CheckOpen(Terminator &); - bool Seek(Offset, IoErrorHandler &); - bool RawSeek(Offset); + bool Seek(FileOffset, IoErrorHandler &); + bool RawSeek(FileOffset); int PendingResult(Terminator &, int); Lock lock_; int fd_{-1}; OwningPtr path_; - Offset position_{0}; - std::optional knownSize_; + std::size_t pathLength_; + bool mayRead_{false}; + bool mayWrite_{false}; + bool mayPosition_{false}; + FileOffset position_{0}; + std::optional knownSize_; int nextId_; OwningPtr pending_; }; diff --git a/runtime/format.cpp b/runtime/format.cpp index 46ad2ea2b5d0..f31139ebb5ac 100644 --- a/runtime/format.cpp +++ b/runtime/format.cpp @@ -8,43 +8,25 @@ #include "format.h" #include "io-stmt.h" +#include "main.h" #include "flang/common/format.h" #include "flang/decimal/decimal.h" #include namespace Fortran::runtime::io { -// Default FormatContext virtual member functions -void FormatContext::Emit(const char *, std::size_t) { - Crash("Cannot emit data from this FORMAT string"); -} -void FormatContext::Emit(const char16_t *, std::size_t) { - Crash("Cannot emit data from this FORMAT string"); -} -void FormatContext::Emit(const char32_t *, std::size_t) { - Crash("Cannot emit data from this FORMAT string"); -} -void FormatContext::HandleSlash(int) { - Crash("A / control edit descriptor may not appear in this FORMAT string"); -} -void FormatContext::HandleAbsolutePosition(int) { - Crash("A Tn control edit descriptor may not appear in this FORMAT string"); -} -void FormatContext::HandleRelativePosition(int) { - Crash("An nX, TLn, or TRn control edit descriptor may not appear in this " - "FORMAT string"); -} - template FormatControl::FormatControl(Terminator &terminator, const CHAR *format, std::size_t formatLength, int maxHeight) : maxHeight_{static_cast(maxHeight)}, format_{format}, formatLength_{static_cast(formatLength)} { - // The additional two items are for the whole string and a - // repeated non-parenthesized edit descriptor. - if (maxHeight > std::numeric_limits::max()) { + if (maxHeight != maxHeight_) { terminator.Crash("internal Fortran runtime error: maxHeight %d", maxHeight); } + if (formatLength != static_cast(formatLength_)) { + terminator.Crash( + "internal Fortran runtime error: formatLength %zd", formatLength); + } stack_[0].start = offset_; stack_[0].remaining = Iteration::unlimited; // 13.4(8) } @@ -95,8 +77,7 @@ int FormatControl::GetIntField(Terminator &terminator, CHAR firstCh) { return result; } -static void HandleControl( - FormatContext &context, std::uint16_t &scale, char ch, char next, int n) { +static void HandleControl(FormatContext &context, char ch, char next, int n) { MutableModes &modes{context.mutableModes()}; switch (ch) { case 'B': @@ -121,7 +102,7 @@ static void HandleControl( break; case 'P': if (!next) { - scale = n; // kP - decimal scaling by 10**k (TODO) + modes.scale = n; // kP - decimal scaling by 10**k return; } break; @@ -134,6 +115,9 @@ static void HandleControl( case 'C': modes.roundingMode = common::RoundingMode::TiesAwayFromZero; return; + case 'P': + modes.roundingMode = executionEnvironment.defaultOutputRoundingMode; + return; default: break; } break; @@ -269,13 +253,15 @@ int FormatControl::CueUpNextDataEdit(FormatContext &context, bool stop) { } else if (ch >= 'A' && ch <= 'Z') { int start{offset_ - 1}; CHAR next{Capitalize(PeekNext())}; - if (next < 'A' || next > 'Z') { + if (next >= 'A' && next <= 'Z') { + ++offset_; + } else { next = '\0'; } if (ch == 'E' || (!next && (ch == 'A' || ch == 'I' || ch == 'B' || ch == 'O' || ch == 'Z' || - ch == 'F' || ch == 'D' || ch == 'G'))) { + ch == 'F' || ch == 'D' || ch == 'G' || ch == 'L'))) { // Data edit descriptor found offset_ = start; return repeat && *repeat > 0 ? *repeat : 1; @@ -284,8 +270,8 @@ int FormatControl::CueUpNextDataEdit(FormatContext &context, bool stop) { if (ch == 'T') { // Tn, TLn, TRn repeat = GetIntField(context); } - HandleControl(context, scale_, static_cast(ch), - static_cast(next), repeat && *repeat > 0 ? *repeat : 1); + HandleControl(context, static_cast(ch), static_cast(next), + repeat ? *repeat : 1); } } else if (ch == '/') { context.HandleSlash(repeat && *repeat > 0 ? *repeat : 1); @@ -316,7 +302,16 @@ void FormatControl::GetNext( edit.variation = '\0'; } - edit.width = GetIntField(context); + if (edit.descriptor == 'A') { // width is optional for A[w] + auto ch{PeekNext()}; + if (ch >= '0' && ch <= '9') { + edit.width = GetIntField(context); + } else { + edit.width.reset(); + } + } else { + edit.width = GetIntField(context); + } edit.modes = context.mutableModes(); if (PeekNext() == '.') { ++offset_; diff --git a/runtime/format.h b/runtime/format.h index ed164e8902d1..c954c7f3872f 100644 --- a/runtime/format.h +++ b/runtime/format.h @@ -11,6 +11,7 @@ #ifndef FORTRAN_RUNTIME_FORMAT_H_ #define FORTRAN_RUNTIME_FORMAT_H_ +#include "environment.h" #include "terminator.h" #include "flang/common/Fortran.h" #include @@ -26,16 +27,19 @@ enum EditingFlags { struct MutableModes { std::uint8_t editingFlags{0}; // BN, DP, SS - common::RoundingMode roundingMode{common::RoundingMode::TiesToEven}; // RN + common::RoundingMode roundingMode{ + executionEnvironment + .defaultOutputRoundingMode}; // RP/ROUND='PROCESSOR_DEFAULT' bool pad{false}; // PAD= mode on READ char delim{'\0'}; // DELIM= + short scale{0}; // kP }; // A single edit descriptor extracted from a FORMAT struct DataEdit { char descriptor; // capitalized: one of A, I, B, O, Z, F, E(N/S/X), D, G char variation{'\0'}; // N, S, or X for EN, ES, EX - int width; // the 'w' field + std::optional width; // the 'w' field; optional for A std::optional digits; // the 'm' or 'd' field std::optional expoDigits; // 'Ee' field MutableModes modes; @@ -45,13 +49,14 @@ struct DataEdit { class FormatContext : virtual public Terminator { public: FormatContext() {} + virtual ~FormatContext() {} explicit FormatContext(const MutableModes &modes) : mutableModes_{modes} {} - virtual void Emit(const char *, std::size_t); - virtual void Emit(const char16_t *, std::size_t); - virtual void Emit(const char32_t *, std::size_t); - virtual void HandleSlash(int = 1); - virtual void HandleRelativePosition(int); - virtual void HandleAbsolutePosition(int); + virtual bool Emit(const char *, std::size_t) = 0; + virtual bool Emit(const char16_t *, std::size_t) = 0; + virtual bool Emit(const char32_t *, std::size_t) = 0; + virtual bool HandleSlash(int = 1) = 0; + virtual bool HandleRelativePosition(std::int64_t) = 0; + virtual bool HandleAbsolutePosition(std::int64_t) = 0; MutableModes &mutableModes() { return mutableModes_; } private: @@ -63,6 +68,8 @@ class FormatContext : virtual public Terminator { // Errors are fatal. See clause 13.4 in Fortran 2018 for background. template class FormatControl { public: + FormatControl() {} + // TODO: make 'format' a reference here and below FormatControl(Terminator &, const CHAR *format, std::size_t formatLength, int maxHeight = maxMaxHeight); @@ -125,11 +132,10 @@ template class FormatControl { // Data members are arranged and typed so as to reduce size. // This structure may be allocated in stack space loaned by the // user program for internal I/O. - std::uint16_t scale_{0}; // kP const std::uint8_t maxHeight_{maxMaxHeight}; std::uint8_t height_{0}; - const CHAR *format_; - int formatLength_; + const CHAR *format_{nullptr}; + int formatLength_{0}; int offset_{0}; // next item is at format_[offset_] // must be last, may be incomplete diff --git a/runtime/io-api.cpp b/runtime/io-api.cpp index 56e6dff932c5..d5840a03b75d 100644 --- a/runtime/io-api.cpp +++ b/runtime/io-api.cpp @@ -6,11 +6,15 @@ // //===----------------------------------------------------------------------===// +// Implements the I/O statement API + #include "io-api.h" #include "format.h" #include "io-stmt.h" #include "memory.h" +#include "numeric-output.h" #include "terminator.h" +#include "unit.h" #include #include @@ -25,7 +29,62 @@ Cookie IONAME(BeginInternalFormattedOutput)(char *internal, internalLength, format, formatLength, sourceFile, sourceLine); } -enum Iostat IONAME(EndIoStatement)(Cookie io) { - return static_cast(io->EndIoStatement()); +Cookie IONAME(BeginExternalFormattedOutput)(const char *format, + std::size_t formatLength, ExternalUnit unitNumber, const char *sourceFile, + int sourceLine) { + Terminator terminator{sourceFile, sourceLine}; + int unit{unitNumber == DefaultUnit ? 6 : unitNumber}; + ExternalFile &file{ExternalFile::LookUpOrCrash(unit, terminator)}; + return &file.BeginIoStatement>( + file, format, formatLength, sourceFile, sourceLine); +} + +bool IONAME(OutputInteger64)(Cookie cookie, std::int64_t n) { + IoStatementState &io{*cookie}; + DataEdit edit; + io.GetNext(edit); + return EditIntegerOutput(io, edit, n); +} + +bool IONAME(OutputReal64)(Cookie cookie, double x) { + IoStatementState &io{*cookie}; + DataEdit edit; + io.GetNext(edit); + return RealOutputEditing{io, x}.Edit(edit); +} + +bool IONAME(OutputAscii)(Cookie cookie, const char *x, std::size_t length) { + IoStatementState &io{*cookie}; + DataEdit edit; + io.GetNext(edit); + if (edit.descriptor != 'A' && edit.descriptor != 'G') { + io.Crash( + "Data edit descriptor '%c' may not be used with a CHARACTER data item", + edit.descriptor); + return false; + } + int len{static_cast(length)}; + int width{edit.width.value_or(len)}; + return EmitRepeated(io, ' ', std::max(0, width - len)) && + io.Emit(x, std::min(width, len)); +} + +bool IONAME(OutputLogical)(Cookie cookie, bool truth) { + IoStatementState &io{*cookie}; + DataEdit edit; + io.GetNext(edit); + if (edit.descriptor != 'L' && edit.descriptor != 'G') { + io.Crash( + "Data edit descriptor '%c' may not be used with a LOGICAL data item", + edit.descriptor); + return false; + } + return EmitRepeated(io, ' ', std::max(0, edit.width.value_or(1) - 1)) && + io.Emit(truth ? "T" : "F", 1); +} + +enum Iostat IONAME(EndIoStatement)(Cookie cookie) { + IoStatementState &io{*cookie}; + return static_cast(io.EndIoStatement()); } } diff --git a/runtime/io-stmt.cpp b/runtime/io-stmt.cpp index 617e3e697a14..e54a67a328e2 100644 --- a/runtime/io-stmt.cpp +++ b/runtime/io-stmt.cpp @@ -8,81 +8,193 @@ #include "io-stmt.h" #include "memory.h" +#include "unit.h" #include #include namespace Fortran::runtime::io { +IoStatementState::IoStatementState(const char *sourceFile, int sourceLine) + : IoErrorHandler{sourceFile, sourceLine} {} + int IoStatementState::EndIoStatement() { return GetIoStat(); } -int InternalIoStatementState::EndIoStatement() { - auto result{GetIoStat()}; - if (free_) { - FreeMemory(this); - } - return result; +// Defaults +void IoStatementState::GetNext(DataEdit &, int) { + Crash("GetNext() called for I/O statement that is not a formatted data " + "transfer statement"); +} +bool IoStatementState::Emit(const char *, std::size_t) { + Crash("Emit() called for I/O statement that is not an output statement"); + return false; +} +bool IoStatementState::Emit(const char16_t *, std::size_t) { + Crash("Emit() called for I/O statement that is not an output statement"); + return false; +} +bool IoStatementState::Emit(const char32_t *, std::size_t) { + Crash("Emit() called for I/O statement that is not an output statement"); + return false; +} +bool IoStatementState::HandleSlash(int) { + Crash("HandleSlash() called for I/O statement that is not a formatted data " + "transfer statement"); + return false; +} +bool IoStatementState::HandleRelativePosition(std::int64_t) { + Crash("HandleRelativePosition() called for I/O statement that is not a " + "formatted data transfer statement"); + return false; +} +bool IoStatementState::HandleAbsolutePosition(std::int64_t) { + Crash("HandleAbsolutePosition() called for I/O statement that is not a " + "formatted data transfer statement"); + return false; } - -InternalIoStatementState::InternalIoStatementState( - const char *sourceFile, int sourceLine) - : IoStatementState(sourceFile, sourceLine) {} template -InternalFormattedIoStatementState::InternalFormattedIoStatementState(Buffer internal, - std::size_t internalLength, const CHAR *format, std::size_t formatLength, - const char *sourceFile, int sourceLine) - : InternalIoStatementState{sourceFile, sourceLine}, FormatContext{}, - internal_{internal}, internalLength_{internalLength}, format_{*this, format, - formatLength} { - std::fill_n(internal_, internalLength_, static_cast(' ')); +FixedRecordIoStatementState::FixedRecordIoStatementState( + Buffer buffer, std::size_t length, const char *sourceFile, int sourceLine) + : IoStatementState{sourceFile, sourceLine}, buffer_{buffer}, length_{length} { } template -void InternalFormattedIoStatementState::Emit( +bool FixedRecordIoStatementState::Emit( const CHAR *data, std::size_t chars) { if constexpr (isInput) { - FormatContext::Emit(data, chars); // default Crash() - } else if (at_ + chars > internalLength_) { + IoStatementState::Emit(data, chars); // default Crash() + return false; + } else if (at_ + chars > length_) { SignalEor(); + if (at_ < length_) { + std::memcpy(buffer_ + at_, data, (length_ - at_) * sizeof(CHAR)); + at_ = furthest_ = length_; + } + return false; } else { - std::memcpy(internal_ + at_, data, chars * sizeof(CHAR)); + std::memcpy(buffer_ + at_, data, chars * sizeof(CHAR)); at_ += chars; + furthest_ = std::max(furthest_, at_); + return true; } } template -void InternalFormattedIoStatementState::HandleAbsolutePosition( - int n) { - if (n < 0 || static_cast(n) >= internalLength_) { - Crash("T%d control edit descriptor is out of range", n); - } else { - at_ = n; +bool FixedRecordIoStatementState::HandleAbsolutePosition( + std::int64_t n) { + if (n < 0) { + n = 0; } + n += leftTabLimit_; + bool ok{true}; + if (static_cast(n) > length_) { + SignalEor(); + n = length_; + ok = false; + } + if constexpr (!isInput) { + if (static_cast(n) > furthest_) { + std::fill_n(buffer_ + furthest_, n - furthest_, static_cast(' ')); + } + } + at_ = n; + furthest_ = std::max(furthest_, at_); + return ok; } template -void InternalFormattedIoStatementState::HandleRelativePosition( - int n) { - if (n < 0) { - at_ -= std::min(at_, -static_cast(n)); - } else { - at_ += n; - if (at_ > internalLength_) { - Crash("TR%d control edit descriptor is out of range", n); - } +bool FixedRecordIoStatementState::HandleRelativePosition( + std::int64_t n) { + return HandleAbsolutePosition(n + at_ - leftTabLimit_); +} + +template +int FixedRecordIoStatementState::EndIoStatement() { + if constexpr (!isInput) { + HandleAbsolutePosition(length_ - leftTabLimit_); // fill } + return GetIoStat(); } template -int InternalFormattedIoStatementState::EndIoStatement() { - format_.FinishOutput(*this); - auto result{GetIoStat()}; +int InternalIoStatementState::EndIoStatement() { + auto result{FixedRecordIoStatementState::EndIoStatement()}; if (free_) { FreeMemory(this); } return result; } +template +InternalIoStatementState::InternalIoStatementState( + Buffer buffer, std::size_t length, const char *sourceFile, int sourceLine) + : FixedRecordIoStatementState( + buffer, length, sourceFile, sourceLine) {} + +template +InternalFormattedIoStatementState::InternalFormattedIoStatementState(Buffer buffer, std::size_t length, + const CHAR *format, std::size_t formatLength, const char *sourceFile, + int sourceLine) + : InternalIoStatementState{buffer, length, sourceFile, + sourceLine}, + format_{*this, format, formatLength} {} + +template +int InternalFormattedIoStatementState::EndIoStatement() { + format_.FinishOutput(*this); + return InternalIoStatementState::EndIoStatement(); +} + +template +ExternalFormattedIoStatementState::ExternalFormattedIoStatementState(ExternalFile &file, + const CHAR *format, std::size_t formatLength, const char *sourceFile, + int sourceLine) + : IoStatementState{sourceFile, sourceLine}, file_{file}, format_{*this, + format, + formatLength} {} + +template +bool ExternalFormattedIoStatementState::Emit( + const CHAR *data, std::size_t chars) { + // TODO: UTF-8 encoding of 2- and 4-byte characters + return file_.Emit(data, chars * sizeof(CHAR), *this); +} + +template +bool ExternalFormattedIoStatementState::HandleSlash(int n) { + while (n-- > 0) { + if (!file_.NextOutputRecord(*this)) { + return false; + } + } + return true; +} + +template +bool ExternalFormattedIoStatementState::HandleAbsolutePosition( + std::int64_t n) { + return file_.HandleAbsolutePosition(n, *this); +} + +template +bool ExternalFormattedIoStatementState::HandleRelativePosition( + std::int64_t n) { + return file_.HandleRelativePosition(n, *this); +} + +template +int ExternalFormattedIoStatementState::EndIoStatement() { + format_.FinishOutput(*this); + if constexpr (!isInput) { + file_.NextOutputRecord(*this); // TODO: non-advancing I/O + } + int result{GetIoStat()}; + file_.EndIoStatement(); // annihilates *this in file_.u_ + return result; +} + template class InternalFormattedIoStatementState; +template class ExternalFormattedIoStatementState; } diff --git a/runtime/io-stmt.h b/runtime/io-stmt.h index 2e70efa591be..002f38e82596 100644 --- a/runtime/io-stmt.h +++ b/runtime/io-stmt.h @@ -18,47 +18,100 @@ namespace Fortran::runtime::io { -class IoStatementState : public IoErrorHandler { +class ExternalFile; + +class IoStatementState : public IoErrorHandler, public FormatContext { public: - using IoErrorHandler::IoErrorHandler; + IoStatementState(const char *sourceFile, int sourceLine); + virtual ~IoStatementState() {} + virtual int EndIoStatement(); + // Default (crashing) callback overrides for FormatContext + virtual void GetNext(DataEdit &, int maxRepeat = 1); + virtual bool Emit(const char *, std::size_t); + virtual bool Emit(const char16_t *, std::size_t); + virtual bool Emit(const char32_t *, std::size_t); + virtual bool HandleSlash(int); + virtual bool HandleRelativePosition(std::int64_t); + virtual bool HandleAbsolutePosition(std::int64_t); +}; + +template +class FixedRecordIoStatementState : public IoStatementState { protected: + using Buffer = std::conditional_t; + +public: + FixedRecordIoStatementState( + Buffer, std::size_t, const char *sourceFile, int sourceLine); + + virtual bool Emit(const CHAR *, std::size_t chars /* not bytes */); + // TODO virtual void HandleSlash(int); + virtual bool HandleRelativePosition(std::int64_t); + virtual bool HandleAbsolutePosition(std::int64_t); + virtual int EndIoStatement(); + +private: + Buffer buffer_{nullptr}; + std::size_t length_; // RECL= or internal I/O character variable length + std::size_t leftTabLimit_{0}; // nonzero only when non-advancing + std::size_t at_{0}; + std::size_t furthest_{0}; }; -class InternalIoStatementState : public IoStatementState { +template +class InternalIoStatementState + : public FixedRecordIoStatementState { public: - InternalIoStatementState(const char *sourceFile, int sourceLine); + using typename FixedRecordIoStatementState::Buffer; + InternalIoStatementState(Buffer, std::size_t, + const char *sourceFile = nullptr, int sourceLine = 0); virtual int EndIoStatement(); protected: bool free_{true}; }; -template -class InternalFormattedIoStatementState : public InternalIoStatementState, - private FormatContext { -private: - using Buffer = std::conditional_t; - +template +class InternalFormattedIoStatementState + : public InternalIoStatementState { public: + using typename InternalIoStatementState::Buffer; InternalFormattedIoStatementState(Buffer internal, std::size_t internalLength, const CHAR *format, std::size_t formatLength, const char *sourceFile = nullptr, int sourceLine = 0); - void Emit(const CHAR *, std::size_t chars); - // TODO pmk: void HandleSlash(int); - void HandleRelativePosition(int); - void HandleAbsolutePosition(int); + void GetNext(DataEdit &edit, int maxRepeat = 1) { + format_.GetNext(*this, edit, maxRepeat); + } int EndIoStatement(); private: - Buffer internal_; - std::size_t internalLength_; - std::size_t at_{0}; FormatControl format_; // must be last, may be partial }; +template +class ExternalFormattedIoStatementState : public IoStatementState { +public: + ExternalFormattedIoStatementState(ExternalFile &, const CHAR *format, + std::size_t formatLength, const char *sourceFile = nullptr, + int sourceLine = 0); + void GetNext(DataEdit &edit, int maxRepeat = 1) { + format_.GetNext(*this, edit, maxRepeat); + } + bool Emit(const CHAR *, std::size_t chars /* not bytes */); + bool HandleSlash(int); + bool HandleRelativePosition(std::int64_t); + bool HandleAbsolutePosition(std::int64_t); + int EndIoStatement(); + +private: + ExternalFile &file_; + FormatControl format_; +}; + extern template class InternalFormattedIoStatementState; +extern template class ExternalFormattedIoStatementState; } #endif // FORTRAN_RUNTIME_IO_STMT_H_ diff --git a/runtime/main.cpp b/runtime/main.cpp index 25b3b02001bf..8c2caa570df5 100644 --- a/runtime/main.cpp +++ b/runtime/main.cpp @@ -7,35 +7,12 @@ //===----------------------------------------------------------------------===// #include "main.h" -#include "io-stmt.h" +#include "environment.h" #include "terminator.h" +#include "unit.h" #include #include #include -#include - -namespace Fortran::runtime { -ExecutionEnvironment executionEnvironment; - -void ExecutionEnvironment::Configure( - int ac, const char *av[], const char *env[]) { - argc = ac; - argv = av; - envp = env; - listDirectedOutputLineLengthLimit = 79; // PGI default - - if (auto *x{std::getenv("FORT_FMT_RECL")}) { - char *end; - auto n{std::strtol(x, &end, 10)}; - if (n > 0 && n < std::numeric_limits::max() && *end == '\0') { - listDirectedOutputLineLengthLimit = n; - } else { - std::fprintf( - stderr, "Fortran runtime: FORT_FMT_RECL=%s is invalid; ignored\n", x); - } - } -} -} static void ConfigureFloatingPoint() { #ifdef feclearexcept // a macro in some environments; omit std:: @@ -56,5 +33,7 @@ void RTNAME(ProgramStart)(int argc, const char *argv[], const char *envp[]) { std::atexit(Fortran::runtime::NotifyOtherImagesOfNormalEnd); Fortran::runtime::executionEnvironment.Configure(argc, argv, envp); ConfigureFloatingPoint(); + Fortran::runtime::Terminator terminator{"ProgramStart()"}; + Fortran::runtime::io::ExternalFile::InitializePredefinedUnits(terminator); } } diff --git a/runtime/main.h b/runtime/main.h index c966a3674351..2f2504826465 100644 --- a/runtime/main.h +++ b/runtime/main.h @@ -9,22 +9,11 @@ #ifndef FORTRAN_RUNTIME_MAIN_H_ #define FORTRAN_RUNTIME_MAIN_H_ +#include "c-or-cpp.h" #include "entry-names.h" -namespace Fortran::runtime { -struct ExecutionEnvironment { - void Configure(int argc, const char *argv[], const char *envp[]); - - int argc; - const char **argv; - const char **envp; - int listDirectedOutputLineLengthLimit; -}; -extern ExecutionEnvironment executionEnvironment; -} - -extern "C" { +EXTERN_C_BEGIN void RTNAME(ProgramStart)(int, const char *[], const char *[]); -} +EXTERN_C_END #endif // FORTRAN_RUNTIME_MAIN_H_ diff --git a/runtime/memory.cpp b/runtime/memory.cpp index e2d997caea78..ac456a5dd9d1 100644 --- a/runtime/memory.cpp +++ b/runtime/memory.cpp @@ -25,9 +25,4 @@ void *AllocateMemoryOrCrash(Terminator &terminator, std::size_t bytes) { } void FreeMemory(void *p) { std::free(p); } - -void FreeMemoryAndNullify(void *&p) { - std::free(p); - p = nullptr; -} } diff --git a/runtime/memory.h b/runtime/memory.h index 3e65a98fb224..d41f5f95407e 100644 --- a/runtime/memory.h +++ b/runtime/memory.h @@ -18,15 +18,22 @@ namespace Fortran::runtime { class Terminator; -void *AllocateMemoryOrCrash(Terminator &, std::size_t bytes); -template A &AllocateOrCrash(Terminator &t) { +[[nodiscard]] void *AllocateMemoryOrCrash(Terminator &, std::size_t bytes); +template[[nodiscard]] A &AllocateOrCrash(Terminator &t) { return *reinterpret_cast(AllocateMemoryOrCrash(t, sizeof(A))); } void FreeMemory(void *); -void FreeMemoryAndNullify(void *&); +template void FreeMemory(A *p) { + FreeMemory(reinterpret_cast(p)); +} +template void FreeMemoryAndNullify(A *&p) { + FreeMemory(p); + p = nullptr; +} template struct New { - template A &operator()(Terminator &terminator, X &&... x) { + template + [[nodiscard]] A &operator()(Terminator &terminator, X &&... x) { return *new (AllocateMemoryOrCrash(terminator, sizeof(A))) A{std::forward(x)...}; } @@ -37,6 +44,22 @@ template struct OwningPtrDeleter { }; template using OwningPtr = std::unique_ptr>; + +template struct Allocator { + using value_type = A; + explicit Allocator(Terminator &t) : terminator{t} {} + template + explicit constexpr Allocator(const Allocator &that) noexcept + : terminator{that.terminator} {} + Allocator(const Allocator &) = default; + Allocator(Allocator &&) = default; + [[nodiscard]] constexpr A *allocate(std::size_t n) { + return reinterpret_cast( + AllocateMemoryOrCrash(terminator, n * sizeof(A))); + } + constexpr void deallocate(A *p, std::size_t) { FreeMemory(p); } + Terminator &terminator; +}; } #endif // FORTRAN_RUNTIME_MEMORY_H_ diff --git a/runtime/numeric-output.h b/runtime/numeric-output.h new file mode 100644 index 000000000000..a0f40c700b7b --- /dev/null +++ b/runtime/numeric-output.h @@ -0,0 +1,449 @@ +//===-- runtime/numeric-output.h --------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_RUNTIME_NUMERIC_OUTPUT_H_ +#define FORTRAN_RUNTIME_NUMERIC_OUTPUT_H_ + +// Output data editing templates implementing the FORMAT data editing +// descriptors E, EN, ES, EX, D, F, and G for REAL data (and COMPLEX +// components, I and G for INTEGER, and B/O/Z for both. +// See subclauses in 13.7.2.3 of Fortran 2018 for the +// detailed specifications of these descriptors. +// Drives the same binary-to-decimal formatting templates used +// by the f18 compiler. + +#include "format.h" +#include "flang/common/unsigned-const-division.h" +#include "flang/decimal/decimal.h" + +namespace Fortran::runtime::io { + +class IoStatementState; + +// Utility subroutines +static bool EmitRepeated(IoStatementState &io, char ch, int n) { + while (n-- > 0) { + if (!io.Emit(&ch, 1)) { + return false; + } + } + return true; +} + +static bool EmitField( + IoStatementState &io, const char *p, std::size_t length, int width) { + if (width <= 0) { + width = static_cast(length); + } + if (length > static_cast(width)) { + return EmitRepeated(io, '*', width); + } else { + return EmitRepeated(io, ' ', static_cast(width - length)) && + io.Emit(p, length); + } +} + +// I, B, O, Z, and (for INTEGER) G output editing. +// edit is const here so that a repeated edit descriptor may safely serve +// multiple array elements +static bool EditIntegerOutput( + IoStatementState &io, const DataEdit &edit, std::int64_t n) { + char buffer[66], *end = &buffer[sizeof buffer], *p = end; + std::uint64_t un{static_cast(n < 0 ? -n : n)}; + int signChars{0}; + switch (edit.descriptor) { + case 'G': + case 'I': + if (n < 0 || (edit.modes.editingFlags & signPlus)) { + signChars = 1; // '-' or '+' + } + while (un > 0) { + auto quotient{common::DivideUnsignedBy(un)}; + *--p = '0' + un - 10 * quotient; + un = quotient; + } + break; + case 'B': + for (; un > 0; un >>= 1) { + *--p = '0' + (un & 1); + } + break; + case 'O': + for (; un > 0; un >>= 3) { + *--p = '0' + (un & 7); + } + break; + case 'Z': + for (; un > 0; un >>= 4) { + int digit = un & 0xf; + *--p = digit >= 10 ? 'A' + (digit - 10) : '0' + digit; + } + break; + default: + io.Crash( + "Data edit descriptor '%c' may not be used with an INTEGER data item", + edit.descriptor); + return false; + } + + int digits = end - p; + int leadingZeroes{0}; + int editWidth{edit.width.value_or(0)}; + if (edit.digits && digits <= *edit.digits) { // Iw.m + if (*edit.digits == 0 && n == 0) { + // Iw.0 with zero value: output field must be blank. For I0.0 + // and a zero value, emit one blank character. + signChars = 0; // in case of SP + editWidth = std::max(1, editWidth); + } else { + leadingZeroes = *edit.digits - digits; + } + } else if (n == 0) { + leadingZeroes = 1; + } + int total{signChars + leadingZeroes + digits}; + if (edit.width > 0 && total > editWidth) { + return EmitRepeated(io, '*', editWidth); + } + if (total < editWidth) { + EmitRepeated(io, '*', editWidth - total); + return false; + } + if (signChars) { + if (!io.Emit(n < 0 ? "-" : "+", 1)) { + return false; + } + } + return EmitRepeated(io, '0', leadingZeroes) && io.Emit(p, digits); +} + +// Encapsulates the state of a REAL output conversion. +template +class RealOutputEditing { +public: + RealOutputEditing(IoStatementState &io, FLOAT x) : io_{io}, x_{x} {} + bool Edit(const DataEdit &edit); + +private: + // The DataEdit arguments here are const references or copies so that + // the original DataEdit can safely serve multiple array elements if + // it has a repeat count. + bool EditEorDOutput(const DataEdit &); + bool EditFOutput(const DataEdit &); + DataEdit EditForGOutput(DataEdit); // returns an E or F edit + bool EditEXOutput(const DataEdit &); + + bool IsZero() const { return x_ == 0; } + const char *FormatExponent(int, const DataEdit &edit, int &length); + + static enum decimal::FortranRounding SetRounding( + common::RoundingMode rounding) { + switch (rounding) { + case common::RoundingMode::TiesToEven: break; + case common::RoundingMode::Up: return decimal::RoundUp; + case common::RoundingMode::Down: return decimal::RoundDown; + case common::RoundingMode::ToZero: return decimal::RoundToZero; + case common::RoundingMode::TiesAwayFromZero: + return decimal::RoundCompatible; + } + return decimal::RoundNearest; // arranged thus to dodge bogus G++ warning + } + + static bool IsDecimalNumber(const char *p) { + if (!p) { + return false; + } + if (*p == '-' || *p == '+') { + ++p; + } + return *p >= '0' && *p <= '9'; + } + + decimal::ConversionToDecimalResult Convert( + int significantDigits, const DataEdit &, int flags = 0); + + IoStatementState &io_; + FLOAT x_; + char buffer_[bufferSize]; + int trailingBlanks_{0}; // created when G editing maps to F + char exponent_[16]; +}; + +template +decimal::ConversionToDecimalResult RealOutputEditing::Convert(int significantDigits, + const DataEdit &edit, int flags) { + if (edit.modes.editingFlags & signPlus) { + flags |= decimal::AlwaysSign; + } + auto converted{decimal::ConvertToDecimal(buffer_, bufferSize, + static_cast(flags), + significantDigits, SetRounding(edit.modes.roundingMode), + decimal::BinaryFloatingPointNumber(x_))}; + if (!converted.str) { // overflow + io_.Crash("RealOutputEditing::Convert : buffer size %zd was insufficient", + bufferSize); + } + return converted; +} + +// 13.7.2.3.3 in F'2018 +template +bool RealOutputEditing::EditEorDOutput(const DataEdit &edit) { + int editDigits{edit.digits.value_or(0)}; // 'd' field + int editWidth{edit.width.value_or(0)}; // 'w' field + int significantDigits{editDigits}; + int flags{0}; + if (editWidth == 0) { // "the processor selects the field width" + if (edit.digits.has_value()) { // E0.d + editWidth = editDigits + 6; // -.666E+ee + } else { // E0 + flags |= decimal::Minimize; + significantDigits = + bufferSize - 5; // sign, NUL, + 3 extra for EN scaling + } + } + bool isEN{edit.variation == 'N'}; + bool isES{edit.variation == 'S'}; + int scale{isEN || isES ? 1 : edit.modes.scale}; // 'kP' value + int zeroesAfterPoint{0}; + if (scale < 0) { + zeroesAfterPoint = -scale; + significantDigits = std::max(0, significantDigits - zeroesAfterPoint); + } else if (scale > 0) { + ++significantDigits; + scale = std::min(scale, significantDigits + 1); + } + // In EN editing, multiple attempts may be necessary, so it's in a loop. + while (true) { + decimal::ConversionToDecimalResult converted{ + Convert(significantDigits, edit, flags)}; + if (converted.length > 0 && !IsDecimalNumber(converted.str)) { // Inf, NaN + return EmitField(io_, converted.str, converted.length, editWidth); + } + if (!IsZero()) { + converted.decimalExponent -= scale; + } + if (isEN && scale < 3 && (converted.decimalExponent % 3) != 0) { + // EN mode: boost the scale and significant digits, try again; need + // an effective exponent field that's a multiple of three. + ++scale; + ++significantDigits; + continue; + } + // Format the exponent (see table 13.1 for all the cases) + int expoLength{0}; + const char *exponent{ + FormatExponent(converted.decimalExponent, edit, expoLength)}; + int signLength{*converted.str == '-' || *converted.str == '+' ? 1 : 0}; + int convertedDigits{static_cast(converted.length) - signLength}; + int zeroesBeforePoint{std::max(0, scale - convertedDigits)}; + int digitsBeforePoint{std::max(0, scale - zeroesBeforePoint)}; + int digitsAfterPoint{convertedDigits - digitsBeforePoint}; + int trailingZeroes{flags & decimal::Minimize + ? 0 + : std::max(0, + significantDigits - (convertedDigits + zeroesBeforePoint))}; + int totalLength{signLength + digitsBeforePoint + zeroesBeforePoint + + 1 /*'.'*/ + zeroesAfterPoint + digitsAfterPoint + trailingZeroes + + expoLength}; + int width{editWidth > 0 ? editWidth : totalLength}; + if (totalLength > width) { + return EmitRepeated(io_, '*', width); + } + if (totalLength < width && digitsBeforePoint == 0 && + zeroesBeforePoint == 0) { + zeroesBeforePoint = 1; + ++totalLength; + } + return EmitRepeated(io_, ' ', width - totalLength) && + io_.Emit(converted.str, signLength + digitsBeforePoint) && + EmitRepeated(io_, '0', zeroesBeforePoint) && + io_.Emit(edit.modes.editingFlags & decimalComma ? "," : ".", 1) && + EmitRepeated(io_, '0', zeroesAfterPoint) && + io_.Emit( + converted.str + signLength + digitsBeforePoint, digitsAfterPoint) && + EmitRepeated(io_, '0', trailingZeroes) && + io_.Emit(exponent, expoLength); + } +} + +// Formats the exponent (see table 13.1 for all the cases) +template +const char *RealOutputEditing::FormatExponent(int expo, const DataEdit &edit, int &length) { + char *eEnd{&exponent_[sizeof exponent_]}; + char *exponent{eEnd}; + for (unsigned e{static_cast(std::abs(expo))}; e > 0;) { + unsigned quotient{common::DivideUnsignedBy(e)}; + *--exponent = '0' + e - 10 * quotient; + e = quotient; + } + if (edit.expoDigits) { + if (int ed{*edit.expoDigits}) { // Ew.dEe with e > 0 + while (exponent > exponent_ + 2 /*E+*/ && exponent + ed > eEnd) { + *--exponent = '0'; + } + } else if (exponent == eEnd) { + *--exponent = '0'; // Ew.dE0 with zero-valued exponent + } + } else { // ensure at least two exponent digits + while (exponent + 2 > eEnd) { + *--exponent = '0'; + } + } + *--exponent = expo < 0 ? '-' : '+'; + if (edit.expoDigits || exponent + 3 == eEnd) { + *--exponent = edit.descriptor == 'D' ? 'D' : 'E'; // not 'G' + } + length = eEnd - exponent; + return exponent; +} + +// 13.7.2.3.2 in F'2018 +template +bool RealOutputEditing::EditFOutput(const DataEdit &edit) { + int fracDigits{edit.digits.value_or(0)}; // 'd' field + int extraDigits{0}; + int editWidth{edit.width.value_or(0)}; // 'w' field + int flags{0}; + if (editWidth == 0) { // "the processor selects the field width" + if (!edit.digits.has_value()) { // F0 + flags |= decimal::Minimize; + fracDigits = bufferSize - 2; // sign & NUL + } + } + // Multiple conversions may be needed to get the right number of + // effective rounded fractional digits. + while (true) { + decimal::ConversionToDecimalResult converted{ + Convert(extraDigits + fracDigits, edit, flags)}; + if (converted.length > 0 && !IsDecimalNumber(converted.str)) { // Inf, NaN + return EmitField(io_, converted.str, converted.length, editWidth); + } + int scale{IsZero() ? -1 : edit.modes.scale}; + int expo{converted.decimalExponent - scale}; + if (expo > extraDigits) { + extraDigits = expo; + if (flags & decimal::Minimize) { + fracDigits = bufferSize - extraDigits - 2; // sign & NUL + } + continue; // try again + } + int signLength{*converted.str == '-' || *converted.str == '+' ? 1 : 0}; + int convertedDigits{static_cast(converted.length) - signLength}; + int digitsBeforePoint{std::max(0, std::min(expo, convertedDigits))}; + int zeroesBeforePoint{std::max(0, expo - digitsBeforePoint)}; + int zeroesAfterPoint{std::max(0, -expo)}; + int digitsAfterPoint{convertedDigits - digitsBeforePoint}; + int trailingZeroes{flags & decimal::Minimize + ? 0 + : std::max(0, fracDigits - (zeroesAfterPoint + digitsAfterPoint))}; + if (digitsBeforePoint + zeroesBeforePoint + zeroesAfterPoint + + digitsAfterPoint + trailingZeroes == + 0) { + ++zeroesBeforePoint; // "." -> "0." + } + int totalLength{signLength + digitsBeforePoint + zeroesBeforePoint + + 1 /*'.'*/ + zeroesAfterPoint + digitsAfterPoint + trailingZeroes}; + int width{editWidth > 0 ? editWidth : totalLength}; + if (totalLength > width) { + return EmitRepeated(io_, '*', width); + } + if (totalLength < width && digitsBeforePoint + zeroesBeforePoint == 0) { + zeroesBeforePoint = 1; + ++totalLength; + } + return EmitRepeated(io_, ' ', width - totalLength) && + io_.Emit(converted.str, signLength + digitsBeforePoint) && + EmitRepeated(io_, '0', zeroesBeforePoint) && + io_.Emit(edit.modes.editingFlags & decimalComma ? "," : ".", 1) && + EmitRepeated(io_, '0', zeroesAfterPoint) && + io_.Emit( + converted.str + signLength + digitsBeforePoint, digitsAfterPoint) && + EmitRepeated(io_, '0', trailingZeroes) && + EmitRepeated(io_, ' ', trailingBlanks_); + } +} + +// 13.7.5.2.3 in F'2018 +template +DataEdit RealOutputEditing::EditForGOutput(DataEdit edit) { + edit.descriptor = 'E'; + if (!edit.width.has_value() || + (*edit.width > 0 && edit.digits.value_or(-1) == 0)) { + return edit; // Gw.0 -> Ew.0 for w > 0 + } + decimal::ConversionToDecimalResult converted{Convert(1, edit)}; + if (!IsDecimalNumber(converted.str)) { // Inf, NaN + return edit; + } + int expo{IsZero() ? 1 : converted.decimalExponent}; // 's' + int significantDigits{edit.digits.value_or(decimalPrecision)}; // 'd' + if (expo < 0 || expo > significantDigits) { + return edit; // Ew.d + } + edit.descriptor = 'F'; + edit.modes.scale = 0; // kP is ignored for G when no exponent field + trailingBlanks_ = 0; + int editWidth{edit.width.value_or(0)}; + if (editWidth > 0) { + int expoDigits{edit.expoDigits.value_or(0)}; + trailingBlanks_ = expoDigits > 0 ? expoDigits + 2 : 4; // 'n' + *edit.width = std::max(0, editWidth - trailingBlanks_); + } + if (edit.digits.has_value()) { + *edit.digits = std::max(0, *edit.digits - expo); + } + return edit; +} + +// 13.7.5.2.6 in F'2018 +template +bool RealOutputEditing::EditEXOutput(const DataEdit &) { + io_.Crash("EX output editing is not yet implemented"); // TODO +} + +template +bool RealOutputEditing::Edit(const DataEdit &edit) { + switch (edit.descriptor) { + case 'D': return EditEorDOutput(edit); + case 'E': + if (edit.variation == 'X') { + return EditEXOutput(edit); + } else { + return EditEorDOutput(edit); + } + case 'F': return EditFOutput(edit); + case 'B': + case 'O': + case 'Z': + return EditIntegerOutput(io_, edit, decimal::BinaryFloatingPointNumber{x_}.raw); + case 'G': return Edit(EditForGOutput(edit)); + default: + io_.Crash("Data edit descriptor '%c' may not be used with a REAL data item", + edit.descriptor); + return false; + } + return false; +} +} +#endif // FORTRAN_RUNTIME_NUMERIC_OUTPUT_H_ diff --git a/runtime/stop.cpp b/runtime/stop.cpp index 8bf665f82512..85bf9c4a14ac 100644 --- a/runtime/stop.cpp +++ b/runtime/stop.cpp @@ -7,7 +7,9 @@ //===----------------------------------------------------------------------===// #include "stop.h" +#include "io-error.h" #include "terminator.h" +#include "unit.h" #include #include #include @@ -66,4 +68,10 @@ static void DescribeIEEESignaledExceptions() { Fortran::runtime::NotifyOtherImagesOfFailImageStatement(); std::exit(EXIT_FAILURE); } + +[[noreturn]] void RTNAME(ProgramEndStatement)() { + Fortran::runtime::io::IoErrorHandler handler{"END statement"}; + Fortran::runtime::io::ExternalFile::CloseAll(handler); + std::exit(EXIT_SUCCESS); +} } diff --git a/runtime/stop.h b/runtime/stop.h index b3d8e32c5de4..8fb1d8d4cffd 100644 --- a/runtime/stop.h +++ b/runtime/stop.h @@ -21,6 +21,7 @@ NORETURN void RTNAME(StopStatement)(int code DEFAULT_VALUE(EXIT_SUCCESS), NORETURN void RTNAME(StopStatementText)(const char *, bool isErrorStop DEFAULT_VALUE(false), bool quiet DEFAULT_VALUE(false)); NORETURN void RTNAME(FailImageStatement)(NO_ARGUMENTS); +NORETURN void RTNAME(ProgramEndStatement)(NO_ARGUMENTS); EXTERN_C_END diff --git a/runtime/tools.h b/runtime/tools.h index 184f6af63f8e..d1b90b1ad3c9 100644 --- a/runtime/tools.h +++ b/runtime/tools.h @@ -8,7 +8,12 @@ #ifndef FORTRAN_RUNTIME_TOOLS_H_ #define FORTRAN_RUNTIME_TOOLS_H_ + #include "memory.h" +#include +#include +#include + namespace Fortran::runtime { class Terminator; @@ -21,5 +26,11 @@ OwningPtr SaveDefaultCharacter(const char *, std::size_t, Terminator &); // or -1 when it has no match. int IdentifyValue( const char *value, std::size_t length, const char *possibilities[]); + +// A std::map<> customized to use the runtime's memory allocator +template +using MapAllocator = Allocator, VALUE>>; +template> +using Map = std::map>; } #endif // FORTRAN_RUNTIME_TOOLS_H_ diff --git a/runtime/unit.cpp b/runtime/unit.cpp new file mode 100644 index 000000000000..f7a342ccbb73 --- /dev/null +++ b/runtime/unit.cpp @@ -0,0 +1,137 @@ +//===-- runtime/unit.cpp ----------------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#include "unit.h" +#include "lock.h" +#include "memory.h" +#include "tools.h" +#include +#include + +namespace Fortran::runtime::io { + +static Lock mapLock; +static Terminator mapTerminator; +static Map unitMap{MapAllocator{mapTerminator}}; + +ExternalFile *ExternalFile::LookUp(int unit) { + CriticalSection criticalSection{mapLock}; + auto iter{unitMap.find(unit)}; + return iter == unitMap.end() ? nullptr : &iter->second; +} + +ExternalFile &ExternalFile::LookUpOrCrash(int unit, Terminator &terminator) { + CriticalSection criticalSection{mapLock}; + ExternalFile *file{LookUp(unit)}; + if (!file) { + terminator.Crash("Not an open I/O unit number: %d", unit); + } + return *file; +} + +ExternalFile &ExternalFile::Create(int unit, Terminator &terminator) { + CriticalSection criticalSection{mapLock}; + auto pair{unitMap.emplace(unit, unit)}; + if (!pair.second) { + terminator.Crash("Already opened I/O unit number: %d", unit); + } + return pair.first->second; +} + +void ExternalFile::CloseUnit(IoErrorHandler &handler) { + CriticalSection criticalSection{mapLock}; + Flush(handler); + auto iter{unitMap.find(unitNumber_)}; + if (iter != unitMap.end()) { + unitMap.erase(iter); + } +} + +void ExternalFile::InitializePredefinedUnits(Terminator &terminator) { + ExternalFile &out{ExternalFile::Create(6, terminator)}; + out.Predefine(1); + out.set_mayRead(false); + out.set_mayWrite(true); + out.set_mayPosition(false); + ExternalFile &in{ExternalFile::Create(5, terminator)}; + in.Predefine(0); + in.set_mayRead(true); + in.set_mayWrite(false); + in.set_mayPosition(false); + // TODO: Set UTF-8 mode from the environment +} + +void ExternalFile::CloseAll(IoErrorHandler &handler) { + CriticalSection criticalSection{mapLock}; + while (!unitMap.empty()) { + auto &pair{*unitMap.begin()}; + pair.second.CloseUnit(handler); + } +} + +bool ExternalFile::SetPositionInRecord(std::int64_t n, IoErrorHandler &handler) { + n = std::max(std::int64_t{0}, n); + bool ok{true}; + if (n > recordLength.value_or(n)) { + handler.SignalEor(); + n = *recordLength; + ok = false; + } + if (n > furthestPositionInRecord) { + if (!isReading_ && ok) { + WriteFrame(recordOffsetInFile, n, handler); + std::fill_n(Frame() + furthestPositionInRecord, n - furthestPositionInRecord, ' '); + } + furthestPositionInRecord = n; + } + positionInRecord = n; + return ok; +} + +bool ExternalFile::Emit(const char *data, std::size_t bytes, IoErrorHandler &handler) { + auto furthestAfter{std::max(furthestPositionInRecord, positionInRecord + static_cast(bytes))}; + WriteFrame(recordOffsetInFile, furthestAfter, handler); + std::memcpy(Frame() + positionInRecord, data, bytes); + positionInRecord += bytes; + furthestPositionInRecord = furthestAfter; + return true; +} + +void ExternalFile::SetLeftTabLimit() { + leftTabLimit = furthestPositionInRecord; + positionInRecord = furthestPositionInRecord; +} + +bool ExternalFile::NextOutputRecord(IoErrorHandler &handler) { + bool ok{true}; + if (recordLength.has_value()) { // fill fixed-size record + ok &= SetPositionInRecord(*recordLength, handler); + } else if (!unformatted && !isReading_) { + ok &= SetPositionInRecord(furthestPositionInRecord, handler) && + Emit("\n", 1, handler); + } + recordOffsetInFile += furthestPositionInRecord; + ++currentRecordNumber; + positionInRecord = 0; + positionInRecord = furthestPositionInRecord = 0; + leftTabLimit.reset(); + return ok; +} + +bool ExternalFile::HandleAbsolutePosition(std::int64_t n, IoErrorHandler &handler) { + return SetPositionInRecord(std::max(n, std::int64_t{0}) + leftTabLimit.value_or(0), handler); +} + +bool ExternalFile::HandleRelativePosition(std::int64_t n, IoErrorHandler &handler) { + return HandleAbsolutePosition(positionInRecord + n, handler); +} + +void ExternalFile::EndIoStatement() { + u_.emplace(); +} +} diff --git a/runtime/unit.h b/runtime/unit.h new file mode 100644 index 000000000000..a6b80b22587e --- /dev/null +++ b/runtime/unit.h @@ -0,0 +1,114 @@ +//===-- runtime/unit.h ------------------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +// Fortran I/O units + +#ifndef FORTRAN_RUNTIME_IO_UNIT_H_ +#define FORTRAN_RUNTIME_IO_UNIT_H_ + +#include "buffer.h" +#include "descriptor.h" +#include "file.h" +#include "format.h" +#include "io-error.h" +#include "io-stmt.h" +#include "lock.h" +#include "memory.h" +#include "terminator.h" +#include +#include +#include +#include + +namespace Fortran::runtime::io { + +enum class Access { Sequential, Direct, Stream }; + +inline bool IsRecordFile(Access a) { return a != Access::Stream; } + +// These characteristics of a connection are immutable after being +// established in an OPEN statement. +struct ConnectionAttributes { + Access access{Access::Sequential}; // ACCESS='SEQUENTIAL', 'DIRECT', 'STREAM' + std::optional recordLength; // RECL= when fixed-length + bool unformatted{false}; // FORM='UNFORMATTED' + bool isUTF8{false}; // ENCODING='UTF-8' + bool asynchronousAllowed{false}; // ASYNCHRONOUS='YES' +}; + +struct ConnectionState : public ConnectionAttributes { + // Positions in a record file (sequential or direct, but not stream) + std::int64_t recordOffsetInFile{0}; + std::int64_t currentRecordNumber{1}; // 1 is first + std::int64_t positionInRecord{0}; // offset in current record + std::int64_t furthestPositionInRecord{0}; // max(positionInRecord) + std::optional leftTabLimit; // offset in current record + // nextRecord value captured after ENDFILE/REWIND/BACKSPACE statement + // on a sequential access file + std::optional endfileRecordNumber; + // Mutable modes set at OPEN() that can be overridden in READ/WRITE & FORMAT + MutableModes modes; // BLANK=, DECIMAL=, SIGN=, ROUND=, PAD=, DELIM=, kP +}; + +class InternalUnit : public ConnectionState, public IoErrorHandler { +public: + InternalUnit(Descriptor &, const char *sourceFile, int sourceLine) + : IoErrorHandler{sourceFile, sourceLine} { +// TODO pmk descriptor_.Establish(...); + descriptor_.GetLowerBounds(at_); + recordLength = descriptor_.ElementBytes(); + endfileRecordNumber = descriptor_.Elements(); + } + ~InternalUnit() { + if (!doNotFree_) { + std::free(this); + } + } + +private: + bool doNotFree_{false}; + Descriptor descriptor_; + SubscriptValue at_[maxRank]; +}; + +class ExternalFile : public ConnectionState, // TODO: privatize these + public OpenFile, + public FileFrame { +public: + explicit ExternalFile(int unitNumber) : unitNumber_{unitNumber} {} + static ExternalFile *LookUp(int unit); + static ExternalFile &LookUpOrCrash(int unit, Terminator &); + static ExternalFile &Create(int unit, Terminator &); + static void InitializePredefinedUnits(Terminator &); + static void CloseAll(IoErrorHandler &); + + void CloseUnit(IoErrorHandler &); + + // TODO: accessors & mutators for many OPEN() specifiers + template A &BeginIoStatement(X&&... xs) { + // TODO: lock_.Take() here, and keep it until EndIoStatement()? + // Nested I/O from derived types wouldn't work, though. + return u_.emplace(std::forward(xs)...); + } + void EndIoStatement(); + + bool SetPositionInRecord(std::int64_t, IoErrorHandler &); + bool Emit(const char *, std::size_t bytes, IoErrorHandler &); + void SetLeftTabLimit(); + bool NextOutputRecord(IoErrorHandler &); + bool HandleAbsolutePosition(std::int64_t, IoErrorHandler &); + bool HandleRelativePosition(std::int64_t, IoErrorHandler &); +private: + int unitNumber_{-1}; + Lock lock_; + bool isReading_{false}; + std::variant> u_; +}; + +} +#endif // FORTRAN_RUNTIME_IO_UNIT_H_ diff --git a/test/runtime/CMakeLists.txt b/test/runtime/CMakeLists.txt index fda3776cc906..feadddfa880a 100644 --- a/test/runtime/CMakeLists.txt +++ b/test/runtime/CMakeLists.txt @@ -29,3 +29,11 @@ target_link_libraries(hello-world ) add_test(HelloWorld hello-world) + +add_executable(external-hello-world + external-hello.cpp +) + +target_link_libraries(external-hello-world + FortranRuntime +) diff --git a/test/runtime/external-hello.cpp b/test/runtime/external-hello.cpp new file mode 100644 index 000000000000..af7151f6c44e --- /dev/null +++ b/test/runtime/external-hello.cpp @@ -0,0 +1,15 @@ +#include "../../runtime/io-api.h" +#include "../../runtime/main.h" +#include "../../runtime/stop.h" +#include + +using namespace Fortran::runtime::io; + +int main(int argc, const char *argv[], const char *envp[]) { + static const char *format{"(12HHELLO, WORLD)"}; + RTNAME(ProgramStart)(argc, argv, envp); + auto *io{IONAME(BeginExternalFormattedOutput)(format, std::strlen(format))}; + IONAME(EndIoStatement)(io); + RTNAME(ProgramEndStatement)(); + return 0; +} diff --git a/test/runtime/format.cpp b/test/runtime/format.cpp index 937a4434b8d7..31e3261d8f88 100644 --- a/test/runtime/format.cpp +++ b/test/runtime/format.cpp @@ -1,4 +1,5 @@ -// Test basic FORMAT string traversal +// Tests basic FORMAT string traversal + #include "../runtime/format.h" #include "../runtime/terminator.h" #include @@ -17,17 +18,20 @@ using Results = std::list; // Test harness context for format control struct TestFormatContext : virtual public Terminator, public FormatContext { TestFormatContext() : Terminator{"format.cpp", 1} {} - void Emit(const char *, std::size_t); - void HandleSlash(int = 1); - void HandleRelativePosition(int); - void HandleAbsolutePosition(int); + bool Emit(const char *, std::size_t); + bool Emit(const char16_t *, std::size_t); + bool Emit(const char32_t *, std::size_t); + bool HandleSlash(int = 1); + bool HandleRelativePosition(std::int64_t); + bool HandleAbsolutePosition(std::int64_t); void Report(const DataEdit &); void Check(Results &); Results results; }; // Override the runtime's Crash() for testing purposes -[[noreturn]] void Fortran::runtime::Terminator::Crash(const char *message, ...) { +[[noreturn]] void Fortran::runtime::Terminator::Crash( + const char *message, ...) { std::va_list ap; va_start(ap, message); char buffer[1000]; @@ -36,27 +40,39 @@ struct TestFormatContext : virtual public Terminator, public FormatContext { throw std::string{buffer}; } -void TestFormatContext::Emit(const char *s, std::size_t len) { +bool TestFormatContext::Emit(const char *s, std::size_t len) { std::string str{s, len}; results.push_back("'"s + str + '\''); + return true; +} +bool TestFormatContext::Emit(const char16_t *, std::size_t) { + Crash("TestFormatContext::Emit(const char16_t *) called"); + return false; +} +bool TestFormatContext::Emit(const char32_t *, std::size_t) { + Crash("TestFormatContext::Emit(const char32_t *) called"); + return false; } -void TestFormatContext::HandleSlash(int n) { +bool TestFormatContext::HandleSlash(int n) { while (n-- > 0) { results.emplace_back("/"); } + return true; } -void TestFormatContext::HandleAbsolutePosition(int n) { +bool TestFormatContext::HandleAbsolutePosition(std::int64_t n) { results.push_back("T"s + std::to_string(n)); + return true; } -void TestFormatContext::HandleRelativePosition(int n) { +bool TestFormatContext::HandleRelativePosition(std::int64_t n) { if (n < 0) { results.push_back("TL"s + std::to_string(-n)); } else { results.push_back(std::to_string(n) + 'X'); } + return true; } void TestFormatContext::Report(const DataEdit &edit) { @@ -67,7 +83,9 @@ void TestFormatContext::Report(const DataEdit &edit) { if (edit.variation) { str += edit.variation; } - str += std::to_string(edit.width); + if (edit.width) { + str += std::to_string(*edit.width); + } if (edit.digits) { str += "."s + std::to_string(*edit.digits); } diff --git a/test/runtime/hello.cpp b/test/runtime/hello.cpp index 9c52a01b26a9..86354a36de5e 100644 --- a/test/runtime/hello.cpp +++ b/test/runtime/hello.cpp @@ -1,4 +1,4 @@ -// Basic tests of I/O API +// Basic sanity tests of I/O API; exhaustive testing will be done in Fortran #include "../../runtime/io-api.h" #include @@ -8,22 +8,334 @@ using namespace Fortran::runtime::io; static int failures{0}; -int main() { +static void test(const char *format, const char *expect, std::string &&got) { + std::string want{expect}; + want.resize(got.length(), ' '); + if (got != want) { + std::cerr << '\'' << format << "' failed;\n got '" << got + << "',\nexpected '" << want << "'\n"; + ++failures; + } +} + +static void hello() { char buffer[32]; - const char *format1{"(12HHELLO, WORLD)"}; - auto cookie{IONAME(BeginInternalFormattedOutput)(buffer, sizeof buffer, format1, std::strlen(format1))}; + const char *format{"(6HHELLO,,A6,2X,I3,1X,'0x',Z8,1X,L1)"}; + auto cookie{IONAME(BeginInternalFormattedOutput)( + buffer, sizeof buffer, format, std::strlen(format))}; + IONAME(OutputAscii)(cookie, "WORLD", 5); + IONAME(OutputInteger64)(cookie, 678); + IONAME(OutputInteger64)(cookie, 0xfeedface); + IONAME(OutputLogical)(cookie, true); if (auto status{IONAME(EndIoStatement)(cookie)}) { - std::cerr << "format1 failed, status " << static_cast(status) << '\n'; + std::cerr << '\'' << format << "' failed, status " + << static_cast(status) << '\n'; ++failures; + } else { + test(format, "HELLO, WORLD 678 0xFEEDFACE T", + std::string{buffer, sizeof buffer}); } - std::string got1{buffer, sizeof buffer}; - std::string expect1{"HELLO, WORLD"}; - expect1.resize(got1.length(), ' '); - if (got1 != expect1) { - std::cerr << "format1 failed, got '" << got1 << "', expected '" << expect1 << "'\n"; +} + +static void realTest(const char *format, double x, const char *expect) { + char buffer[800]; + auto cookie{IONAME(BeginInternalFormattedOutput)( + buffer, sizeof buffer, format, std::strlen(format))}; + IONAME(OutputReal64)(cookie, x); + if (auto status{IONAME(EndIoStatement)(cookie)}) { + std::cerr << '\'' << format << "' failed, status " + << static_cast(status) << '\n'; ++failures; + } else { + test(format, expect, std::string{buffer, sizeof buffer}); + } +} + +int main() { + hello(); + + static const char *zeroes[][2]{ + {"(E32.17,';')", " 0.00000000000000000E+00;"}, + {"(F32.17,';')", " 0.00000000000000000;"}, + {"(G32.17,';')", " 0.0000000000000000 ;"}, + {"(DC,E32.17,';')", " 0,00000000000000000E+00;"}, + {"(DC,F32.17,';')", " 0,00000000000000000;"}, + {"(DC,G32.17,';')", " 0,0000000000000000 ;"}, + {"(D32.17,';')", " 0.00000000000000000D+00;"}, + {"(E32.17E1,';')", " 0.00000000000000000E+0;"}, + {"(G32.17E1,';')", " 0.0000000000000000 ;"}, + {"(E32.17E0,';')", " 0.00000000000000000E+0;"}, + {"(G32.17E0,';')", " 0.0000000000000000 ;"}, + {"(1P,E32.17,';')", " 0.00000000000000000E+00;"}, + {"(1P,F32.17,';')", " 0.00000000000000000;"}, + {"(1P,G32.17,';')", " 0.0000000000000000 ;"}, + {"(2P,E32.17,';')", " 00.0000000000000000E+00;"}, + {"(-1P,E32.17,';')", " 0.00000000000000000E+00;"}, + {"(G0,';')", "0.;"}, {}}; + for (int j{0}; zeroes[j][0]; ++j) { + realTest(zeroes[j][0], 0.0, zeroes[j][1]); + } + + static const char *ones[][2]{ + {"(E32.17,';')", " 0.10000000000000000E+01;"}, + {"(F32.17,';')", " 1.00000000000000000;"}, + {"(G32.17,';')", " 1.0000000000000000 ;"}, + {"(E32.17E1,';')", " 0.10000000000000000E+1;"}, + {"(G32.17E1,';')", " 1.0000000000000000 ;"}, + {"(E32.17E0,';')", " 0.10000000000000000E+1;"}, + {"(G32.17E0,';')", " 1.0000000000000000 ;"}, + {"(E32.17E4,';')", " 0.10000000000000000E+0001;"}, + {"(G32.17E4,';')", " 1.0000000000000000 ;"}, + {"(1P,E32.17,';')", " 1.00000000000000000E+00;"}, + {"(1P,F32.17,';')", " 0.10000000000000000;"}, + {"(1P,G32.17,';')", " 1.0000000000000000 ;"}, + {"(ES32.17,';')", " 1.00000000000000000E+00;"}, + {"(2P,E32.17,';')", " 10.0000000000000000E-01;"}, + {"(2P,G32.17,';')", " 1.0000000000000000 ;"}, + {"(-1P,E32.17,';')", " 0.01000000000000000E+02;"}, + {"(-1P,G32.17,';')", " 1.0000000000000000 ;"}, + {"(G0,';')", "1.;"}, {}}; + for (int j{0}; ones[j][0]; ++j) { + realTest(ones[j][0], 1.0, ones[j][1]); } + realTest("(E32.17,';')", -1.0, " -0.10000000000000000E+01;"); + realTest("(F32.17,';')", -1.0, " -1.00000000000000000;"); + realTest("(G32.17,';')", -1.0, " -1.0000000000000000 ;"); + realTest("(G0,';')", -1.0, "-1.;"); + + volatile union { + double d; + std::uint64_t n; + } u; + u.n = 0x8000000000000000; // -0 + realTest("(E9.1,';')", u.d, " -0.0E+00;"); + realTest("(F4.0,';')", u.d, " -0.;"); + realTest("(G8.0,';')", u.d, "-0.0E+00;"); + realTest("(G8.1,';')", u.d, " -0. ;"); + realTest("(G0,';')", u.d, "-0.;"); + u.n = 0x7ff0000000000000; // +Inf + realTest("(E9.1,';')", u.d, " Inf;"); + realTest("(F9.1,';')", u.d, " Inf;"); + realTest("(G9.1,';')", u.d, " Inf;"); + realTest("(SP,E9.1,';')", u.d, " +Inf;"); + realTest("(SP,F9.1,';')", u.d, " +Inf;"); + realTest("(SP,G9.1,';')", u.d, " +Inf;"); + realTest("(G0,';')", u.d, "Inf;"); + u.n = 0xfff0000000000000; // -Inf + realTest("(E9.1,';')", u.d, " -Inf;"); + realTest("(F9.1,';')", u.d, " -Inf;"); + realTest("(G9.1,';')", u.d, " -Inf;"); + realTest("(G0,';')", u.d, "-Inf;"); + u.n = 0x7ff0000000000001; // NaN + realTest("(E9.1,';')", u.d, " NaN;"); + realTest("(F9.1,';')", u.d, " NaN;"); + realTest("(G9.1,';')", u.d, " NaN;"); + realTest("(G0,';')", u.d, "NaN;"); + u.n = 0xfff0000000000001; // NaN (sign irrelevant) + realTest("(E9.1,';')", u.d, " NaN;"); + realTest("(F9.1,';')", u.d, " NaN;"); + realTest("(G9.1,';')", u.d, " NaN;"); + realTest("(SP,E9.1,';')", u.d, " NaN;"); + realTest("(SP,F9.1,';')", u.d, " NaN;"); + realTest("(SP,G9.1,';')", u.d, " NaN;"); + realTest("(G0,';')", u.d, "NaN;"); + + u.n = 0x3fb999999999999a; // 0.1 rounded + realTest("(E62.55,';')", u.d, + " 0.1000000000000000055511151231257827021181583404541015625E+00;"); + realTest("(E0.0,';')", u.d, "0.E+00;"); + realTest("(E0.55,';')", u.d, + "0.1000000000000000055511151231257827021181583404541015625E+00;"); + realTest("(E0,';')", u.d, ".1E+00;"); + realTest("(F58.55,';')", u.d, + " 0.1000000000000000055511151231257827021181583404541015625;"); + realTest("(F0.0,';')", u.d, "0.;"); + realTest("(F0.55,';')", u.d, + ".1000000000000000055511151231257827021181583404541015625;"); + realTest("(F0,';')", u.d, ".1;"); + realTest("(G62.55,';')", u.d, + " 0.1000000000000000055511151231257827021181583404541015625 ;"); + realTest("(G0.0,';')", u.d, "0.;"); + realTest("(G0.55,';')", u.d, + ".1000000000000000055511151231257827021181583404541015625;"); + realTest("(G0,';')", u.d, ".1;"); + + u.n = 0x3ff8000000000000; // 1.5 + realTest("(E9.2,';')", u.d, " 0.15E+01;"); + realTest("(F4.1,';')", u.d, " 1.5;"); + realTest("(G7.1,';')", u.d, " 2. ;"); + realTest("(RN,E8.1,';')", u.d, " 0.2E+01;"); + realTest("(RN,F3.0,';')", u.d, " 2.;"); + realTest("(RN,G7.0,';')", u.d, " 0.E+01;"); + realTest("(RN,G7.1,';')", u.d, " 2. ;"); + realTest("(RD,E8.1,';')", u.d, " 0.1E+01;"); + realTest("(RD,F3.0,';')", u.d, " 1.;"); + realTest("(RD,G7.0,';')", u.d, " 0.E+01;"); + realTest("(RD,G7.1,';')", u.d, " 1. ;"); + realTest("(RU,E8.1,';')", u.d, " 0.2E+01;"); + realTest("(RU,G7.0,';')", u.d, " 0.E+01;"); + realTest("(RU,G7.1,';')", u.d, " 2. ;"); + realTest("(RZ,E8.1,';')", u.d, " 0.1E+01;"); + realTest("(RZ,F3.0,';')", u.d, " 1.;"); + realTest("(RZ,G7.0,';')", u.d, " 0.E+01;"); + realTest("(RZ,G7.1,';')", u.d, " 1. ;"); + realTest("(RC,E8.1,';')", u.d, " 0.2E+01;"); + realTest("(RC,F3.0,';')", u.d, " 2.;"); + realTest("(RC,G7.0,';')", u.d, " 0.E+01;"); + realTest("(RC,G7.1,';')", u.d, " 2. ;"); + + // TODO continue F and G editing tests on these data + + u.n = 0xbff8000000000000; // -1.5 + realTest("(E9.2,';')", u.d, "-0.15E+01;"); + realTest("(RN,E8.1,';')", u.d, "-0.2E+01;"); + realTest("(RD,E8.1,';')", u.d, "-0.2E+01;"); + realTest("(RU,E8.1,';')", u.d, "-0.1E+01;"); + realTest("(RZ,E8.1,';')", u.d, "-0.1E+01;"); + realTest("(RC,E8.1,';')", u.d, "-0.2E+01;"); + + u.n = 0x4004000000000000; // 2.5 + realTest("(E9.2,';')", u.d, " 0.25E+01;"); + realTest("(RN,E8.1,';')", u.d, " 0.2E+01;"); + realTest("(RD,E8.1,';')", u.d, " 0.2E+01;"); + realTest("(RU,E8.1,';')", u.d, " 0.3E+01;"); + realTest("(RZ,E8.1,';')", u.d, " 0.2E+01;"); + realTest("(RC,E8.1,';')", u.d, " 0.3E+01;"); + + u.n = 0xc004000000000000; // -2.5 + realTest("(E9.2,';')", u.d, "-0.25E+01;"); + realTest("(RN,E8.1,';')", u.d, "-0.2E+01;"); + realTest("(RD,E8.1,';')", u.d, "-0.3E+01;"); + realTest("(RU,E8.1,';')", u.d, "-0.2E+01;"); + realTest("(RZ,E8.1,';')", u.d, "-0.2E+01;"); + realTest("(RC,E8.1,';')", u.d, "-0.3E+01;"); + + u.n = 1; // least positive nonzero subnormal + realTest("(E32.17,';')", u.d, " 0.49406564584124654-323;"); + realTest("(ES32.17,';')", u.d, " 4.94065645841246544-324;"); + realTest("(EN32.17,';')", u.d, " 4.94065645841246544-324;"); + realTest("(E759.752,';')", u.d, + " 0." + "494065645841246544176568792868221372365059802614324764425585682500675507" + "270208751865299836361635992379796564695445717730926656710355939796398774" + "796010781878126300713190311404527845817167848982103688718636056998730723" + "050006387409153564984387312473397273169615140031715385398074126238565591" + "171026658556686768187039560310624931945271591492455329305456544401127480" + "129709999541931989409080416563324524757147869014726780159355238611550134" + "803526493472019379026810710749170333222684475333572083243193609238289345" + "836806010601150616980975307834227731832924790498252473077637592724787465" + "608477820373446969953364701797267771758512566055119913150489110145103786" + "273816725095583738973359899366480994116420570263709027924276754456522908" + "75386825064197182655334472656250-323;"); + realTest("(G0,';')", u.d, ".5-323;"); + realTest("(E757.750,';')", u.d, + " 0." + "494065645841246544176568792868221372365059802614324764425585682500675507" + "270208751865299836361635992379796564695445717730926656710355939796398774" + "796010781878126300713190311404527845817167848982103688718636056998730723" + "050006387409153564984387312473397273169615140031715385398074126238565591" + "171026658556686768187039560310624931945271591492455329305456544401127480" + "129709999541931989409080416563324524757147869014726780159355238611550134" + "803526493472019379026810710749170333222684475333572083243193609238289345" + "836806010601150616980975307834227731832924790498252473077637592724787465" + "608477820373446969953364701797267771758512566055119913150489110145103786" + "273816725095583738973359899366480994116420570263709027924276754456522908" + "753868250641971826553344726562-323;"); + realTest("(RN,E757.750,';')", u.d, + " 0." + "494065645841246544176568792868221372365059802614324764425585682500675507" + "270208751865299836361635992379796564695445717730926656710355939796398774" + "796010781878126300713190311404527845817167848982103688718636056998730723" + "050006387409153564984387312473397273169615140031715385398074126238565591" + "171026658556686768187039560310624931945271591492455329305456544401127480" + "129709999541931989409080416563324524757147869014726780159355238611550134" + "803526493472019379026810710749170333222684475333572083243193609238289345" + "836806010601150616980975307834227731832924790498252473077637592724787465" + "608477820373446969953364701797267771758512566055119913150489110145103786" + "273816725095583738973359899366480994116420570263709027924276754456522908" + "753868250641971826553344726562-323;"); + realTest("(RD,E757.750,';')", u.d, + " 0." + "494065645841246544176568792868221372365059802614324764425585682500675507" + "270208751865299836361635992379796564695445717730926656710355939796398774" + "796010781878126300713190311404527845817167848982103688718636056998730723" + "050006387409153564984387312473397273169615140031715385398074126238565591" + "171026658556686768187039560310624931945271591492455329305456544401127480" + "129709999541931989409080416563324524757147869014726780159355238611550134" + "803526493472019379026810710749170333222684475333572083243193609238289345" + "836806010601150616980975307834227731832924790498252473077637592724787465" + "608477820373446969953364701797267771758512566055119913150489110145103786" + "273816725095583738973359899366480994116420570263709027924276754456522908" + "753868250641971826553344726562-323;"); + realTest("(RU,E757.750,';')", u.d, + " 0." + "494065645841246544176568792868221372365059802614324764425585682500675507" + "270208751865299836361635992379796564695445717730926656710355939796398774" + "796010781878126300713190311404527845817167848982103688718636056998730723" + "050006387409153564984387312473397273169615140031715385398074126238565591" + "171026658556686768187039560310624931945271591492455329305456544401127480" + "129709999541931989409080416563324524757147869014726780159355238611550134" + "803526493472019379026810710749170333222684475333572083243193609238289345" + "836806010601150616980975307834227731832924790498252473077637592724787465" + "608477820373446969953364701797267771758512566055119913150489110145103786" + "273816725095583738973359899366480994116420570263709027924276754456522908" + "753868250641971826553344726563-323;"); + realTest("(RC,E757.750,';')", u.d, + " 0." + "494065645841246544176568792868221372365059802614324764425585682500675507" + "270208751865299836361635992379796564695445717730926656710355939796398774" + "796010781878126300713190311404527845817167848982103688718636056998730723" + "050006387409153564984387312473397273169615140031715385398074126238565591" + "171026658556686768187039560310624931945271591492455329305456544401127480" + "129709999541931989409080416563324524757147869014726780159355238611550134" + "803526493472019379026810710749170333222684475333572083243193609238289345" + "836806010601150616980975307834227731832924790498252473077637592724787465" + "608477820373446969953364701797267771758512566055119913150489110145103786" + "273816725095583738973359899366480994116420570263709027924276754456522908" + "753868250641971826553344726563-323;"); + + u.n = 0x10000000000000; // least positive nonzero normal + realTest("(E723.716,';')", u.d, + " 0." + "222507385850720138309023271733240406421921598046233183055332741688720443" + "481391819585428315901251102056406733973103581100515243416155346010885601" + "238537771882113077799353200233047961014744258363607192156504694250373420" + "837525080665061665815894872049117996859163964850063590877011830487479978" + "088775374994945158045160505091539985658247081864511353793580499211598108" + "576605199243335211435239014879569960959128889160299264151106346631339366" + "347758651302937176204732563178148566435087212282863764204484681140761391" + "147706280168985324411002416144742161856716615054015428508471675290190316" + "132277889672970737312333408698898317506783884692609277397797285865965494" + "10913690954061364675687023986783152906809846172109246253967285156250-" + "307;"); + realTest("(G0,';')", u.d, ".22250738585072014-307;"); + + u.n = 0x7fefffffffffffffuLL; // greatest finite + realTest("(E32.17,';')", u.d, " 0.17976931348623157+309;"); + realTest("(E317.310,';')", u.d, + " 0." + "179769313486231570814527423731704356798070567525844996598917476803157260" + "780028538760589558632766878171540458953514382464234321326889464182768467" + "546703537516986049910576551282076245490090389328944075868508455133942304" + "583236903222948165808559332123348274797826204144723168738177180919299881" + "2504040261841248583680+309;"); + realTest("(ES317.310,';')", u.d, + " 1." + "797693134862315708145274237317043567980705675258449965989174768031572607" + "800285387605895586327668781715404589535143824642343213268894641827684675" + "467035375169860499105765512820762454900903893289440758685084551339423045" + "832369032229481658085593321233482747978262041447231687381771809192998812" + "5040402618412485836800+308;"); + realTest("(EN319.310,';')", u.d, + " 179." + "769313486231570814527423731704356798070567525844996598917476803157260780" + "028538760589558632766878171540458953514382464234321326889464182768467546" + "703537516986049910576551282076245490090389328944075868508455133942304583" + "236903222948165808559332123348274797826204144723168738177180919299881250" + "4040261841248583680000+306;"); + realTest("(G0,';')", u.d, ".17976931348623157+309;"); + if (failures == 0) { std::cout << "PASS\n"; } else { From 572a57d3d0d785bb3f2aad9e890ef498c1214309 Mon Sep 17 00:00:00 2001 From: "Jinxin (Brian) Yang" Date: Wed, 5 Feb 2020 10:13:43 -0800 Subject: [PATCH 08/18] [OpenMP] Predetermined rules for loop index variables (#962) This refers to three rules in OpenMP 4.5 Spec 2.15.1.1: * The loop iteration variable(s) in the associated do-loop(s) of a do, parallel do, taskloop, or distribute construct is (are) private. * The loop iteration variable in the associated do-loop of a simd construct with just one associated do-loop is linear with a linear-step that is the increment of the associated do-loop. * The loop iteration variables in the associated do-loops of a simd construct with multiple associated do-loops are lastprivate. A simple example: ``` implicit none integer :: N = 1024 integer i, j, k !$omp parallel do collapse(3) do i=1, N <- i is private do j=1, N <- j is private do k=1, N <- k is private enddo enddo enddo end ``` If `collapse` clause is not present, the associated do-loop for construct `parallel do` is only `i` loop. With `collapse(n)`, `i`, `j`, and `k` are all associated do-loops and the loop index variables are private to the OpenMP construct: ``` implicit none !DEF: /MainProgram1/n ObjectEntity INTEGER(4) integer :: n = 1024 !DEF: /MainProgram1/i ObjectEntity INTEGER(4) !DEF: /MainProgram1/j ObjectEntity INTEGER(4) !DEF: /MainProgram1/k ObjectEntity INTEGER(4) integer i, j, k !$omp parallel do collapse(3) !DEF: /MainProgram1/Block1/i (OmpPrivate) HostAssoc INTEGER(4) !REF: /MainProgram1/n do i=1,n !DEF: /MainProgram1/Block1/j (OmpPrivate) HostAssoc INTEGER(4) !REF: /MainProgram1/n do j=1,n !DEF: /MainProgram1/Block1/k (OmpPrivate) HostAssoc INTEGER(4) !REF: /MainProgram1/n do k=1,n end do end do end do end program ``` This implementation assumes that the structural checks for do-loops are done at this point, for example the `n` in `collapse(n)` should be no more than the number of actual perfectly nested do-loops, etc.. --- lib/semantics/check-omp-structure.cpp | 43 ----- lib/semantics/check-omp-structure.h | 43 +++++ lib/semantics/resolve-names.cpp | 145 +++++++++++++++- test/semantics/CMakeLists.txt | 1 + test/semantics/omp-clause-validity01.f90 | 10 +- test/semantics/omp-device-constructs.f90 | 6 +- test/semantics/omp-symbol01.f90 | 8 +- test/semantics/omp-symbol04.f90 | 2 +- test/semantics/omp-symbol06.f90 | 2 +- test/semantics/omp-symbol08.f90 | 209 +++++++++++++++++++++++ 10 files changed, 414 insertions(+), 55 deletions(-) create mode 100644 test/semantics/omp-symbol08.f90 diff --git a/lib/semantics/check-omp-structure.cpp b/lib/semantics/check-omp-structure.cpp index 8d22d422e909..c8493c05b22c 100644 --- a/lib/semantics/check-omp-structure.cpp +++ b/lib/semantics/check-omp-structure.cpp @@ -13,49 +13,6 @@ namespace Fortran::semantics { -static constexpr OmpDirectiveSet parallelSet{ - OmpDirective::DISTRIBUTE_PARALLEL_DO, - OmpDirective::DISTRIBUTE_PARALLEL_DO_SIMD, OmpDirective::PARALLEL, - OmpDirective::PARALLEL_DO, OmpDirective::PARALLEL_DO_SIMD, - OmpDirective::PARALLEL_SECTIONS, OmpDirective::PARALLEL_WORKSHARE, - OmpDirective::TARGET_PARALLEL, OmpDirective::TARGET_PARALLEL_DO, - OmpDirective::TARGET_PARALLEL_DO_SIMD, - OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO, - OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, - OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO, - OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD}; -static constexpr OmpDirectiveSet doSet{OmpDirective::DISTRIBUTE_PARALLEL_DO, - OmpDirective::DISTRIBUTE_PARALLEL_DO_SIMD, OmpDirective::PARALLEL_DO, - OmpDirective::PARALLEL_DO_SIMD, OmpDirective::DO, OmpDirective::DO_SIMD, - OmpDirective::TARGET_PARALLEL_DO, OmpDirective::TARGET_PARALLEL_DO_SIMD, - OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO, - OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, - OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO, - OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD}; -static constexpr OmpDirectiveSet simdSet{ - OmpDirective::DISTRIBUTE_PARALLEL_DO_SIMD, OmpDirective::DISTRIBUTE_SIMD, - OmpDirective::PARALLEL_DO_SIMD, OmpDirective::DO_SIMD, OmpDirective::SIMD, - OmpDirective::TARGET_PARALLEL_DO_SIMD, - OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, - OmpDirective::TARGET_TEAMS_DISTRIBUTE_SIMD, OmpDirective::TARGET_SIMD, - OmpDirective::TASKLOOP_SIMD, - OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, - OmpDirective::TEAMS_DISTRIBUTE_SIMD}; -static constexpr OmpDirectiveSet doSimdSet{ - OmpDirective::DISTRIBUTE_PARALLEL_DO_SIMD, OmpDirective::PARALLEL_DO_SIMD, - OmpDirective::DO_SIMD, OmpDirective::TARGET_PARALLEL_DO_SIMD, - OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, - OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD}; -static constexpr OmpDirectiveSet taskloopSet{ - OmpDirective::TASKLOOP, OmpDirective::TASKLOOP_SIMD}; -static constexpr OmpDirectiveSet targetSet{OmpDirective::TARGET, - OmpDirective::TARGET_PARALLEL, OmpDirective::TARGET_PARALLEL_DO, - OmpDirective::TARGET_PARALLEL_DO_SIMD, OmpDirective::TARGET_SIMD, - OmpDirective::TARGET_TEAMS, OmpDirective::TARGET_TEAMS_DISTRIBUTE, - OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO, - OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, - OmpDirective::TARGET_TEAMS_DISTRIBUTE_SIMD}; - std::string OmpStructureChecker::ContextDirectiveAsFortran() { auto dir{EnumToString(GetContext().directive)}; std::replace(dir.begin(), dir.end(), '_', ' '); diff --git a/lib/semantics/check-omp-structure.h b/lib/semantics/check-omp-structure.h index cfe4a2f0cda5..b20c32550769 100644 --- a/lib/semantics/check-omp-structure.h +++ b/lib/semantics/check-omp-structure.h @@ -46,6 +46,49 @@ ENUM_CLASS(OmpClause, ALIGNED, COLLAPSE, COPYIN, COPYPRIVATE, DEFAULT, using OmpClauseSet = common::EnumSet; +static constexpr OmpDirectiveSet parallelSet{ + OmpDirective::DISTRIBUTE_PARALLEL_DO, + OmpDirective::DISTRIBUTE_PARALLEL_DO_SIMD, OmpDirective::PARALLEL, + OmpDirective::PARALLEL_DO, OmpDirective::PARALLEL_DO_SIMD, + OmpDirective::PARALLEL_SECTIONS, OmpDirective::PARALLEL_WORKSHARE, + OmpDirective::TARGET_PARALLEL, OmpDirective::TARGET_PARALLEL_DO, + OmpDirective::TARGET_PARALLEL_DO_SIMD, + OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO, + OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, + OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO, + OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD}; +static constexpr OmpDirectiveSet doSet{OmpDirective::DISTRIBUTE_PARALLEL_DO, + OmpDirective::DISTRIBUTE_PARALLEL_DO_SIMD, OmpDirective::PARALLEL_DO, + OmpDirective::PARALLEL_DO_SIMD, OmpDirective::DO, OmpDirective::DO_SIMD, + OmpDirective::TARGET_PARALLEL_DO, OmpDirective::TARGET_PARALLEL_DO_SIMD, + OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO, + OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, + OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO, + OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD}; +static constexpr OmpDirectiveSet doSimdSet{ + OmpDirective::DISTRIBUTE_PARALLEL_DO_SIMD, OmpDirective::PARALLEL_DO_SIMD, + OmpDirective::DO_SIMD, OmpDirective::TARGET_PARALLEL_DO_SIMD, + OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, + OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD}; +static constexpr OmpDirectiveSet taskloopSet{ + OmpDirective::TASKLOOP, OmpDirective::TASKLOOP_SIMD}; +static constexpr OmpDirectiveSet targetSet{OmpDirective::TARGET, + OmpDirective::TARGET_PARALLEL, OmpDirective::TARGET_PARALLEL_DO, + OmpDirective::TARGET_PARALLEL_DO_SIMD, OmpDirective::TARGET_SIMD, + OmpDirective::TARGET_TEAMS, OmpDirective::TARGET_TEAMS_DISTRIBUTE, + OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO, + OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, + OmpDirective::TARGET_TEAMS_DISTRIBUTE_SIMD}; +static constexpr OmpDirectiveSet simdSet{ + OmpDirective::DISTRIBUTE_PARALLEL_DO_SIMD, OmpDirective::DISTRIBUTE_SIMD, + OmpDirective::PARALLEL_DO_SIMD, OmpDirective::DO_SIMD, OmpDirective::SIMD, + OmpDirective::TARGET_PARALLEL_DO_SIMD, + OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, + OmpDirective::TARGET_TEAMS_DISTRIBUTE_SIMD, OmpDirective::TARGET_SIMD, + OmpDirective::TASKLOOP_SIMD, + OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, + OmpDirective::TEAMS_DISTRIBUTE_SIMD}; + class OmpStructureChecker : public virtual BaseChecker { public: OmpStructureChecker(SemanticsContext &context) : context_{context} {} diff --git a/lib/semantics/resolve-names.cpp b/lib/semantics/resolve-names.cpp index 5ab1424b246f..a7b76d61843c 100644 --- a/lib/semantics/resolve-names.cpp +++ b/lib/semantics/resolve-names.cpp @@ -1148,6 +1148,11 @@ class OmpAttributeVisitor { template bool Pre(const A &) { return true; } template void Post(const A &) {} + bool Pre(const parser::SpecificationPart &x) { + Walk(std::get>(x.t)); + return false; + } + bool Pre(const parser::OpenMPBlockConstruct &); void Post(const parser::OpenMPBlockConstruct &) { PopContext(); } void Post(const parser::OmpBeginBlockDirective &) { @@ -1199,6 +1204,7 @@ class OmpAttributeVisitor { // variables on Data-sharing attribute clauses std::map objectWithDSA; bool withinConstruct{false}; + std::size_t associatedLoopLevel{0}; }; // back() is the top of the stack OmpContext &GetContext() { @@ -1226,6 +1232,10 @@ class OmpAttributeVisitor { auto it{GetContext().objectWithDSA.find(&symbol)}; return it != GetContext().objectWithDSA.end(); } + void SetContextAssociatedLoopLevel(std::size_t level) { + GetContext().associatedLoopLevel = level; + } + std::size_t GetAssociatedLoopLevelFromClauses(const parser::OmpClauseList &); Symbol &MakeAssocSymbol(const SourceName &name, Symbol &prev) { const auto pair{ @@ -1260,6 +1270,11 @@ class OmpAttributeVisitor { } bool HasDataSharingAttributeObject(const Symbol &); + const parser::DoConstruct *GetDoConstructIf( + const parser::ExecutionPartConstruct &); + // Predetermined DSA rules + void PrivatizeAssociatedLoopIndex(const parser::OpenMPLoopConstruct &); + void ResolveOmpObjectList(const parser::OmpObjectList &, Symbol::Flag); void ResolveOmpObject(const parser::OmpObject &, Symbol::Flag); Symbol *ResolveOmp(const parser::Name &, Symbol::Flag); @@ -5935,10 +5950,20 @@ bool OmpAttributeVisitor::Pre(const parser::OpenMPBlockConstruct &x) { bool OmpAttributeVisitor::Pre(const parser::OpenMPLoopConstruct &x) { const auto &beginLoopDir{std::get(x.t)}; const auto &beginDir{std::get(beginLoopDir.t)}; + const auto &clauseList{std::get(beginLoopDir.t)}; switch (beginDir.v) { case parser::OmpLoopDirective::Directive::Distribute: PushContext(beginDir.source, OmpDirective::DISTRIBUTE); break; + case parser::OmpLoopDirective::Directive::DistributeParallelDo: + PushContext(beginDir.source, OmpDirective::DISTRIBUTE_PARALLEL_DO); + break; + case parser::OmpLoopDirective::Directive::DistributeParallelDoSimd: + PushContext(beginDir.source, OmpDirective::DISTRIBUTE_PARALLEL_DO_SIMD); + break; + case parser::OmpLoopDirective::Directive::DistributeSimd: + PushContext(beginDir.source, OmpDirective::DISTRIBUTE_SIMD); + break; case parser::OmpLoopDirective::Directive::Do: PushContext(beginDir.source, OmpDirective::DO); break; @@ -5954,20 +5979,136 @@ bool OmpAttributeVisitor::Pre(const parser::OpenMPLoopConstruct &x) { case parser::OmpLoopDirective::Directive::Simd: PushContext(beginDir.source, OmpDirective::SIMD); break; + case parser::OmpLoopDirective::Directive::TargetParallelDo: + PushContext(beginDir.source, OmpDirective::TARGET_PARALLEL_DO); + break; + case parser::OmpLoopDirective::Directive::TargetParallelDoSimd: + PushContext(beginDir.source, OmpDirective::TARGET_PARALLEL_DO_SIMD); + break; + case parser::OmpLoopDirective::Directive::TargetTeamsDistribute: + PushContext(beginDir.source, OmpDirective::TARGET_TEAMS_DISTRIBUTE); + break; + case parser::OmpLoopDirective::Directive::TargetTeamsDistributeParallelDo: + PushContext( + beginDir.source, OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO); + break; + case parser::OmpLoopDirective::Directive::TargetTeamsDistributeParallelDoSimd: + PushContext(beginDir.source, + OmpDirective::TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); + break; + case parser::OmpLoopDirective::Directive::TargetTeamsDistributeSimd: + PushContext(beginDir.source, OmpDirective::TARGET_TEAMS_DISTRIBUTE_SIMD); + break; + case parser::OmpLoopDirective::Directive::TargetSimd: + PushContext(beginDir.source, OmpDirective::TARGET_SIMD); + break; case parser::OmpLoopDirective::Directive::Taskloop: PushContext(beginDir.source, OmpDirective::TASKLOOP); break; case parser::OmpLoopDirective::Directive::TaskloopSimd: PushContext(beginDir.source, OmpDirective::TASKLOOP_SIMD); break; - default: - // TODO others + case parser::OmpLoopDirective::Directive::TeamsDistribute: + PushContext(beginDir.source, OmpDirective::TEAMS_DISTRIBUTE); + break; + case parser::OmpLoopDirective::Directive::TeamsDistributeParallelDo: + PushContext(beginDir.source, OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO); + break; + case parser::OmpLoopDirective::Directive::TeamsDistributeParallelDoSimd: + PushContext( + beginDir.source, OmpDirective::TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); + break; + case parser::OmpLoopDirective::Directive::TeamsDistributeSimd: + PushContext(beginDir.source, OmpDirective::TEAMS_DISTRIBUTE_SIMD); break; } ClearDataSharingAttributeObjects(); + SetContextAssociatedLoopLevel(GetAssociatedLoopLevelFromClauses(clauseList)); + PrivatizeAssociatedLoopIndex(x); return true; } +const parser::DoConstruct *OmpAttributeVisitor::GetDoConstructIf( + const parser::ExecutionPartConstruct &x) { + if (auto *y{std::get_if(&x.u)}) { + if (auto *z{std::get_if>(&y->u)}) { + return &z->value(); + } + } + return nullptr; +} + +std::size_t OmpAttributeVisitor::GetAssociatedLoopLevelFromClauses( + const parser::OmpClauseList &x) { + std::size_t orderedLevel{0}; + std::size_t collapseLevel{0}; + for (const auto &clause : x.v) { + if (const auto *orderedClause{ + std::get_if(&clause.u)}) { + if (const auto v{ + evaluate::ToInt64(resolver_.EvaluateIntExpr(orderedClause->v))}) { + orderedLevel = *v; + } + } + if (const auto *collapseClause{ + std::get_if(&clause.u)}) { + if (const auto v{evaluate::ToInt64( + resolver_.EvaluateIntExpr(collapseClause->v))}) { + collapseLevel = *v; + } + } + } + + if (orderedLevel && (!collapseLevel || orderedLevel >= collapseLevel)) { + return orderedLevel; + } else if (!orderedLevel && collapseLevel) { + return collapseLevel; + } // orderedLevel < collapseLevel is an error handled in structural checks + return 1; // default is outermost loop +} + +// 2.15.1.1 Data-sharing Attribute Rules - Predetermined +// - The loop iteration variable(s) in the associated do-loop(s) of a do, +// parallel do, taskloop, or distribute construct is (are) private. +// - The loop iteration variable in the associated do-loop of a simd construct +// with just one associated do-loop is linear with a linear-step that is the +// increment of the associated do-loop. +// - The loop iteration variables in the associated do-loops of a simd +// construct with multiple associated do-loops are lastprivate. +// +// TODO: This assumes that the do-loops association for collapse/ordered +// clause has been performed (the number of nested do-loops >= n). +void OmpAttributeVisitor::PrivatizeAssociatedLoopIndex( + const parser::OpenMPLoopConstruct &x) { + std::size_t level{GetContext().associatedLoopLevel}; + Symbol::Flag ivDSA{Symbol::Flag::OmpPrivate}; + if (simdSet.test(GetContext().directive)) { + if (level == 1) { + ivDSA = Symbol::Flag::OmpLinear; + } else { + ivDSA = Symbol::Flag::OmpLastPrivate; + } + } + + auto &outer{std::get>(x.t)}; + for (const parser::DoConstruct *loop{&*outer}; loop && level > 0; --level) { + // go through all the nested do-loops and resolve index variables + auto &loopControl{loop->GetLoopControl().value()}; + using Bounds = parser::LoopControl::Bounds; + const Bounds &bounds{std::get(loopControl.u)}; + const parser::Name &iv{bounds.name.thing}; + if (auto *symbol{ResolveOmp(iv, ivDSA)}) { + iv.symbol = symbol; // adjust the symbol within region + AddToContextObjectWithDSA(*symbol, ivDSA); + } + + const auto &block{std::get(loop->t)}; + const auto it{block.begin()}; + loop = it != block.end() ? GetDoConstructIf(*it) : nullptr; + } + CHECK(level == 0); +} + bool OmpAttributeVisitor::Pre(const parser::OpenMPSectionsConstruct &x) { const auto &beginSectionsDir{ std::get(x.t)}; diff --git a/test/semantics/CMakeLists.txt b/test/semantics/CMakeLists.txt index 5dfbcb2bf928..2dd11981577b 100644 --- a/test/semantics/CMakeLists.txt +++ b/test/semantics/CMakeLists.txt @@ -229,6 +229,7 @@ set(SYMBOL_TESTS omp-symbol05.f90 omp-symbol06.f90 omp-symbol07.f90 + omp-symbol08.f90 kinds01.f90 kinds03.f90 procinterface01.f90 diff --git a/test/semantics/omp-clause-validity01.f90 b/test/semantics/omp-clause-validity01.f90 index 08abc1f032ce..d624564cd20b 100644 --- a/test/semantics/omp-clause-validity01.f90 +++ b/test/semantics/omp-clause-validity01.f90 @@ -43,7 +43,9 @@ !ERROR: COLLAPSE clause is not allowed on the PARALLEL directive !$omp parallel collapse(2) do i = 1, N - a = 3.14 + do j = 1, N + a = 3.14 + enddo enddo !$omp end parallel @@ -143,7 +145,7 @@ enddo !ERROR: The parameter of the ORDERED clause must be greater than or equal to the parameter of the COLLAPSE clause - !$omp do collapse(num) ordered(1+2+3+4) + !$omp do collapse(num-14) ordered(1) do i = 1, N do j = 1, N do k = 1, N @@ -309,7 +311,9 @@ !ERROR: NOGROUP clause is not allowed on the DO SIMD directive !$omp do simd ordered(2) NOGROUP do i = 1, N - a = 3.14 + do j = 1, N + a = 3.14 + enddo enddo !$omp end parallel diff --git a/test/semantics/omp-device-constructs.f90 b/test/semantics/omp-device-constructs.f90 index 118e49c9afc9..e87cb119dba4 100644 --- a/test/semantics/omp-device-constructs.f90 +++ b/test/semantics/omp-device-constructs.f90 @@ -149,7 +149,11 @@ program main !ERROR: At most one COLLAPSE clause can appear on the DISTRIBUTE directive !$omp distribute collapse(2) collapse(3) do i = 1, N - a = 3.14 + do j = 1, N + do k = 1, N + a = 3.14 + enddo + enddo enddo !$omp end distribute !$omp end target diff --git a/test/semantics/omp-symbol01.f90 b/test/semantics/omp-symbol01.f90 index 2286bcc5a35e..eca885565fba 100644 --- a/test/semantics/omp-symbol01.f90 +++ b/test/semantics/omp-symbol01.f90 @@ -45,21 +45,21 @@ program mm !DEF: /mm/c (Implicit) ObjectEntity REAL(4) c = 2.0 !$omp parallel do private(a,t,/c/) shared(c) - !DEF: /mm/i (Implicit) ObjectEntity INTEGER(4) + !DEF: /mm/Block1/i (OmpPrivate) HostAssoc INTEGER(4) do i=1,10 !DEF: /mm/Block1/a (OmpPrivate) HostAssoc REAL(4) !REF: /mm/b - !REF: /mm/i + !REF: /mm/Block1/i a = a+b(i) !DEF: /mm/Block1/t (OmpPrivate) HostAssoc TYPE(myty) !REF: /md/myty/a - !REF: /mm/i + !REF: /mm/Block1/i t%a = i !DEF: /mm/Block1/y (OmpPrivate) HostAssoc REAL(4) y = 0. !DEF: /mm/Block1/x (OmpPrivate) HostAssoc REAL(4) !REF: /mm/Block1/a - !REF: /mm/i + !REF: /mm/Block1/i !REF: /mm/Block1/y x = a+i+y !REF: /mm/c diff --git a/test/semantics/omp-symbol04.f90 b/test/semantics/omp-symbol04.f90 index d97768d9396c..9daacfb49854 100644 --- a/test/semantics/omp-symbol04.f90 +++ b/test/semantics/omp-symbol04.f90 @@ -12,7 +12,7 @@ !DEF: /MainProgram1/Block1/a (OmpPrivate) HostAssoc REAL(8) a = 2. !$omp do private(a) - !DEF: /MainProgram1/i (Implicit) ObjectEntity INTEGER(4) + !DEF: /MainProgram1/Block1/Block1/i (OmpPrivate) HostAssoc INTEGER(4) do i=1,10 !DEF: /MainProgram1/Block1/Block1/a (OmpPrivate) HostAssoc REAL(8) a = 1. diff --git a/test/semantics/omp-symbol06.f90 b/test/semantics/omp-symbol06.f90 index d343d084c44d..3b82fc88e598 100644 --- a/test/semantics/omp-symbol06.f90 +++ b/test/semantics/omp-symbol06.f90 @@ -8,7 +8,7 @@ !DEF: /MainProgram1/a (Implicit) ObjectEntity REAL(4) a = 1. !$omp parallel do firstprivate(a) lastprivate(a) - !DEF: /MainProgram1/i (Implicit) ObjectEntity INTEGER(4) + !DEF: /MainProgram1/Block1/i (OmpPrivate) HostAssoc INTEGER(4) do i=1,10 !DEF: /MainProgram1/Block1/a (OmpFirstPrivate, OmpLastPrivate) HostAssoc REAL(4) a = 2. diff --git a/test/semantics/omp-symbol08.f90 b/test/semantics/omp-symbol08.f90 new file mode 100644 index 000000000000..eaf8ff2eaa9d --- /dev/null +++ b/test/semantics/omp-symbol08.f90 @@ -0,0 +1,209 @@ +!OPTIONS: -fopenmp + +! 2.15.1.1 Predetermined rules for associated do-loops index variable +! a) The loop iteration variable(s) in the associated do-loop(s) of a do, +! parallel do, taskloop, or distribute construct is (are) private. +! b) The loop iteration variable in the associated do-loop of a simd construct +! with just one associated do-loop is linear with a linear-step that is the +! increment of the associated do-loop. +! c) The loop iteration variables in the associated do-loops of a simd +! construct with multiple associated do-loops are lastprivate. +! - TBD + +! All the tests assume that the do-loops association for collapse/ordered +! clause has been performed (the number of nested do-loops >= n). + +! Rule a) +! TODO: nested constructs (k should be private too) +!DEF: /test_do (Subroutine) Subprogram +subroutine test_do + implicit none + !DEF: /test_do/a ObjectEntity REAL(4) + real a(20,20,20) + !DEF: /test_do/i ObjectEntity INTEGER(4) + !DEF: /test_do/j ObjectEntity INTEGER(4) + !DEF: /test_do/k ObjectEntity INTEGER(4) + integer i, j, k +!$omp parallel + !REF: /test_do/i + i = 99 +!$omp do collapse(2) + !DEF: /test_do/Block1/Block1/i (OmpPrivate) HostAssoc INTEGER(4) + do i=1,5 + !DEF: /test_do/Block1/Block1/j (OmpPrivate) HostAssoc INTEGER(4) + do j=6,10 + !REF: /test_do/a + a(1,1,1) = 0. + !REF: /test_do/k + do k=11,15 + !REF: /test_do/a + !REF: /test_do/k + !REF: /test_do/Block1/Block1/j + !REF: /test_do/Block1/Block1/i + a(k,j,i) = 1. + end do + end do + end do +!$omp end parallel +end subroutine test_do + +! Rule a) +!DEF: /test_pardo (Subroutine) Subprogram +subroutine test_pardo + implicit none + !DEF: /test_pardo/a ObjectEntity REAL(4) + real a(20,20,20) + !DEF: /test_pardo/i ObjectEntity INTEGER(4) + !DEF: /test_pardo/j ObjectEntity INTEGER(4) + !DEF: /test_pardo/k ObjectEntity INTEGER(4) + integer i, j, k +!$omp parallel do collapse(2) private(k) ordered(2) + !DEF: /test_pardo/Block1/i (OmpPrivate) HostAssoc INTEGER(4) + do i=1,5 + !DEF: /test_pardo/Block1/j (OmpPrivate) HostAssoc INTEGER(4) + do j=6,10 + !REF: /test_pardo/a + a(1,1,1) = 0. + !DEF: /test_pardo/Block1/k (OmpPrivate) HostAssoc INTEGER(4) + do k=11,15 + !REF: /test_pardo/a + !REF: /test_pardo/Block1/k + !REF: /test_pardo/Block1/j + !REF: /test_pardo/Block1/i + a(k,j,i) = 1. + end do + end do + end do +end subroutine test_pardo + +! Rule a) +!DEF: /test_taskloop (Subroutine) Subprogram +subroutine test_taskloop + implicit none + !DEF: /test_taskloop/a ObjectEntity REAL(4) + real a(5,5) + !DEF: /test_taskloop/i ObjectEntity INTEGER(4) + !DEF: /test_taskloop/j ObjectEntity INTEGER(4) + integer i, j +!$omp taskloop private(j) + !DEF: /test_taskloop/Block1/i (OmpPrivate) HostAssoc INTEGER(4) + do i=1,5 + !DEF: /test_taskloop/Block1/j (OmpPrivate) HostAssoc INTEGER(4) + !REF: /test_taskloop/Block1/i + do j=1,i + !REF: /test_taskloop/a + !REF: /test_taskloop/Block1/j + !REF: /test_taskloop/Block1/i + a(j,i) = 3.14 + end do + end do +!$omp end taskloop +end subroutine test_taskloop + +! Rule a); OpenMP 4.5 Examples teams.2.f90 +! TODO: reduction; data-mapping attributes +!DEF: /dotprod (Subroutine) Subprogram +!DEF: /dotprod/b ObjectEntity REAL(4) +!DEF: /dotprod/c ObjectEntity REAL(4) +!DEF: /dotprod/n ObjectEntity INTEGER(4) +!DEF: /dotprod/block_size ObjectEntity INTEGER(4) +!DEF: /dotprod/num_teams ObjectEntity INTEGER(4) +!DEF: /dotprod/block_threads ObjectEntity INTEGER(4) +subroutine dotprod (b, c, n, block_size, num_teams, block_threads) + implicit none + !REF: /dotprod/n + integer n + !REF: /dotprod/b + !REF: /dotprod/n + !REF: /dotprod/c + !DEF: /dotprod/sum ObjectEntity REAL(4) + real b(n), c(n), sum + !REF: /dotprod/block_size + !REF: /dotprod/num_teams + !REF: /dotprod/block_threads + !DEF: /dotprod/i ObjectEntity INTEGER(4) + !DEF: /dotprod/i0 ObjectEntity INTEGER(4) + integer block_size, num_teams, block_threads, i, i0 + !REF: /dotprod/sum + sum = 0.0e0 +!$omp target map(to:b,c) map(tofrom:sum) +!$omp teams num_teams(num_teams) thread_limit(block_threads) reduction(+:sum) +!$omp distribute + !DEF: /dotprod/Block1/Block1/Block1/i0 (OmpPrivate) HostAssoc INTEGER(4) + !REF: /dotprod/n + !REF: /dotprod/block_size + do i0=1,n,block_size +!$omp parallel do reduction(+:sum) + !DEF: /dotprod/Block1/Block1/Block1/Block1/i (OmpPrivate) HostAssoc INTEGER(4) + !REF: /dotprod/i0 + !DEF: /dotprod/min INTRINSIC (Function) ProcEntity + !REF: /dotprod/block_size + !REF: /dotprod/n + do i=i0,min(i0+block_size, n) + !REF: /dotprod/sum + !REF: /dotprod/b + !REF: /dotprod/Block1/Block1/Block1/Block1/i + !REF: /dotprod/c + sum = sum+b(i)*c(i) + end do + end do +!$omp end teams +!$omp end target + !REF: /dotprod/sum + print *, sum +end subroutine dotprod + +! Rule b) +! TODO: nested constructs (j, k should be private too) +!DEF: /test_simd (Subroutine) Subprogram +subroutine test_simd + implicit none + !DEF: /test_simd/a ObjectEntity REAL(4) + real a(20,20,20) + !DEF: /test_simd/i ObjectEntity INTEGER(4) + !DEF: /test_simd/j ObjectEntity INTEGER(4) + !DEF: /test_simd/k ObjectEntity INTEGER(4) + integer i, j, k +!$omp parallel do simd + !DEF: /test_simd/Block1/i (OmpLinear) HostAssoc INTEGER(4) + do i=1,5 + !REF: /test_simd/j + do j=6,10 + !REF: /test_simd/k + do k=11,15 + !REF: /test_simd/a + !REF: /test_simd/k + !REF: /test_simd/j + !REF: /test_simd/Block1/i + a(k,j,i) = 3.14 + end do + end do + end do +end subroutine test_simd + +! Rule c) +!DEF: /test_simd_multi (Subroutine) Subprogram +subroutine test_simd_multi + implicit none + !DEF: /test_simd_multi/a ObjectEntity REAL(4) + real a(20,20,20) + !DEF: /test_simd_multi/i ObjectEntity INTEGER(4) + !DEF: /test_simd_multi/j ObjectEntity INTEGER(4) + !DEF: /test_simd_multi/k ObjectEntity INTEGER(4) + integer i, j, k +!$omp parallel do simd collapse(3) + !DEF: /test_simd_multi/Block1/i (OmpLastPrivate) HostAssoc INTEGER(4) + do i=1,5 + !DEF: /test_simd_multi/Block1/j (OmpLastPrivate) HostAssoc INTEGER(4) + do j=6,10 + !DEF: /test_simd_multi/Block1/k (OmpLastPrivate) HostAssoc INTEGER(4) + do k=11,15 + !REF: /test_simd_multi/a + !REF: /test_simd_multi/Block1/k + !REF: /test_simd_multi/Block1/j + !REF: /test_simd_multi/Block1/i + a(k,j,i) = 3.14 + end do + end do + end do +end subroutine test_simd_multi From a1a95bfcd1811d697f1386fe57af664b8a16ffb5 Mon Sep 17 00:00:00 2001 From: Pete Steinfeld Date: Thu, 6 Feb 2020 12:26:51 -0800 Subject: [PATCH 09/18] Semantic checks for C702 C702 (R701) A colon shall not be used as a type-param-value except in the declaration of an entity that has the POINTER or ALLOCATABLE attribute. I added code to the visitor for a TypeDeclarationStmt to check for the 'LEN' type parameter for strings and to loop over the type parameters for derived types. I also ran into a few situations where previous tests had erroneously used a colon for type parameters without either the POINTER or ALLOCATABLE attribute and fixed them up. --- lib/semantics/resolve-names.cpp | 27 +++++++++++++++++-- test/evaluate/folding05.f90 | Bin 9530 -> 9530 bytes test/semantics/CMakeLists.txt | 1 + test/semantics/allocate03.f90 | 2 +- test/semantics/allocate09.f90 | 8 +++--- test/semantics/modfile28.f90 | 12 ++++----- test/semantics/resolve37.f90 | 2 ++ test/semantics/resolve69.f90 | 45 ++++++++++++++++++++++++++++++++ 8 files changed, 84 insertions(+), 13 deletions(-) create mode 100644 test/semantics/resolve69.f90 diff --git a/lib/semantics/resolve-names.cpp b/lib/semantics/resolve-names.cpp index a7b76d61843c..a964f85943a1 100644 --- a/lib/semantics/resolve-names.cpp +++ b/lib/semantics/resolve-names.cpp @@ -720,7 +720,7 @@ class DeclarationVisitor : public ArraySpecVisitor, void Post(const parser::DimensionStmt::Declaration &); void Post(const parser::CodimensionDecl &); bool Pre(const parser::TypeDeclarationStmt &) { return BeginDecl(); } - void Post(const parser::TypeDeclarationStmt &) { EndDecl(); } + void Post(const parser::TypeDeclarationStmt &); void Post(const parser::IntegerTypeSpec &); void Post(const parser::IntrinsicTypeSpec::Real &); void Post(const parser::IntrinsicTypeSpec::Complex &); @@ -2889,6 +2889,29 @@ bool DeclarationVisitor::CheckAccessibleComponent( return false; } +void DeclarationVisitor::Post(const parser::TypeDeclarationStmt &) { + if (!GetAttrs().HasAny({Attr::POINTER, Attr::ALLOCATABLE})) { // C702 + if (const auto *typeSpec{GetDeclTypeSpec()}) { + if (typeSpec->category() == DeclTypeSpec::Character) { + if (typeSpec->characterTypeSpec().length().isDeferred()) { + Say("The type parameter LEN cannot be deferred without" + " the POINTER or ALLOCATABLE attribute"_err_en_US); + } + } else if (const DerivedTypeSpec * derivedSpec{typeSpec->AsDerived()}) { + for (const auto &pair : derivedSpec->parameters()) { + if (pair.second.isDeferred()) { + Say(currStmtSource().value(), + "The value of type parameter '%s' cannot be deferred" + " without the POINTER or ALLOCATABLE attribute"_err_en_US, + pair.first); + } + } + } + } + } + EndDecl(); +} + void DeclarationVisitor::Post(const parser::DimensionStmt::Declaration &x) { const auto &name{std::get(x.t)}; DeclareObjectEntity(name, Attrs{}); @@ -3522,7 +3545,7 @@ bool DeclarationVisitor::Pre(const parser::DataComponentDefStmt &x) { // so POINTER & ALLOCATABLE enable forward references to derived types. Walk(std::get>(x.t)); set_allowForwardReferenceToDerivedType( - GetAttrs().test(Attr::POINTER) || GetAttrs().test(Attr::ALLOCATABLE)); + GetAttrs().HasAny({Attr::POINTER, Attr::ALLOCATABLE})); Walk(std::get(x.t)); set_allowForwardReferenceToDerivedType(false); Walk(std::get>(x.t)); diff --git a/test/evaluate/folding05.f90 b/test/evaluate/folding05.f90 index d6d8a45673822b31959a962829fd3a147889a315..5e5e5c576976724256e3c150f56be5df2efaf023 100644 GIT binary patch delta 35 mcmdnxwaaV6NoGc^&8L_rG6Ja>)*3b-b(7l>Bq+@)*3b-b(7l>Bq+@ 0xff are serialized into UTF-8; ! each of those bytes then gets encoded into UTF-8 for the module file. -character(kind=1,len=:), parameter :: c1 = 1_"Hi! 你好!" -character(kind=4,len=:), parameter :: c4a(*) = [4_"一", 4_"二", 4_"三", 4_"四", 4_"五"] +character(kind=1,len=*), parameter :: c1 = 1_"Hi! 你好!" +character(kind=4,len=*), parameter :: c4a(*) = [4_"一", 4_"二", 4_"三", 4_"四", 4_"五"] integer, parameter :: lc4 = len(c4) integer, parameter :: lc1 = len(c1) end module m !Expect: m.mod !module m -!character(:,4),parameter::c4=4_"Hi! \344\275\240\345\245\275!" -!character(:,1),parameter::c1=1_"Hi! \344\275\240\345\245\275!" -!character(:,4),parameter::c4a(1_8:*)=[CHARACTER(KIND=4,LEN=1)::4_"\344\270\200",4_"\344\272\214",4_"\344\270\211",4_"\345\233\233",4_"\344\272\224"] +!character(*,4),parameter::c4=4_"Hi! \344\275\240\345\245\275!" +!character(*,1),parameter::c1=1_"Hi! \344\275\240\345\245\275!" +!character(*,4),parameter::c4a(1_8:*)=[CHARACTER(KIND=4,LEN=1)::4_"\344\270\200",4_"\344\272\214",4_"\344\270\211",4_"\345\233\233",4_"\344\272\224"] !integer(4),parameter::lc4=7_4 !intrinsic::len !integer(4),parameter::lc1=11_4 diff --git a/test/semantics/resolve37.f90 b/test/semantics/resolve37.f90 index e2d5f124bed4..a33e3700a932 100644 --- a/test/semantics/resolve37.f90 +++ b/test/semantics/resolve37.f90 @@ -1,3 +1,5 @@ +! C701 The type-param-value for a kind type parameter shall be a constant +! expression. This constraint looks like a mistake in the standard. integer, parameter :: k = 8 real, parameter :: l = 8.0 integer :: n = 2 diff --git a/test/semantics/resolve69.f90 b/test/semantics/resolve69.f90 new file mode 100644 index 000000000000..5950f66e4741 --- /dev/null +++ b/test/semantics/resolve69.f90 @@ -0,0 +1,45 @@ +subroutine s1() + ! C701 (R701) The type-param-value for a kind type parameter shall be a + ! constant expression. + ! C702 (R701) A colon shall not be used as a type-param-value except in the + ! declaration of an entity that has the POINTER or ALLOCATABLE attribute. + integer, parameter :: constVal = 1 + integer :: nonConstVal = 1 +!ERROR: Invalid specification expression: reference to local entity 'nonconstval' + character(nonConstVal) :: colonString1 + character(len=20, kind=constVal + 1) :: constKindString + character(len=:, kind=constVal + 1), pointer :: constKindString1 +!ERROR: The type parameter LEN cannot be deferred without the POINTER or ALLOCATABLE attribute + character(len=:, kind=constVal + 1) :: constKindString2 +!ERROR: Must be a constant value + character(len=20, kind=nonConstVal) :: nonConstKindString +!ERROR: The type parameter LEN cannot be deferred without the POINTER or ALLOCATABLE attribute + character(len=:) :: deferredString +!ERROR: The type parameter LEN cannot be deferred without the POINTER or ALLOCATABLE attribute + character(:) :: colonString2 + !OK because of the allocatable attribute + character(:), allocatable :: colonString3 + + type derived(typeKind, typeLen) + integer, kind :: typeKind + integer, len :: typeLen + end type derived + + type (derived(constVal, 3)) :: constDerivedKind +!ERROR: Value of kind type parameter 'typekind' (nonconstval) is not a scalar INTEGER constant +!ERROR: Invalid specification expression: reference to local entity 'nonconstval' + type (derived(nonConstVal, 3)) :: nonConstDerivedKind + + !OK because all type-params are constants + type (derived(3, constVal)) :: constDerivedLen + +!ERROR: Invalid specification expression: reference to local entity 'nonconstval' + type (derived(3, nonConstVal)) :: nonConstDerivedLen +!ERROR: The value of type parameter 'typelen' cannot be deferred without the POINTER or ALLOCATABLE attribute + type (derived(3, :)) :: colonDerivedLen +!ERROR: The value of type parameter 'typekind' cannot be deferred without the POINTER or ALLOCATABLE attribute +!ERROR: The value of type parameter 'typelen' cannot be deferred without the POINTER or ALLOCATABLE attribute + type (derived( :, :)) :: colonDerivedLen1 + type (derived( :, :)), pointer :: colonDerivedLen2 + type (derived(4, :)), pointer :: colonDerivedLen3 +end subroutine s1 From 16543d22f74e9421ecb4078818f4c1970bac0a5d Mon Sep 17 00:00:00 2001 From: Jean Perier Date: Thu, 6 Feb 2020 03:27:36 -0800 Subject: [PATCH 10/18] Fix issues comming from clang-10 warnings - Remove SubprogramDetails copy ctor - Prevent copies in range based loops over symbols - Remove unsued var --- include/flang/semantics/symbol.h | 4 ---- lib/semantics/mod-file.cpp | 4 ++-- lib/semantics/resolve-labels.cpp | 2 +- lib/semantics/resolve-names.cpp | 2 +- lib/semantics/semantics.cpp | 2 +- runtime/buffer.h | 1 - 6 files changed, 5 insertions(+), 10 deletions(-) diff --git a/include/flang/semantics/symbol.h b/include/flang/semantics/symbol.h index faef1ca7af2b..a27a935bdb00 100644 --- a/include/flang/semantics/symbol.h +++ b/include/flang/semantics/symbol.h @@ -52,10 +52,6 @@ class MainProgramDetails { class SubprogramDetails { public: - SubprogramDetails() {} - SubprogramDetails(const SubprogramDetails &that) - : dummyArgs_{that.dummyArgs_}, result_{that.result_} {} - bool isFunction() const { return result_ != nullptr; } bool isInterface() const { return isInterface_; } void set_isInterface(bool value = true) { isInterface_ = value; } diff --git a/lib/semantics/mod-file.cpp b/lib/semantics/mod-file.cpp index 857c52b2b461..1f89c56e9870 100644 --- a/lib/semantics/mod-file.cpp +++ b/lib/semantics/mod-file.cpp @@ -915,10 +915,10 @@ void SubprogramSymbolCollector::DoType(const DeclTypeSpec *type) { if (const DerivedTypeSpec * extends{typeSymbol.GetParentTypeSpec()}) { DoSymbol(extends->name(), extends->typeSymbol()); } - for (const auto pair : derived->parameters()) { + for (const auto &pair : derived->parameters()) { DoParamValue(pair.second); } - for (const auto pair : *typeSymbol.scope()) { + for (const auto &pair : *typeSymbol.scope()) { const Symbol &comp{*pair.second}; DoSymbol(comp); } diff --git a/lib/semantics/resolve-labels.cpp b/lib/semantics/resolve-labels.cpp index 87cacb8376c3..723762706a85 100644 --- a/lib/semantics/resolve-labels.cpp +++ b/lib/semantics/resolve-labels.cpp @@ -824,7 +824,7 @@ void CheckBranchesIntoDoBody(const SourceStmtList &branches, if (HasScope(branchTarget.proxyForScope)) { const auto &fromPosition{branch.parserCharBlock}; const auto &toPosition{branchTarget.parserCharBlock}; - for (const auto body : loopBodies) { + for (const auto &body : loopBodies) { if (!InBody(fromPosition, body) && InBody(toPosition, body)) { context.Say(fromPosition, "branch into loop body from outside"_en_US) .Attach(body.first, "the loop branched into"_en_US); diff --git a/lib/semantics/resolve-names.cpp b/lib/semantics/resolve-names.cpp index a964f85943a1..197a32b4fee2 100644 --- a/lib/semantics/resolve-names.cpp +++ b/lib/semantics/resolve-names.cpp @@ -4099,7 +4099,7 @@ void DeclarationVisitor::SetSaveAttr(Symbol &symbol) { // Check types of common block objects, now that they are known. void DeclarationVisitor::CheckCommonBlocks() { // check for empty common blocks - for (const auto pair : currScope().commonBlocks()) { + for (const auto &pair : currScope().commonBlocks()) { const auto &symbol{*pair.second}; if (symbol.get().objects().empty() && symbol.attrs().test(Attr::BIND_C)) { diff --git a/lib/semantics/semantics.cpp b/lib/semantics/semantics.cpp index 1f9958e08469..8c5bece6f72e 100644 --- a/lib/semantics/semantics.cpp +++ b/lib/semantics/semantics.cpp @@ -294,7 +294,7 @@ void Semantics::DumpSymbols(std::ostream &os) { void Semantics::DumpSymbolsSources(std::ostream &os) const { NameToSymbolMap symbols; GetSymbolNames(context_.globalScope(), symbols); - for (const auto pair : symbols) { + for (const auto &pair : symbols) { const Symbol &symbol{pair.second}; if (auto sourceInfo{cooked_.GetSourcePositionRange(symbol.name())}) { os << symbol.name().ToString() << ": " << sourceInfo->first.file.path() diff --git a/runtime/buffer.h b/runtime/buffer.h index a7b31848df8d..ec39bacd6ec6 100644 --- a/runtime/buffer.h +++ b/runtime/buffer.h @@ -66,7 +66,6 @@ template class FileFrame { } else { // [cde........ab] -> [abcde........] auto n{start_ + length_ - size_}; // 3 for cde - auto gap{size_ - length_}; // 13 - 5 = 8 RUNTIME_CHECK(handler, length_ >= n); std::memmove(buffer_ + n, buffer_ + start_, length_ - n); // cdeab LeftShiftBufferCircularly(buffer_, length_, n); // abcde From c342575a9e0217fa3252b70b8ef3eac0236a58e3 Mon Sep 17 00:00:00 2001 From: Tim Keith Date: Mon, 10 Feb 2020 10:55:24 -0800 Subject: [PATCH 11/18] Fix compilation error on macOS The call to `std::min` failed to compile with GCC on macOS due to type inference because `std::size_t` is `long unsigned int` but `std::int64_t` is `long long int`. --- runtime/buffer.h | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/runtime/buffer.h b/runtime/buffer.h index a7b31848df8d..8a1fd9b39df5 100644 --- a/runtime/buffer.h +++ b/runtime/buffer.h @@ -41,8 +41,7 @@ template class FileFrame { FileOffset FrameAt() const { return fileOffset_ + frame_; } char *Frame() const { return buffer_ + start_ + frame_; } std::size_t FrameLength() const { - return std::min( - static_cast(length_ - frame_), size_ - (start_ + frame_)); + return std::min(length_ - frame_, size_ - (start_ + frame_)); } // Returns a short frame at a non-fatal EOF. Can return a long frame as well. From 75adddd504577a295f0c906aa049bd47ce2b4f2e Mon Sep 17 00:00:00 2001 From: Pete Steinfeld Date: Mon, 3 Feb 2020 10:31:30 -0800 Subject: [PATCH 12/18] Updated the description of `evaluate::Expr` types --- documentation/ImplementingASemanticCheck.md | 23 ++++++++++----------- 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/documentation/ImplementingASemanticCheck.md b/documentation/ImplementingASemanticCheck.md index cc5ff7f62667..736202abaa1f 100644 --- a/documentation/ImplementingASemanticCheck.md +++ b/documentation/ImplementingASemanticCheck.md @@ -214,22 +214,21 @@ existing framework used in DO construct semantic checking that traversed an be able to use a similar framework to traverse an `evaluate::Expr` node to find all of the `evaluate::ActualArgument` nodes. -Note that there are two distinct data types in the compiler called `Expr`. One -is in the `parser` namespace. `parser::Expr` is defined in the file +Note that the compiler has multiple types called `Expr`. One is in the +`parser` namespace. `parser::Expr` is defined in the file `include/flang/parser/parse-tree.h`. It represents a parsed expression that maps directly to the source code and has fields that specify any operators in the expression, the operands, and the source position of the expression. -The second `Expr` type is in the `evaluate` namespace. The `evaluate` -namespace contains many types associated with semantic checking of expressions. -`evaluate::Expr` is defined in the file `include/flang/evaluate/expression.h`. -It represents an expression after it has undergone semantic checking and -contains information that is only available after semantic analysis. This -information includes the Fortran type of the expression, whether it's a -reference to a function, whether it's an actual argument, etc. After an -expression has undergone semantic analysis, the field `typedExpr` in the -`parser::Expr` node is filled in with a pointer to the analyzed expression in -`evaluate::Expr`. +Additionally, in the namespace `evaluate`, there are `evaluate::Expr` +template classes defined in the file `include/flang/evaluate/expression.h`. +These are parameterized over the various types of Fortran and constitute a +suite of strongly-typed representations of valid Fortran expressions of type +`T` that have been fully elaborated with conversion operations and subjected to +constant folding. After an expression has undergone semantic analysis, the +field `typedExpr` in the `parser::Expr` node is filled in with a pointer that +owns an instance of `evaluate::Expr`, the most general representation +of an analyzed expression. All of the declarations associated with both FUNCTION and SUBROUTINE calls are in `include/flang/evaluate/call.h`. An `evaluate::FunctionRef` inherits from From 49a64c4c2374e930f6890b270289a6f49ba63edd Mon Sep 17 00:00:00 2001 From: Pete Steinfeld Date: Mon, 10 Feb 2020 13:24:32 -0800 Subject: [PATCH 13/18] Semantic checks for constraints on types I implemented and added tests for constraints C703, C704, C705, C706, and C796. In some cases, the code and/or test already existed, and all I did was add a notation indicating the associated constraint. --- lib/semantics/check-declarations.cpp | 2 +- lib/semantics/resolve-names.cpp | 33 ++++++++++++++-- test/semantics/CMakeLists.txt | 1 + test/semantics/allocate04.f90 | 2 +- test/semantics/resolve52.f90 | 1 + test/semantics/resolve69.f90 | 9 +++++ test/semantics/resolve70.f90 | 58 ++++++++++++++++++++++++++++ test/semantics/structconst01.f90 | 4 +- 8 files changed, 103 insertions(+), 7 deletions(-) create mode 100644 test/semantics/resolve70.f90 diff --git a/lib/semantics/check-declarations.cpp b/lib/semantics/check-declarations.cpp index a96bc6fb056b..7cd81c91c348 100644 --- a/lib/semantics/check-declarations.cpp +++ b/lib/semantics/check-declarations.cpp @@ -495,7 +495,7 @@ void CheckHelper::CheckDerivedType( } if (const DeclTypeSpec * parent{FindParentTypeSpec(symbol)}) { const DerivedTypeSpec *parentDerived{parent->AsDerived()}; - if (!IsExtensibleType(parentDerived)) { + if (!IsExtensibleType(parentDerived)) { // C705 messages_.Say("The parent type is not extensible"_err_en_US); } if (!symbol.attrs().test(Attr::ABSTRACT) && parentDerived && diff --git a/lib/semantics/resolve-names.cpp b/lib/semantics/resolve-names.cpp index 197a32b4fee2..f075fa30a4b8 100644 --- a/lib/semantics/resolve-names.cpp +++ b/lib/semantics/resolve-names.cpp @@ -343,6 +343,7 @@ class DeclTypeSpecVisitor : public AttrsVisitor { } KindExpr GetKindParamExpr( TypeCategory, const std::optional &); + void CheckForAbstractType(const Symbol &typeSymbol); private: State state_; @@ -731,7 +732,9 @@ class DeclarationVisitor : public ArraySpecVisitor, void Post(const parser::LengthSelector &); bool Pre(const parser::KindParam &); bool Pre(const parser::DeclarationTypeSpec::Type &); + void Post(const parser::DeclarationTypeSpec::Type &); bool Pre(const parser::DeclarationTypeSpec::Class &); + void Post(const parser::DeclarationTypeSpec::Class &); bool Pre(const parser::DeclarationTypeSpec::Record &); void Post(const parser::DerivedTypeSpec &); bool Pre(const parser::DerivedTypeDef &); @@ -1590,9 +1593,7 @@ void DeclTypeSpecVisitor::Post(const parser::TypeSpec &typeSpec) { case DeclTypeSpec::Character: typeSpec.declTypeSpec = spec; break; case DeclTypeSpec::TypeDerived: if (const DerivedTypeSpec * derived{spec->AsDerived()}) { - if (derived->typeSymbol().attrs().test(Attr::ABSTRACT)) { - Say("ABSTRACT derived type may not be used here"_err_en_US); - } + CheckForAbstractType(derived->typeSymbol()); // C703 typeSpec.declTypeSpec = spec; } break; @@ -1613,6 +1614,12 @@ void DeclTypeSpecVisitor::MakeNumericType(TypeCategory category, int kind) { SetDeclTypeSpec(context().MakeNumericType(category, kind)); } +void DeclTypeSpecVisitor::CheckForAbstractType(const Symbol &typeSymbol) { + if (typeSymbol.attrs().test(Attr::ABSTRACT)) { + Say("ABSTRACT derived type may not be used here"_err_en_US); + } +} + void DeclTypeSpecVisitor::Post(const parser::DeclarationTypeSpec::ClassStar &) { SetDeclTypeSpec(context().globalScope().MakeClassStarType()); } @@ -3287,11 +3294,29 @@ bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Type &) { return true; } +void DeclarationVisitor::Post(const parser::DeclarationTypeSpec::Type &type) { + const parser::Name &derivedName{std::get(type.derived.t)}; + if (const Symbol * derivedSymbol{derivedName.symbol}) { + CheckForAbstractType(*derivedSymbol); // C706 + } +} + bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Class &) { SetDeclTypeSpecCategory(DeclTypeSpec::Category::ClassDerived); return true; } +void DeclarationVisitor::Post( + const parser::DeclarationTypeSpec::Class &parsedClass) { + const auto &typeName{std::get(parsedClass.derived.t)}; + if (auto spec{ResolveDerivedType(typeName)}; + spec && !IsExtensibleType(&*spec)) { // C705 + SayWithDecl(typeName, *typeName.symbol, + "Non-extensible derived type '%s' may not be used with CLASS" + " keyword"_err_en_US); + } +} + bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Record &) { // TODO return true; @@ -4501,7 +4526,7 @@ ParamValue DeclarationVisitor::GetParamValue( const parser::TypeParamValue &x, common::TypeParamAttr attr) { return std::visit( common::visitors{ - [=](const parser::ScalarIntExpr &x) { + [=](const parser::ScalarIntExpr &x) { // C704 return ParamValue{EvaluateIntExpr(x), attr}; }, [=](const parser::Star &) { return ParamValue::Assumed(attr); }, diff --git a/test/semantics/CMakeLists.txt b/test/semantics/CMakeLists.txt index c69569bc33e3..4873a0f50ebd 100644 --- a/test/semantics/CMakeLists.txt +++ b/test/semantics/CMakeLists.txt @@ -100,6 +100,7 @@ set(ERROR_TESTS resolve67.f90 resolve68.f90 resolve69.f90 + resolve70.f90 stop01.f90 structconst01.f90 structconst02.f90 diff --git a/test/semantics/allocate04.f90 b/test/semantics/allocate04.f90 index 4ccf01413c88..3b7ce25bf00e 100644 --- a/test/semantics/allocate04.f90 +++ b/test/semantics/allocate04.f90 @@ -47,7 +47,7 @@ subroutine C933_b(n) allocate(p3%y) !ERROR: Either type-spec or source-expr must appear in ALLOCATE when allocatable object is of abstract type allocate(p4(2)%y) - !WRONG allocate(Base:: u1) !C703 + !WRONG allocate(Base:: u1) ! No error expected allocate(real:: u1, u2(2)) diff --git a/test/semantics/resolve52.f90 b/test/semantics/resolve52.f90 index 3df7f7fae628..3ee41dd3503f 100644 --- a/test/semantics/resolve52.f90 +++ b/test/semantics/resolve52.f90 @@ -114,6 +114,7 @@ module m7 end type contains subroutine s(x) + !ERROR: Non-extensible derived type 't' may not be used with CLASS keyword class(t) :: x end end diff --git a/test/semantics/resolve69.f90 b/test/semantics/resolve69.f90 index 5950f66e4741..bf08c3a706b0 100644 --- a/test/semantics/resolve69.f90 +++ b/test/semantics/resolve69.f90 @@ -1,8 +1,14 @@ subroutine s1() ! C701 (R701) The type-param-value for a kind type parameter shall be a ! constant expression. + ! ! C702 (R701) A colon shall not be used as a type-param-value except in the ! declaration of an entity that has the POINTER or ALLOCATABLE attribute. + ! + ! C704 (R703) In a declaration-type-spec, every type-param-value that is + ! not a colon or an asterisk shall be a specification expression. + ! Section 10.1.11 defines specification expressions + ! integer, parameter :: constVal = 1 integer :: nonConstVal = 1 !ERROR: Invalid specification expression: reference to local entity 'nonconstval' @@ -20,6 +26,9 @@ subroutine s1() !OK because of the allocatable attribute character(:), allocatable :: colonString3 +!ERROR: Must have INTEGER type, but is REAL(4) + character(3.5) :: badParamValue + type derived(typeKind, typeLen) integer, kind :: typeKind integer, len :: typeLen diff --git a/test/semantics/resolve70.f90 b/test/semantics/resolve70.f90 new file mode 100644 index 000000000000..b771fd0677be --- /dev/null +++ b/test/semantics/resolve70.f90 @@ -0,0 +1,58 @@ +! C703 (R702) The derived-type-spec shall not specify an abstract type (7.5.7). +! This constraint refers to the derived-type-spec in a type-spec. A type-spec +! can appear in an ALLOCATE statement, an ac-spec for an array constructor, and +! in the type specifier of a TYPE GUARD statement +! +! C706 TYPE(derived-type-spec) shall not specify an abstract type (7.5.7). +! This is for a declaration-type-spec +! +! C796 (R756) The derived-type-spec shall not specify an abstract type (7.5.7). +! +! C705 (R703) In a declaration-type-spec that uses the CLASS keyword, +! derived-type-spec shall specify an extensible type (7.5.7). +subroutine s() + type, abstract :: abstractType + end type abstractType + + type, extends(abstractType) :: concreteType + end type concreteType + + ! declaration-type-spec + !ERROR: ABSTRACT derived type may not be used here + type (abstractType), allocatable :: abstractVar + + ! ac-spec for an array constructor + !ERROR: ABSTRACT derived type may not be used here + !ERROR: ABSTRACT derived type may not be used here + type (abstractType), parameter :: abstractArray(*) = (/ abstractType :: /) + + class(*), allocatable :: selector + + ! Structure constructor + !ERROR: ABSTRACT derived type may not be used here + !ERROR: ABSTRACT derived type 'abstracttype' may not be used in a structure constructor + type (abstractType) :: abstractVar1 = abstractType() + + ! Allocate statement + !ERROR: ABSTRACT derived type may not be used here + allocate(abstractType :: abstractVar) + + select type(selector) + ! Type specifier for a type guard statement + !ERROR: ABSTRACT derived type may not be used here + type is (abstractType) + end select +end subroutine s + +subroutine s1() + type :: extensible + end type + type, bind(c) :: inextensible + end type + + ! This one's OK + class(extensible) :: y + + !ERROR: Non-extensible derived type 'inextensible' may not be used with CLASS keyword + class(inextensible) :: x +end subroutine s1 diff --git a/test/semantics/structconst01.f90 b/test/semantics/structconst01.f90 index 5a4bd7bad346..a83286c422ab 100644 --- a/test/semantics/structconst01.f90 +++ b/test/semantics/structconst01.f90 @@ -3,6 +3,8 @@ ! errors meant to be caught by expression semantic analysis, as well as ! acceptable use cases. ! Type parameters are used here to make the parses unambiguous. +! C796 (R756) The derived-type-spec shall not specify an abstract type (7.5.7). +! This refers to a derived-type-spec used in a structure constructor module module1 type :: type1(j) @@ -29,7 +31,7 @@ subroutine type2arg(x) type(type2(0,0)), intent(in) :: x end subroutine type2arg subroutine abstractarg(x) - type(abstract(0)), intent(in) :: x + class(abstract(0)), intent(in) :: x end subroutine abstractarg subroutine errors call type1arg(type1(0)()) From 9c4bba11cf2329575ea9ee446f69e9caa797135c Mon Sep 17 00:00:00 2001 From: peter klausler Date: Tue, 4 Feb 2020 16:55:45 -0800 Subject: [PATCH 14/18] Progress on Fortran I/O runtime Use internal units for internal I/O state Replace use of virtual functions reference_wrapper Internal formatted output to array descriptor Delete dead code Begin list-directed internal output Refactorings and renamings for clarity List-directed external I/O (character) COMPLEX list-directed output Control list items First cut at unformatted I/O More OPEN statement work; rename class to ExternalFileUnit Complete OPEN (exc. for POSITION=), add CLOSE() OPEN(POSITION=) Flush buffers on crash and for terminal output; clean up Documentation Fix backquote in documentation Fix typo in comment Begin implementation of input Refactor binary floating-point properties to a new header, simplify numeric output editing Dodge spurious GCC 7.2 build warning Address review comments --- documentation/FortranForCProgrammers.md | 6 +- documentation/IORuntimeInternals.md | 341 ++++++++++ include/flang/common/real.h | 86 +++ include/flang/decimal/binary-floating-point.h | 39 +- include/flang/decimal/decimal.h | 9 + include/flang/evaluate/common.h | 4 +- include/flang/evaluate/complex.h | 2 +- include/flang/evaluate/integer.h | 2 +- include/flang/evaluate/real.h | 58 +- include/flang/evaluate/type.h | 2 +- lib/decimal/big-radix-floating-point.h | 3 +- lib/decimal/binary-to-decimal.cpp | 24 +- lib/decimal/decimal-to-binary.cpp | 6 +- lib/evaluate/characteristics.cpp | 29 - lib/evaluate/complex.cpp | 2 +- lib/evaluate/real.cpp | 52 +- module/iso_fortran_env.f90 | 3 +- runtime/CMakeLists.txt | 3 + runtime/buffer.h | 12 +- runtime/connection.cpp | 19 + runtime/connection.h | 50 ++ runtime/descriptor.cpp | 5 + runtime/descriptor.h | 1 + runtime/environment.cpp | 4 +- runtime/environment.h | 5 +- runtime/file.cpp | 110 ++-- runtime/file.h | 38 +- runtime/format-implementation.h | 355 ++++++++++ runtime/format.cpp | 390 ++--------- runtime/format.h | 72 +- runtime/internal-unit.cpp | 129 ++++ runtime/internal-unit.h | 46 ++ runtime/io-api.cpp | 614 +++++++++++++++++- runtime/io-api.h | 15 +- runtime/io-error.h | 3 +- runtime/io-stmt.cpp | 402 ++++++++---- runtime/io-stmt.h | 312 +++++++-- runtime/lock.h | 2 +- runtime/main.cpp | 3 +- runtime/memory.cpp | 2 +- runtime/memory.h | 11 +- runtime/numeric-output.cpp | 152 +++++ runtime/numeric-output.h | 324 ++++----- runtime/stop.cpp | 2 +- runtime/terminator.cpp | 21 +- runtime/terminator.h | 12 +- runtime/tools.cpp | 2 +- runtime/tools.h | 3 +- runtime/unit.cpp | 118 +++- runtime/unit.h | 106 ++- test/evaluate/real.cpp | 2 +- test/runtime/external-hello.cpp | 15 +- test/runtime/format.cpp | 29 +- test/runtime/hello.cpp | 48 +- 54 files changed, 2928 insertions(+), 1177 deletions(-) create mode 100644 documentation/IORuntimeInternals.md create mode 100644 include/flang/common/real.h create mode 100644 runtime/connection.cpp create mode 100644 runtime/connection.h create mode 100644 runtime/format-implementation.h create mode 100644 runtime/internal-unit.cpp create mode 100644 runtime/internal-unit.h create mode 100644 runtime/numeric-output.cpp diff --git a/documentation/FortranForCProgrammers.md b/documentation/FortranForCProgrammers.md index db8345477ba5..6038c7ce348a 100644 --- a/documentation/FortranForCProgrammers.md +++ b/documentation/FortranForCProgrammers.md @@ -1,9 +1,9 @@ - Fortran For C Programmers diff --git a/documentation/IORuntimeInternals.md b/documentation/IORuntimeInternals.md new file mode 100644 index 000000000000..70dd0941ac76 --- /dev/null +++ b/documentation/IORuntimeInternals.md @@ -0,0 +1,341 @@ + + +Fortran I/O Runtime Library Internal Design +=========================================== + +This note is meant to be an overview of the design of the *implementation* +of the f18 Fortran compiler's runtime support library for I/O statements. + +The *interface* to the I/O runtime support library is defined in the +C++ header file `runtime/io-api.h`. +This interface was designed to minimize the amount of complexity exposed +to its clients, which are of course the sequences of calls generated by +the compiler to implement each I/O statement. +By keeping this interface as simple as possible, we hope that we have +lowered the risk of future incompatible changes that would necessitate +recompilation of Fortran codes in order to link with later versions of +the runtime library. +As one will see in `io-api.h`, the interface is also directly callable +from C and C++ programs. + +The I/O facilities of the Fortran 2018 language are specified in the +language standard in its clauses 12 (I/O statements) and 13 (`FORMAT`). +It's a complicated collection of language features: + * Files can comprise *records* or *streams*. + * Records can be fixed-length or variable-length. + * Record files can be accessed sequentially or directly (random access). + * Files can be *formatted*, or *unformatted* raw bits. + * `CHARACTER` scalars and arrays can be used as if they were +fixed-length formatted sequential record files. + * Formatted I/O can be under control of a `FORMAT` statement +or `FMT=` specifier, *list-directed* with default formatting chosen +by the runtime, or `NAMELIST`, in which a collection of variables +can be given a name and passed as a group to the runtime library. + * Sequential records of a file can be partially processed by one +or more *non-advancing* I/O statements and eventually completed by +another. + * `FORMAT` strings can manipulate the position in the current +record arbitrarily, causing re-reading or overwriting. + * Floating-point output formatting supports more rounding modes +than the IEEE standard for floating-point arithmetic. + +The Fortran I/O runtime support library is written in C++17, and +uses some C++17 standard library facilities, but it is intended +to not have any link-time dependences on the C++ runtime support +library or any LLVM libraries. +This is important because there are at least two C++ runtime support +libraries, and we don't want Fortran application builders to have to +build multiple versions of their codes; neither do we want to require +them to ship LLVM libraries along with their products. + +Consequently, dynamic memory allocation in the Fortran runtime +uses only C's `malloc()` and `free()` functions, and the few +C++ standard class templates that we instantiate in the library have been +modified with optional template arguments that override their +allocators and deallocators. + +Conversions between the many binary floating-point formats supported +by f18 and their decimal representations are performed with the same +template library of fast conversion algorithms used to interpret +floating-point values in Fortran source programs and to emit them +to module files. + +Overview of Classes +=================== + +A suite of C++ classes and class templates are composed to construct +the Fortran I/O runtime support library. +They (mostly) reside in the C++ namespace `Fortran::runtime::io`. +They are summarized here in a bottom-up order of dependence. + +The header and C++ implementation source file names of these +classes are in the process of being vigorously rearranged and +modified; use `grep` or an IDE to discover these classes in +the source for now. (Sorry!) + +`Terminator` +---------- +A general facility for the entire library, `Terminator` latches a +source program statement location in terms of an unowned pointer to +its source file path name and line number and uses them to construct +a fatal error message if needed. +It is used for both user program errors and internal runtime library crashes. + +`IoErrorHandler` +-------------- +When I/O error conditions arise at runtime that the Fortran program +might have the privilege to handle itself via `ERR=`, `END=`, or +`EOR=` labels and/or by an `IOSTAT=` variable, this subclass of +`Terminator` is used to either latch the error indication or to crash. +It sorts out priorities in the case of multiple errors and determines +the final `IOSTAT=` value at the end of an I/O statement. + +`MutableModes` +------------ +Fortran's formatted I/O statements are affected by a suite of +modes that can be configured by `OPEN` statements, overridden by +data transfer I/O statement control lists, and further overridden +between data items with control edit descriptors in a `FORMAT` string. +These modes are represented with a `MutableModes` instance, and these +are instantiated and copied where one would expect them to be in +order to properly isolate their modifications. +The modes in force at the time each data item is processed constitute +a member of each `DataEdit`. + +`DataEdit` +-------- +Represents a single data edit descriptor from a `FORMAT` statement +or `FMT=` character value, with some hidden extensions to also +support formatting of list-directed transfers. +It holds an instance of `MutableModes`, and also has a repetition +count for when an array appears as a data item in the *io-list*. +For simplicity and efficiency, each data edit descriptor is +encoded in the `DataEdit` as a simple capitalized character +(or two) and some optional field widths. + +`FormatControl<>` +--------------- +This class template traverses a `FORMAT` statement's contents (or `FMT=` +character value) to extract data edit descriptors like `E20.14` to +serve each item in an I/O data transfer statement's *io-list*, +making callbacks to an instance of its class template argument +along the way to effect character literal output and record +positioning. +The Fortran language standard defines formatted I/O as if the `FORMAT` +string were driving the traversal of the data items in the *io-list*, +but our implementation reverses that perspective to allow a more +convenient (for the compiler) I/O runtime support library API design +in which each data item is presented to the library with a distinct +type-dependent call. + +Clients of `FormatControl` instantiations call its `GetNextDataEdit()` +member function to acquire the next data edit descriptor to be processed +from the format, and `FinishOutput()` to flush out any remaining +output strings or record positionings at the end of the *io-list*. + +The `DefaultFormatControlCallbacks` structure summarizes the API +expected by `FormatControl` from its class template actual arguments. + +`OpenFile` +-------- +This class encapsulates all (I hope) the operating system interfaces +used to interact with the host's filesystems for operations on +external units. +Asynchronous I/O interfaces are faked for now with synchronous +operations and deferred results. + +`ConnectionState` +--------------- +An active connection to an external or internal unit maintains +the common parts of its state in this subclass of `ConnectionAttributes`. +The base class holds state that should not change during the +lifetime of the connection, while the subclass maintains state +that may change during I/O statement execution. + +`InternalDescriptorUnit` +---------------------- +When I/O is being performed from/to a Fortran `CHARACTER` array +rather than an external file, this class manages the standard +interoperable descriptor used to access its elements as records. +It has the necessary interfaces to serve as an actual argument +to the `FormatControl` class template. + +`FileFrame<>` +----------- +This CRTP class template isolates all of the complexity involved between +an external unit's `OpenFile` and the buffering requirements +imposed by the capabilities of Fortran `FORMAT` control edit +descriptors that allow repositioning within the current record. +Its interface enables its clients to define a "frame" (my term, +not Fortran's) that is a contiguous range of bytes that are +or may soon be in the file. +This frame is defined as a file offset and a byte size. +The `FileFrame` instance manages an internal circular buffer +with two essential guarantees: + +1. The most recently requested frame is present in the buffer +and contiguous in memory. +1. Any extra data after the frame that may have been read from +the external unit will be preserved, so that it's safe to +read from a socket, pipe, or tape and not have to worry about +repositioning and rereading. + +In end-of-file situations, it's possible that a request to read +a frame may come up short. + +As a CRTP class template, `FileFrame` accesses the raw filesystem +facilities it needs from `*this`. + +`ExternalFileUnit` +---------------- +This class mixes in `ConnectionState`, `OpenFile`, and +`FileFrame` to represent the state of an open +(or soon to be opened) external file descriptor as a Fortran +I/O unit. +It has the contextual APIs required to serve as a template actual +argument to `FormatControl`. +And it contains a `std::variant<>` suitable for holding the +state of the active I/O statement in progress on the unit +(see below). + +`ExternalFileUnit` instances reside in a `Map` that is allocated +as a static variable and indexed by Fortran unit number. +Static member functions `LookUp()`, `LookUpOrCrash()`, and `LookUpOrCreate()` +probe the map to convert Fortran `UNIT=` numbers from I/O statements +into references to active units. + +`IoStatementBase` +--------------- +The subclasses of `IoStatementBase` each encapsulate and maintain +the state of one active Fortran I/O statement across the several +I/O runtime library API function calls it may comprise. +The subclasses handle the distinctions between internal vs. external I/O, +formatted vs. list-directed vs. unformatted I/O, input vs. output, +and so on. + +`IoStatementBase` inherits default `FORMAT` processing callbacks and +an `IoErrorHandler`. +Each of the `IoStatementBase` classes that pertain to formatted I/O +support the contextual callback interfaces needed by `FormatControl`, +overriding the default callbacks of the base class, which crash if +called inappropriately (e.g., if a `CLOSE` statement somehow +passes a data item from an *io-list*). + +The lifetimes of these subclasses' instances each begin with a user +program call to an I/O API routine with a name like `BeginExternalListOutput()` +and persist until `EndIoStatement()` is called. + +To reduce dynamic memory allocation, *external* I/O statements allocate +their per-statement state class instances in space reserved in the +`ExternalFileUnit` instance. +Internal I/O statements currently use dynamic allocation, but +the I/O API supports a means whereby the code generated for the Fortran +program may supply stack space to the I/O runtime support library +for this purpose. + +`IoStatementState` +---------------- +F18's Fortran I/O runtime support library defines and implements an API +that uses a sequence of function calls to implement each Fortran I/O +statement. +The state of each I/O statement in progress is maintained in some +subclass of `IoStatementBase`, as noted above. +The purpose of `IoStatementState` is to provide generic access +to the specific state classes without recourse to C++ `virtual` +functions or function pointers, language features that may not be +available to us in some important execution environments. +`IoStatementState` comprises a `std::variant<>` of wrapped references +to the various possibilities, and uses `std::visit()` to +access them as needed by the I/O API calls that process each specifier +in the I/O *control-list* and each item in the *io-list*. + +Pointers to `IoStatementState` instances are the `Cookie` type returned +in the I/O API for `Begin...` I/O statement calls, passed back for +the *control-list* specifiers and *io-list* data items, and consumed +by the `EndIoStatement()` call at the end of the statement. + +Storage for `IoStatementState` is reserved in `ExternalFileUnit` for +external I/O units, and in the various final subclasses for internal +I/O statement states otherwise. + +Since Fortran permits a `CLOSE` statement to reference a nonexistent +unit, the library has to treat that (expected to be rare) situation +as a weird variation of internal I/O since there's no `ExternalFileUnit` +available to hold its `IoStatementBase` subclass or `IoStatementState`. + +A Narrative Overview Of `PRINT *, 'HELLO, WORLD'` +================================================= +1. When the compiled Fortran program begins execution at the `main()` +entry point exported from its main program, it calls `ProgramStart()` +with its arguments and environment. `ProgramStart()` calls +`ExternalFileUnit::InitializePredefinedUnits()` to create and +initialize Fortran units 5 and 6 and connect them with the +standard input and output file descriptors (respectively). +1. The generated code calls `BeginExternalListOutput()` to +start the sequence of calls that implement the `PRINT` statement. +The default unit code is converted to 6 and passed to +`ExternalFileUnit::LookUpOrCrash()`, which returns a reference to +unit 6's instance. +1. We check that the unit was opened for formatted I/O. +1. `ExternalFileUnit::BeginIoStatement<>()` is called to initialize +an instance of `ExternalListIoStatementState` in the unit, +point to it with an `IoStatementState`, and return a reference to +that object whose address will be the `Cookie` for this statement. +1. The generated code calls `OutputAscii()` with that cookie and the +address and length of the string. +1. `OutputAscii()` confirms that the cookie corresponds to an output +statement and determines that it's list-directed. +1. `ListDirectedStatementState::EmitLeadingSpaceOrAdvance()` +emits the required initial space on the new current output record +by calling `IoStatementState::GetConnectionState()` to locate +the connection state, determining from the record position state +that the space is necessary, and calling `IoStatementState::Emit()` +to cough it out. That call is redirected to `ExternalFileUnit::Emit()`, +which calls `FileFrame::WriteFrame()` to extend +the frame of the current record and then `memcpy()` to fill its +first byte with the space. +1. Back in `OutputAscii()`, the mutable modes and connection state +of the `IoStatementState` are queried to see whether we're in an +`WRITE(UNIT=,FMT=,DELIM=)` statement with a delimited specifier. +If we were, the library would emit the appropriate quote marks, +double up any instances of that character in the text, and split the +text over multiple records if it's long. +1. But we don't have a delimiter, so `OutputAscii()` just carves +up the text into record-sized chunks and emits them. There's just +one chunk for our short `CHARACTER` string value in this example. +It's passed to `IoStatementState::Emit()`, which (as above) is +redirected to `ExternalFileUnit::Emit()`, which interacts with the +frame to extend the frame and `memcpy` data into the buffer. +1. A flag is set in `ListDirectedStatementState` to remember +that the last item emitted in this list-directed output statement +was an undelimited `CHARACTER` value, so that if the next item is +also an undelimited `CHARACTER`, no interposing space will be emitted +between them. +1. `OutputAscii()` return `true` to its caller. +1. The generated code calls `EndIoStatement()`, which is redirected to +`ExternalIoStatementState`'s override of that function. +As this is not a non-advancing I/O statement, `ExternalFileUnit::AdvanceRecord()` +is called to end the record. Since this is a sequential formatted +file, a newline is emitted. +1. If unit 6 is connected to a terminal, the buffer is flushed. +`FileFrame::Flush()` drives `ExternalFileUnit::Write()` +to push out the data in maximal contiguous chunks, dealing with any +short writes that might occur, and collecting I/O errors along the way. +This statement has no `ERR=` label or `IOSTAT=` specifier, so errors +arriving at `IoErrorHandler::SignalErrno()` will cause an immediate +crash. +1. `ExternalIoStatementBase::EndIoStatement()` is called. +It gets the final `IOSTAT=` value from `IoStatementBase::EndIoStatement()`, +tells the `ExternalFileUnit` that no I/O statement remains active, and +returns the I/O status value back to the program. +1. Eventually, the program calls `ProgramEndStatement()`, which +calls `ExternalFileUnit::CloseAll()`, which flushes and closes all +open files. If the standard output were not a terminal, the output +would be written now with the same sequence of calls as above. +1. `exit(EXIT_SUCCESS)`. diff --git a/include/flang/common/real.h b/include/flang/common/real.h new file mode 100644 index 000000000000..d15de663a92b --- /dev/null +++ b/include/flang/common/real.h @@ -0,0 +1,86 @@ +//===-- include/flang/common/real.h -----------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_COMMON_REAL_H_ +#define FORTRAN_COMMON_REAL_H_ + +// Characteristics of IEEE-754 & related binary floating-point numbers. +// The various representations are distinguished by their binary precisions +// (number of explicit significand bits and any implicit MSB in the fraction). + +#include + +namespace Fortran::common { + +// Total representation size in bits for each type +static constexpr int BitsForBinaryPrecision(int binaryPrecision) { + switch (binaryPrecision) { + case 8: return 16; // IEEE single (truncated): 1+8+7 + case 11: return 16; // IEEE half precision: 1+5+10 + case 24: return 32; // IEEE single precision: 1+8+23 + case 53: return 64; // IEEE double precision: 1+11+52 + case 64: return 80; // x87 extended precision: 1+15+64 + case 106: return 128; // "double-double": 2*(1+11+52) + case 112: return 128; // IEEE quad precision: 1+16+111 + default: return -1; + } +} + +// Number of significant decimal digits in the fraction of the +// exact conversion of the least nonzero (subnormal) value +// in each type; i.e., a 128-bit quad value can be formatted +// exactly with FORMAT(E0.22981). +static constexpr int MaxDecimalConversionDigits(int binaryPrecision) { + switch (binaryPrecision) { + case 8: return 93; + case 11: return 17; + case 24: return 105; + case 53: return 751; + case 64: return 11495; + case 106: return 2 * 751; + case 112: return 22981; + default: return -1; + } +} + +template class RealDetails { +private: + // Converts bit widths to whole decimal digits + static constexpr int LogBaseTwoToLogBaseTen(int logb2) { + constexpr std::int64_t LogBaseTenOfTwoTimesTenToThe12th{301029995664}; + constexpr std::int64_t TenToThe12th{1000000000000}; + std::int64_t logb10{ + (logb2 * LogBaseTenOfTwoTimesTenToThe12th) / TenToThe12th}; + return static_cast(logb10); + } + +public: + static constexpr int binaryPrecision{BINARY_PRECISION}; + static constexpr int bits{BitsForBinaryPrecision(binaryPrecision)}; + static constexpr bool isImplicitMSB{binaryPrecision != 64 /*x87*/}; + static constexpr int significandBits{binaryPrecision - isImplicitMSB}; + static constexpr int exponentBits{bits - significandBits - 1 /*sign*/}; + static constexpr int maxExponent{(1 << exponentBits) - 1}; + static constexpr int exponentBias{maxExponent / 2}; + + static constexpr int decimalPrecision{ + LogBaseTwoToLogBaseTen(binaryPrecision - 1)}; + static constexpr int decimalRange{LogBaseTwoToLogBaseTen(exponentBias - 1)}; + + // Number of significant decimal digits in the fraction of the + // exact conversion of the least nonzero subnormal. + static constexpr int maxDecimalConversionDigits{ + MaxDecimalConversionDigits(binaryPrecision)}; + + static_assert(binaryPrecision > 0); + static_assert(exponentBits > 1); + static_assert(exponentBits <= 16); +}; + +} +#endif // FORTRAN_COMMON_REAL_H_ diff --git a/include/flang/decimal/binary-floating-point.h b/include/flang/decimal/binary-floating-point.h index 3da4a336c50e..bf467c5cbb70 100644 --- a/include/flang/decimal/binary-floating-point.h +++ b/include/flang/decimal/binary-floating-point.h @@ -12,6 +12,7 @@ // Access and manipulate the fields of an IEEE-754 binary // floating-point value via a generalized template. +#include "flang/common/real.h" #include "flang/common/uint128.h" #include #include @@ -20,34 +21,24 @@ namespace Fortran::decimal { -static constexpr int BitsForPrecision(int prec) { - switch (prec) { - case 8: return 16; - case 11: return 16; - case 24: return 32; - case 53: return 64; - case 64: return 80; - case 112: return 128; - default: return -1; - } -} +template +struct BinaryFloatingPointNumber + : public common::RealDetails { -// LOG10(2.)*1E12 -static constexpr std::int64_t ScaledLogBaseTenOfTwo{301029995664}; + using Details = common::RealDetails; + using Details::bits; + using Details::decimalPrecision; + using Details::decimalRange; + using Details::exponentBias; + using Details::exponentBits; + using Details::isImplicitMSB; + using Details::maxDecimalConversionDigits; + using Details::maxExponent; + using Details::significandBits; -template struct BinaryFloatingPointNumber { - static constexpr int precision{PRECISION}; - static constexpr int bits{BitsForPrecision(precision)}; using RawType = common::HostUnsignedIntType; static_assert(CHAR_BIT * sizeof(RawType) >= bits); - static constexpr bool implicitMSB{precision != 64 /*x87*/}; - static constexpr int significandBits{precision - implicitMSB}; - static constexpr int exponentBits{bits - 1 - significandBits}; - static constexpr int maxExponent{(1 << exponentBits) - 1}; - static constexpr int exponentBias{maxExponent / 2}; static constexpr RawType significandMask{(RawType{1} << significandBits) - 1}; - static constexpr int RANGE{static_cast( - (exponentBias - 1) * ScaledLogBaseTenOfTwo / 1000000000000)}; constexpr BinaryFloatingPointNumber() {} // zero constexpr BinaryFloatingPointNumber( @@ -76,7 +67,7 @@ template struct BinaryFloatingPointNumber { constexpr RawType Significand() const { return raw & significandMask; } constexpr RawType Fraction() const { RawType sig{Significand()}; - if (implicitMSB && BiasedExponent() > 0) { + if (isImplicitMSB && BiasedExponent() > 0) { sig |= RawType{1} << significandBits; } return sig; diff --git a/include/flang/decimal/decimal.h b/include/flang/decimal/decimal.h index 812d08fe8d09..c9aad161f4dd 100644 --- a/include/flang/decimal/decimal.h +++ b/include/flang/decimal/decimal.h @@ -62,6 +62,15 @@ enum DecimalConversionFlags { AlwaysSign = 2, /* emit leading '+' if not negative */ }; +/* + * When allocating decimal conversion output buffers, use the maximum + * number of significant decimal digits in the representation of the + * least nonzero value, and add this extra space for a sign, a NUL, and + * some extra due to the library working internally in base 10**16 + * and computing its output size in multiples of 16. + */ +#define EXTRA_DECIMAL_CONVERSION_SPACE (1 + 1 + 16 - 1) + #ifdef __cplusplus template ConversionToDecimalResult ConvertToDecimal(char *, size_t, diff --git a/include/flang/evaluate/common.h b/include/flang/evaluate/common.h index f24e93d7cd33..b7ea530e712f 100644 --- a/include/flang/evaluate/common.h +++ b/include/flang/evaluate/common.h @@ -130,9 +130,9 @@ struct Rounding { static constexpr Rounding defaultRounding; #if __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ -constexpr bool IsHostLittleEndian{false}; +constexpr bool isHostLittleEndian{false}; #elif __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ -constexpr bool IsHostLittleEndian{true}; +constexpr bool isHostLittleEndian{true}; #else #error host endianness is not known #endif diff --git a/include/flang/evaluate/complex.h b/include/flang/evaluate/complex.h index 201cbcea60ab..16559e9f0962 100644 --- a/include/flang/evaluate/complex.h +++ b/include/flang/evaluate/complex.h @@ -95,7 +95,7 @@ extern template class Complex, 11>>; extern template class Complex, 8>>; extern template class Complex, 24>>; extern template class Complex, 53>>; -extern template class Complex, 64, false>>; +extern template class Complex, 64>>; extern template class Complex, 112>>; } #endif // FORTRAN_EVALUATE_COMPLEX_H_ diff --git a/include/flang/evaluate/integer.h b/include/flang/evaluate/integer.h index 1bff2bb7b7ca..46478f7e6106 100644 --- a/include/flang/evaluate/integer.h +++ b/include/flang/evaluate/integer.h @@ -49,7 +49,7 @@ namespace Fortran::evaluate::value { // Member functions that correspond to Fortran intrinsic functions are // named accordingly in ALL CAPS so that they can be referenced easily in // the language standard. -template, typename BIGPART = HostUnsignedInt> diff --git a/include/flang/evaluate/real.h b/include/flang/evaluate/real.h index 84e2d556baf3..bcc73cb54b73 100644 --- a/include/flang/evaluate/real.h +++ b/include/flang/evaluate/real.h @@ -12,6 +12,7 @@ #include "formatting.h" #include "integer.h" #include "rounding-bits.h" +#include "flang/common/real.h" #include "flang/evaluate/common.h" #include #include @@ -30,26 +31,25 @@ static constexpr std::int64_t ScaledLogBaseTenOfTwo{301029995664}; // Models IEEE binary floating-point numbers (IEEE 754-2008, // ISO/IEC/IEEE 60559.2011). The first argument to this // class template must be (or look like) an instance of Integer<>; -// the second specifies the number of effective bits in the fraction; -// the third, if true, indicates that the most significant position of the -// fraction is an implicit bit whose value is assumed to be 1 in a finite -// normal number. -template class Real { +// the second specifies the number of effective bits (binary precision) +// in the fraction. +template +class Real : public common::RealDetails { public: using Word = WORD; + static constexpr int binaryPrecision{PREC}; + using Details = common::RealDetails; + using Details::exponentBias; + using Details::exponentBits; + using Details::isImplicitMSB; + using Details::maxExponent; + using Details::significandBits; + static constexpr int bits{Word::bits}; - static constexpr int precision{PREC}; - using Fraction = Integer; // all bits made explicit - static constexpr bool implicitMSB{IMPLICIT_MSB}; - static constexpr int significandBits{precision - implicitMSB}; - static constexpr int exponentBits{bits - significandBits - 1 /*sign*/}; - static_assert(precision > 0); - static_assert(exponentBits > 1); - static_assert(exponentBits <= 16); - static constexpr int maxExponent{(1 << exponentBits) - 1}; - static constexpr int exponentBias{maxExponent / 2}; - - template friend class Real; + static_assert(bits >= Details::bits); + using Fraction = Integer; // all bits made explicit + + template friend class Real; constexpr Real() {} // +0.0 constexpr Real(const Real &) = default; @@ -130,12 +130,13 @@ template class Real { static constexpr Real EPSILON() { Real epsilon; - epsilon.Normalize(false, exponentBias - precision, Fraction::MASKL(1)); + epsilon.Normalize( + false, exponentBias - binaryPrecision, Fraction::MASKL(1)); return epsilon; } static constexpr Real HUGE() { Real huge; - huge.Normalize(false, maxExponent - 1, Fraction::MASKR(precision)); + huge.Normalize(false, maxExponent - 1, Fraction::MASKR(binaryPrecision)); return huge; } static constexpr Real TINY() { @@ -144,11 +145,9 @@ template class Real { return tiny; } - static constexpr int DIGITS{precision}; - static constexpr int PRECISION{static_cast( - (precision - 1) * ScaledLogBaseTenOfTwo / 1000000000000)}; - static constexpr int RANGE{static_cast( - (exponentBias - 1) * ScaledLogBaseTenOfTwo / 1000000000000)}; + static constexpr int DIGITS{binaryPrecision}; + static constexpr int PRECISION{Details::decimalPrecision}; + static constexpr int RANGE{Details::decimalRange}; static constexpr int MAXEXPONENT{maxExponent - 1 - exponentBias}; static constexpr int MINEXPONENT{1 - exponentBias}; @@ -190,7 +189,7 @@ template class Real { } ValueWithRealFlags result; int exponent{exponentBias + absN.bits - leadz - 1}; - int bitsNeeded{absN.bits - (leadz + implicitMSB)}; + int bitsNeeded{absN.bits - (leadz + isImplicitMSB)}; int bitsLost{bitsNeeded - significandBits}; if (bitsLost <= 0) { Fraction fraction{Fraction::ConvertUnsigned(absN).value}; @@ -224,7 +223,8 @@ template class Real { result.flags.set( RealFlag::Overflow, exponent >= exponentBias + result.value.bits); result.flags |= intPart.flags; - int shift{exponent - exponentBias - precision + 1}; // positive -> left + int shift{ + exponent - exponentBias - binaryPrecision + 1}; // positive -> left result.value = result.value.ConvertUnsigned(intPart.value.GetFraction().SHIFTR(-shift)) .value.SHIFTL(shift); @@ -252,7 +252,7 @@ template class Real { } ValueWithRealFlags result; int exponent{exponentBias + x.UnbiasedExponent()}; - int bitsLost{A::precision - precision}; + int bitsLost{A::binaryPrecision - binaryPrecision}; if (exponent < 1) { bitsLost += 1 - exponent; exponent = 1; @@ -282,7 +282,7 @@ template class Real { // Extracts the fraction; any implied bit is made explicit. constexpr Fraction GetFraction() const { Fraction result{Fraction::ConvertUnsigned(word_).value}; - if constexpr (!implicitMSB) { + if constexpr (!isImplicitMSB) { return result; } else { int exponent{Exponent()}; @@ -366,7 +366,7 @@ extern template class Real, 11>; // IEEE half format extern template class Real, 8>; // the "other" half format extern template class Real, 24>; // IEEE single extern template class Real, 53>; // IEEE double -extern template class Real, 64, false>; // 80387 extended precision +extern template class Real, 64>; // 80387 extended precision extern template class Real, 112>; // IEEE quad // N.B. No "double-double" support. } diff --git a/include/flang/evaluate/type.h b/include/flang/evaluate/type.h index 29dde4eeb1a4..a558928d4893 100644 --- a/include/flang/evaluate/type.h +++ b/include/flang/evaluate/type.h @@ -268,7 +268,7 @@ class Type : public TypeBase { template<> class Type : public TypeBase { public: - using Scalar = value::Real, 64, false>; + using Scalar = value::Real, 64>; }; // REAL(KIND=16) is IEEE quad precision (128 bits) diff --git a/lib/decimal/big-radix-floating-point.h b/lib/decimal/big-radix-floating-point.h index 51eb9ec8c5b6..35f0a2e8c31f 100644 --- a/lib/decimal/big-radix-floating-point.h +++ b/lib/decimal/big-radix-floating-point.h @@ -58,7 +58,8 @@ template class BigRadixFloatingPointNumber { // The base-2 logarithm of the least significant bit that can arise // in a subnormal IEEE floating-point number. - static constexpr int minLog2AnyBit{-Real::exponentBias - Real::precision}; + static constexpr int minLog2AnyBit{ + -Real::exponentBias - Real::binaryPrecision}; // The number of Digits needed to represent the smallest subnormal. static constexpr int maxDigits{3 - minLog2AnyBit / log10Radix}; diff --git a/lib/decimal/binary-to-decimal.cpp b/lib/decimal/binary-to-decimal.cpp index ba061856b089..d15aab5ff638 100644 --- a/lib/decimal/binary-to-decimal.cpp +++ b/lib/decimal/binary-to-decimal.cpp @@ -25,7 +25,7 @@ BigRadixFloatingPointNumber::BigRadixFloatingPointNumber( } int twoPow{x.UnbiasedExponent()}; twoPow -= x.bits - 1; - if (!x.implicitMSB) { + if (!x.isImplicitMSB) { ++twoPow; } int lshift{x.exponentBits}; @@ -317,7 +317,7 @@ void BigRadixFloatingPointNumber -ConversionToDecimalResult ConvertToDecimal(char *buffer, size_t size, +ConversionToDecimalResult ConvertToDecimal(char *buffer, std::size_t size, enum DecimalConversionFlags flags, int digits, enum FortranRounding rounding, BinaryFloatingPointNumber x) { if (x.IsNaN()) { @@ -355,34 +355,34 @@ ConversionToDecimalResult ConvertToDecimal(char *buffer, size_t size, } } -template ConversionToDecimalResult ConvertToDecimal<8>(char *, size_t, +template ConversionToDecimalResult ConvertToDecimal<8>(char *, std::size_t, enum DecimalConversionFlags, int, enum FortranRounding, BinaryFloatingPointNumber<8>); -template ConversionToDecimalResult ConvertToDecimal<11>(char *, size_t, +template ConversionToDecimalResult ConvertToDecimal<11>(char *, std::size_t, enum DecimalConversionFlags, int, enum FortranRounding, BinaryFloatingPointNumber<11>); -template ConversionToDecimalResult ConvertToDecimal<24>(char *, size_t, +template ConversionToDecimalResult ConvertToDecimal<24>(char *, std::size_t, enum DecimalConversionFlags, int, enum FortranRounding, BinaryFloatingPointNumber<24>); -template ConversionToDecimalResult ConvertToDecimal<53>(char *, size_t, +template ConversionToDecimalResult ConvertToDecimal<53>(char *, std::size_t, enum DecimalConversionFlags, int, enum FortranRounding, BinaryFloatingPointNumber<53>); -template ConversionToDecimalResult ConvertToDecimal<64>(char *, size_t, +template ConversionToDecimalResult ConvertToDecimal<64>(char *, std::size_t, enum DecimalConversionFlags, int, enum FortranRounding, BinaryFloatingPointNumber<64>); -template ConversionToDecimalResult ConvertToDecimal<112>(char *, size_t, +template ConversionToDecimalResult ConvertToDecimal<112>(char *, std::size_t, enum DecimalConversionFlags, int, enum FortranRounding, BinaryFloatingPointNumber<112>); extern "C" { -ConversionToDecimalResult ConvertFloatToDecimal(char *buffer, size_t size, +ConversionToDecimalResult ConvertFloatToDecimal(char *buffer, std::size_t size, enum DecimalConversionFlags flags, int digits, enum FortranRounding rounding, float x) { return Fortran::decimal::ConvertToDecimal(buffer, size, flags, digits, rounding, Fortran::decimal::BinaryFloatingPointNumber<24>(x)); } -ConversionToDecimalResult ConvertDoubleToDecimal(char *buffer, size_t size, +ConversionToDecimalResult ConvertDoubleToDecimal(char *buffer, std::size_t size, enum DecimalConversionFlags flags, int digits, enum FortranRounding rounding, double x) { return Fortran::decimal::ConvertToDecimal(buffer, size, flags, digits, @@ -390,8 +390,8 @@ ConversionToDecimalResult ConvertDoubleToDecimal(char *buffer, size_t size, } #if __x86_64__ -ConversionToDecimalResult ConvertLongDoubleToDecimal(char *buffer, size_t size, - enum DecimalConversionFlags flags, int digits, +ConversionToDecimalResult ConvertLongDoubleToDecimal(char *buffer, + std::size_t size, enum DecimalConversionFlags flags, int digits, enum FortranRounding rounding, long double x) { return Fortran::decimal::ConvertToDecimal(buffer, size, flags, digits, rounding, Fortran::decimal::BinaryFloatingPointNumber<64>(x)); diff --git a/lib/decimal/decimal-to-binary.cpp b/lib/decimal/decimal-to-binary.cpp index de15833098f5..a07cd570d8c3 100644 --- a/lib/decimal/decimal-to-binary.cpp +++ b/lib/decimal/decimal-to-binary.cpp @@ -122,7 +122,7 @@ bool BigRadixFloatingPointNumber::ParseNumber( // The decimal->binary conversion routine will cope with // returning 0 or Inf, but we must ensure that "expo" didn't // overflow back around to something legal. - expo = 10 * Real::RANGE; + expo = 10 * Real::decimalRange; exponent_ = 0; } p = q; // exponent was valid @@ -256,7 +256,7 @@ ConversionToBinaryResult IntermediateFloat::ToBinary( using Raw = typename Binary::RawType; Raw raw = static_cast(isNegative) << (Binary::bits - 1); raw |= static_cast(expo) << Binary::significandBits; - if constexpr (Binary::implicitMSB) { + if constexpr (Binary::isImplicitMSB) { fraction &= ~topBit; } raw |= fraction; @@ -278,7 +278,7 @@ BigRadixFloatingPointNumber::ConvertToBinary() { // it sits to the *left* of the digits: i.e., x = .D * 10.**E exponent_ += digits_ * log10Radix; // Sanity checks for ridiculous exponents - static constexpr int crazy{2 * Real::RANGE + log10Radix}; + static constexpr int crazy{2 * Real::decimalRange + log10Radix}; if (exponent_ < -crazy) { // underflow to +/-0. return {Real{SignBit()}, Inexact}; } else if (exponent_ > crazy) { // overflow to +/-Inf. diff --git a/lib/evaluate/characteristics.cpp b/lib/evaluate/characteristics.cpp index ac18b5a1730b..3197c46863fa 100644 --- a/lib/evaluate/characteristics.cpp +++ b/lib/evaluate/characteristics.cpp @@ -121,35 +121,6 @@ std::optional TypeAndShape::Characterize( } } -#if 0 // pmk -std::optional TypeAndShape::Characterize( - const Expr &expr, FoldingContext &context) { - if (const auto *symbol{UnwrapWholeSymbolDataRef(expr)}) { - if (const auto *object{ - symbol->detailsIf()}) { - return Characterize(*object); - } else if (const auto *assoc{ - symbol->detailsIf()}) { - return Characterize(*assoc, 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)}) { - if (auto length{chExpr->LEN()}) { - result.set_LEN(Expr{std::move(*length)}); - } - } - } - return result; - } - } - return std::nullopt; -} -#endif // pmk - bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages, const TypeAndShape &that, const char *thisIs, const char *thatIs, bool isElemental) const { diff --git a/lib/evaluate/complex.cpp b/lib/evaluate/complex.cpp index 210fd1fb54c5..a2dca42e4e0b 100644 --- a/lib/evaluate/complex.cpp +++ b/lib/evaluate/complex.cpp @@ -100,6 +100,6 @@ template class Complex, 11>>; template class Complex, 8>>; template class Complex, 24>>; template class Complex, 53>>; -template class Complex, 64, false>>; +template class Complex, 64>>; template class Complex, 112>>; } diff --git a/lib/evaluate/real.cpp b/lib/evaluate/real.cpp index ec9ab1dd4373..29ad1e0aa5a3 100644 --- a/lib/evaluate/real.cpp +++ b/lib/evaluate/real.cpp @@ -15,8 +15,7 @@ namespace Fortran::evaluate::value { -template -Relation Real::Compare(const Real &y) const { +template Relation Real::Compare(const Real &y) const { if (IsNotANumber() || y.IsNotANumber()) { // NaN vs x, x vs NaN return Relation::Unordered; } else if (IsInfinite()) { @@ -53,8 +52,8 @@ Relation Real::Compare(const Real &y) const { } } -template -ValueWithRealFlags> Real::Add( +template +ValueWithRealFlags> Real::Add( const Real &y, Rounding rounding) const { ValueWithRealFlags result; if (IsNotANumber() || y.IsNotANumber()) { @@ -133,8 +132,8 @@ ValueWithRealFlags> Real::Add( return result; } -template -ValueWithRealFlags> Real::Multiply( +template +ValueWithRealFlags> Real::Multiply( const Real &y, Rounding rounding) const { ValueWithRealFlags result; if (IsNotANumber() || y.IsNotANumber()) { @@ -193,8 +192,8 @@ ValueWithRealFlags> Real::Multiply( return result; } -template -ValueWithRealFlags> Real::Divide( +template +ValueWithRealFlags> Real::Divide( const Real &y, Rounding rounding) const { ValueWithRealFlags result; if (IsNotANumber() || y.IsNotANumber()) { @@ -261,8 +260,8 @@ ValueWithRealFlags> Real::Divide( return result; } -template -ValueWithRealFlags> Real::ToWholeNumber( +template +ValueWithRealFlags> Real::ToWholeNumber( common::RoundingMode mode) const { ValueWithRealFlags result{*this}; if (IsNotANumber()) { @@ -271,7 +270,7 @@ ValueWithRealFlags> Real::ToWholeNumber( } else if (IsInfinite()) { result.flags.set(RealFlag::Overflow); } else { - constexpr int noClipExponent{exponentBias + precision - 1}; + constexpr int noClipExponent{exponentBias + binaryPrecision - 1}; if (Exponent() < noClipExponent) { Real adjust; // ABS(EPSILON(adjust)) == 0.5 adjust.Normalize(IsSignBitSet(), noClipExponent, Fraction::MASKL(1)); @@ -287,8 +286,8 @@ ValueWithRealFlags> Real::ToWholeNumber( return result; } -template -RealFlags Real::Normalize(bool negative, int exponent, +template +RealFlags Real::Normalize(bool negative, int exponent, const Fraction &fraction, Rounding rounding, RoundingBits *roundingBits) { int lshift{fraction.LEADZ()}; if (lshift == fraction.bits /* fraction is zero */ && @@ -337,7 +336,7 @@ RealFlags Real::Normalize(bool negative, int exponent, } } } - if constexpr (implicitMSB) { + if constexpr (isImplicitMSB) { word_ = word_.IBCLR(significandBits); } word_ = word_.IOR(Word{exponent}.SHIFTL(significandBits)); @@ -347,8 +346,8 @@ RealFlags Real::Normalize(bool negative, int exponent, return {}; } -template -RealFlags Real::Round( +template +RealFlags Real::Round( Rounding rounding, const RoundingBits &bits, bool multiply) { int origExponent{Exponent()}; RealFlags flags; @@ -363,7 +362,7 @@ RealFlags Real::Round( int newExponent{origExponent}; if (sum.carry) { // The fraction was all ones before rounding; sum.value is now zero - sum.value = sum.value.IBSET(precision - 1); + sum.value = sum.value.IBSET(binaryPrecision - 1); if (++newExponent >= maxExponent) { flags.set(RealFlag::Overflow); // rounded away to an infinity } @@ -388,8 +387,8 @@ RealFlags Real::Round( return flags; } -template -void Real::NormalizeAndRound(ValueWithRealFlags &result, +template +void Real::NormalizeAndRound(ValueWithRealFlags &result, bool isNegative, int exponent, const Fraction &fraction, Rounding rounding, RoundingBits roundingBits, bool multiply) { result.flags |= result.value.Normalize( @@ -423,17 +422,16 @@ inline RealFlags MapFlags(decimal::ConversionResultFlags flags) { return result; } -template -ValueWithRealFlags> Real::Read( +template +ValueWithRealFlags> Real::Read( const char *&p, Rounding rounding) { auto converted{ decimal::ConvertToBinary

(p, MapRoundingMode(rounding.mode))}; - const auto *value{reinterpret_cast *>(&converted.binary)}; + const auto *value{reinterpret_cast *>(&converted.binary)}; return {*value, MapFlags(converted.flags)}; } -template -std::string Real::DumpHexadecimal() const { +template std::string Real::DumpHexadecimal() const { if (IsNotANumber()) { return "NaN 0x"s + word_.Hexadecimal(); } else if (IsNegative()) { @@ -479,8 +477,8 @@ std::string Real::DumpHexadecimal() const { } } -template -std::ostream &Real::AsFortran( +template +std::ostream &Real::AsFortran( std::ostream &o, int kind, bool minimal) const { if (IsNotANumber()) { o << "(0._" << kind << "/0.)"; @@ -521,6 +519,6 @@ template class Real, 11>; template class Real, 8>; template class Real, 24>; template class Real, 53>; -template class Real, 64, false>; +template class Real, 64>; template class Real, 112>; } diff --git a/module/iso_fortran_env.f90 b/module/iso_fortran_env.f90 index 01676cd7f894..957c3ec88131 100644 --- a/module/iso_fortran_env.f90 +++ b/module/iso_fortran_env.f90 @@ -128,7 +128,8 @@ module iso_fortran_env integer, parameter :: current_team = -1, initial_team = -2, parent_team = -3 - integer, parameter :: input_unit = 5, output_unit = 6, error_unit = 0 + integer, parameter :: input_unit = 5, output_unit = 6 + integer, parameter :: error_unit = output_unit integer, parameter :: iostat_end = -1, iostat_eor = -2 integer, parameter :: iostat_inquire_internal_unit = -1 diff --git a/runtime/CMakeLists.txt b/runtime/CMakeLists.txt index 4c1ecf0be736..571775ce8984 100644 --- a/runtime/CMakeLists.txt +++ b/runtime/CMakeLists.txt @@ -9,16 +9,19 @@ add_library(FortranRuntime ISO_Fortran_binding.cpp buffer.cpp + connection.cpp derived-type.cpp descriptor.cpp environment.cpp file.cpp format.cpp + internal-unit.cpp io-api.cpp io-error.cpp io-stmt.cpp main.cpp memory.cpp + numeric-output.cpp stop.cpp terminator.cpp tools.cpp diff --git a/runtime/buffer.h b/runtime/buffer.h index 57c740fabfa8..a956a3bbae1d 100644 --- a/runtime/buffer.h +++ b/runtime/buffer.h @@ -97,14 +97,13 @@ template class FileFrame { } dirty_ = true; frame_ = at - fileOffset_; - length_ = std::max(length_, static_cast(frame_ + bytes)); + length_ = std::max(length_, frame_ + bytes); } void Flush(IoErrorHandler &handler) { if (dirty_) { while (length_ > 0) { - std::size_t chunk{std::min(static_cast(length_), - static_cast(size_ - start_))}; + std::size_t chunk{std::min(length_, size_ - start_)}; std::size_t put{ Store().Write(fileOffset_, buffer_ + start_, chunk, handler)}; length_ -= put; @@ -121,15 +120,14 @@ template class FileFrame { private: STORE &Store() { return static_cast(*this); } - void Reallocate(std::size_t bytes, Terminator &terminator) { + void Reallocate(std::size_t bytes, const Terminator &terminator) { if (bytes > size_) { char *old{buffer_}; auto oldSize{size_}; size_ = std::max(bytes, minBuffer); buffer_ = reinterpret_cast(AllocateMemoryOrCrash(terminator, size_)); - auto chunk{ - std::min(length_, static_cast(oldSize - start_))}; + auto chunk{std::min(length_, oldSize - start_)}; std::memcpy(buffer_, old + start_, chunk); start_ = 0; std::memcpy(buffer_ + chunk, old, length_ - chunk); @@ -143,7 +141,7 @@ template class FileFrame { dirty_ = false; } - void DiscardLeadingBytes(std::size_t n, Terminator &terminator) { + void DiscardLeadingBytes(std::size_t n, const Terminator &terminator) { RUNTIME_CHECK(terminator, length_ >= n); length_ -= n; if (length_ == 0) { diff --git a/runtime/connection.cpp b/runtime/connection.cpp new file mode 100644 index 000000000000..ff15a40819ab --- /dev/null +++ b/runtime/connection.cpp @@ -0,0 +1,19 @@ +//===-- runtime/connection.cpp ----------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#include "connection.h" +#include "environment.h" + +namespace Fortran::runtime::io { + +std::size_t ConnectionState::RemainingSpaceInRecord() const { + return recordLength.value_or( + executionEnvironment.listDirectedOutputLineLengthLimit) - + positionInRecord; +} +} diff --git a/runtime/connection.h b/runtime/connection.h new file mode 100644 index 000000000000..85372dfa610d --- /dev/null +++ b/runtime/connection.h @@ -0,0 +1,50 @@ +//===-- runtime/connection.h ------------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +// Fortran I/O connection state (internal & external) + +#ifndef FORTRAN_RUNTIME_IO_CONNECTION_H_ +#define FORTRAN_RUNTIME_IO_CONNECTION_H_ + +#include "format.h" +#include +#include + +namespace Fortran::runtime::io { + +enum class Access { Sequential, Direct, Stream }; + +inline bool IsRecordFile(Access a) { return a != Access::Stream; } + +// These characteristics of a connection are immutable after being +// established in an OPEN statement. +struct ConnectionAttributes { + Access access{Access::Sequential}; // ACCESS='SEQUENTIAL', 'DIRECT', 'STREAM' + std::optional recordLength; // RECL= when fixed-length + bool isUnformatted{false}; // FORM='UNFORMATTED' + bool isUTF8{false}; // ENCODING='UTF-8' +}; + +struct ConnectionState : public ConnectionAttributes { + std::size_t RemainingSpaceInRecord() const; + // Positions in a record file (sequential or direct, but not stream) + std::int64_t recordOffsetInFile{0}; + std::int64_t currentRecordNumber{1}; // 1 is first + std::int64_t positionInRecord{0}; // offset in current record + std::int64_t furthestPositionInRecord{0}; // max(positionInRecord) + bool nonAdvancing{false}; // ADVANCE='NO' + // Set at end of non-advancing I/O data transfer + std::optional leftTabLimit; // offset in current record + // currentRecordNumber value captured after ENDFILE/REWIND/BACKSPACE statement + // on a sequential access file + std::optional endfileRecordNumber; + // Mutable modes set at OPEN() that can be overridden in READ/WRITE & FORMAT + MutableModes modes; // BLANK=, DECIMAL=, SIGN=, ROUND=, PAD=, DELIM=, kP +}; +} +#endif // FORTRAN_RUNTIME_IO_CONNECTION_H_ diff --git a/runtime/descriptor.cpp b/runtime/descriptor.cpp index c8895dd6d246..ca065246d522 100644 --- a/runtime/descriptor.cpp +++ b/runtime/descriptor.cpp @@ -10,9 +10,14 @@ #include "flang/common/idioms.h" #include #include +#include namespace Fortran::runtime { +Descriptor::Descriptor(const Descriptor &that) { + std::memcpy(this, &that, that.SizeInBytes()); +} + Descriptor::~Descriptor() { if (raw_.attribute != CFI_attribute_pointer) { Deallocate(); diff --git a/runtime/descriptor.h b/runtime/descriptor.h index 3a4f2ce3a29c..bb8a428c83ec 100644 --- a/runtime/descriptor.h +++ b/runtime/descriptor.h @@ -125,6 +125,7 @@ class Descriptor { raw_.base_addr = nullptr; raw_.f18Addendum = false; } + Descriptor(const Descriptor &); ~Descriptor(); diff --git a/runtime/environment.cpp b/runtime/environment.cpp index 5ce55ab47459..735312b9f57c 100644 --- a/runtime/environment.cpp +++ b/runtime/environment.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "environment.h" +#include #include #include @@ -19,7 +20,8 @@ void ExecutionEnvironment::Configure( argv = av; envp = env; listDirectedOutputLineLengthLimit = 79; // PGI default - defaultOutputRoundingMode = common::RoundingMode::TiesToEven; // RP=RN + defaultOutputRoundingMode = + decimal::FortranRounding::RoundNearest; // RP(==RN) if (auto *x{std::getenv("FORT_FMT_RECL")}) { char *end; diff --git a/runtime/environment.h b/runtime/environment.h index 25a98959b741..056a13829b2a 100644 --- a/runtime/environment.h +++ b/runtime/environment.h @@ -9,7 +9,7 @@ #ifndef FORTRAN_RUNTIME_ENVIRONMENT_H_ #define FORTRAN_RUNTIME_ENVIRONMENT_H_ -#include "flang/common/Fortran.h" +#include "flang/decimal/decimal.h" namespace Fortran::runtime { struct ExecutionEnvironment { @@ -19,8 +19,9 @@ struct ExecutionEnvironment { const char **argv; const char **envp; int listDirectedOutputLineLengthLimit; - common::RoundingMode defaultOutputRoundingMode; + enum decimal::FortranRounding defaultOutputRoundingMode; }; extern ExecutionEnvironment executionEnvironment; } + #endif // FORTRAN_RUNTIME_ENVIRONMENT_H_ diff --git a/runtime/file.cpp b/runtime/file.cpp index f9c18c741734..9ee4ae3c4318 100644 --- a/runtime/file.cpp +++ b/runtime/file.cpp @@ -9,7 +9,6 @@ #include "file.h" #include "magic-numbers.h" #include "memory.h" -#include "tools.h" #include #include #include @@ -18,49 +17,22 @@ namespace Fortran::runtime::io { -void OpenFile::Open(const char *path, std::size_t pathLength, - const char *status, std::size_t statusLength, const char *action, - std::size_t actionLength, IoErrorHandler &handler) { - CriticalSection criticalSection{lock_}; - RUNTIME_CHECK(handler, fd_ < 0); // TODO handle re-openings - int flags{0}; - static const char *actions[]{"READ", "WRITE", "READWRITE", nullptr}; - switch (IdentifyValue(action, actionLength, actions)) { - case 0: - flags = O_RDONLY; - mayRead_ = true; - mayWrite_ = false; - break; - case 1: - flags = O_WRONLY; - mayRead_ = false; - mayWrite_ = true; - break; - case 2: - mayRead_ = true; - mayWrite_ = true; - flags = O_RDWR; - break; - default: - handler.Crash( - "Invalid ACTION='%.*s'", action, static_cast(actionLength)); - } - if (!status) { - status = "UNKNOWN", statusLength = 7; - } - static const char *statuses[]{ - "OLD", "NEW", "SCRATCH", "REPLACE", "UNKNOWN", nullptr}; - switch (IdentifyValue(status, statusLength, statuses)) { - case 0: // STATUS='OLD' - if (!path && fd_ >= 0) { - // TODO: Update OpenFile in situ; can ACTION be changed? +void OpenFile::set_path(OwningPtr &&path, std::size_t bytes) { + path_ = std::move(path); + pathLength_ = bytes; +} + +void OpenFile::Open( + OpenStatus status, Position position, IoErrorHandler &handler) { + int flags{mayRead_ ? mayWrite_ ? O_RDWR : O_RDONLY : O_WRONLY}; + switch (status) { + case OpenStatus::Old: + if (fd_ >= 0) { return; } break; - case 1: // STATUS='NEW' - flags |= O_CREAT | O_EXCL; - break; - case 2: // STATUS='SCRATCH' + case OpenStatus::New: flags |= O_CREAT | O_EXCL; break; + case OpenStatus::Scratch: if (path_.get()) { handler.Crash("FILE= must not appear with STATUS='SCRATCH'"); path_.reset(); @@ -74,27 +46,22 @@ void OpenFile::Open(const char *path, std::size_t pathLength, ::unlink(path); } return; - case 3: // STATUS='REPLACE' - flags |= O_CREAT | O_TRUNC; - break; - case 4: // STATUS='UNKNOWN' + case OpenStatus::Replace: flags |= O_CREAT | O_TRUNC; break; + case OpenStatus::Unknown: if (fd_ >= 0) { return; } flags |= O_CREAT; break; - default: - handler.Crash( - "Invalid STATUS='%.*s'", status, static_cast(statusLength)); } // If we reach this point, we're opening a new file if (fd_ >= 0) { - if (::close(fd_) != 0) { + if (fd_ <= 2) { + // don't actually close a standard file descriptor, we might need it + } else if (::close(fd_) != 0) { handler.SignalErrno(); } } - path_ = SaveDefaultCharacter(path, pathLength, handler); - pathLength_ = pathLength; if (!path_.get()) { handler.Crash( "FILE= is required unless STATUS='OLD' and unit is connected"); @@ -105,6 +72,10 @@ void OpenFile::Open(const char *path, std::size_t pathLength, } pending_.reset(); knownSize_.reset(); + if (position == Position::Append && !RawSeekToEnd()) { + handler.SignalErrno(); + } + isTerminal_ = ::isatty(fd_) == 1; } void OpenFile::Predefine(int fd) { @@ -118,25 +89,18 @@ void OpenFile::Predefine(int fd) { pending_.reset(); } -void OpenFile::Close( - const char *status, std::size_t statusLength, IoErrorHandler &handler) { +void OpenFile::Close(CloseStatus status, IoErrorHandler &handler) { CriticalSection criticalSection{lock_}; CheckOpen(handler); pending_.reset(); knownSize_.reset(); - static const char *statuses[]{"KEEP", "DELETE", nullptr}; - switch (IdentifyValue(status, statusLength, statuses)) { - case 0: break; - case 1: + switch (status) { + case CloseStatus::Keep: break; + case CloseStatus::Delete: if (path_.get()) { ::unlink(path_.get()); } break; - default: - if (status) { - handler.Crash( - "Invalid STATUS='%.*s'", status, static_cast(statusLength)); - } } path_.reset(); if (fd_ >= 0) { @@ -319,7 +283,7 @@ void OpenFile::WaitAll(IoErrorHandler &handler) { } } -void OpenFile::CheckOpen(Terminator &terminator) { +void OpenFile::CheckOpen(const Terminator &terminator) { RUNTIME_CHECK(terminator, fd_ >= 0); } @@ -337,13 +301,27 @@ bool OpenFile::Seek(FileOffset at, IoErrorHandler &handler) { bool OpenFile::RawSeek(FileOffset at) { #ifdef _LARGEFILE64_SOURCE - return ::lseek64(fd_, at, SEEK_SET) == 0; + return ::lseek64(fd_, at, SEEK_SET) == at; #else - return ::lseek(fd_, at, SEEK_SET) == 0; + return ::lseek(fd_, at, SEEK_SET) == at; #endif } -int OpenFile::PendingResult(Terminator &terminator, int iostat) { +bool OpenFile::RawSeekToEnd() { +#ifdef _LARGEFILE64_SOURCE + std::int64_t at{::lseek64(fd_, 0, SEEK_END)}; +#else + std::int64_t at{::lseek(fd_, 0, SEEK_END)}; +#endif + if (at >= 0) { + knownSize_ = at; + return true; + } else { + return false; + } +} + +int OpenFile::PendingResult(const Terminator &terminator, int iostat) { int id{nextId_++}; pending_.reset(&New{}(terminator, id, iostat, std::move(pending_))); return id; diff --git a/runtime/file.h b/runtime/file.h index d5e521756653..9ed1c250364a 100644 --- a/runtime/file.h +++ b/runtime/file.h @@ -19,25 +19,33 @@ namespace Fortran::runtime::io { +enum class OpenStatus { Old, New, Scratch, Replace, Unknown }; +enum class CloseStatus { Keep, Delete }; +enum class Position { AsIs, Rewind, Append }; + class OpenFile { public: using FileOffset = std::int64_t; - FileOffset position() const { return position_; } - - void Open(const char *path, std::size_t pathLength, const char *status, - std::size_t statusLength, const char *action, std::size_t actionLength, - IoErrorHandler &); - void Predefine(int fd); - void Close(const char *action, std::size_t actionLength, IoErrorHandler &); - - int fd() const { return fd_; } + Lock &lock() { return lock_; } + const char *path() const { return path_.get(); } + void set_path(OwningPtr &&, std::size_t bytes); + std::size_t pathLength() const { return pathLength_; } bool mayRead() const { return mayRead_; } - bool mayWrite() const { return mayWrite_; } - bool mayPosition() const { return mayPosition_; } void set_mayRead(bool yes) { mayRead_ = yes; } + bool mayWrite() const { return mayWrite_; } void set_mayWrite(bool yes) { mayWrite_ = yes; } + bool mayAsynchronous() const { return mayAsynchronous_; } + void set_mayAsynchronous(bool yes) { mayAsynchronous_ = yes; } + bool mayPosition() const { return mayPosition_; } void set_mayPosition(bool yes) { mayPosition_ = yes; } + FileOffset position() const { return position_; } + bool isTerminal() const { return isTerminal_; } + + bool IsOpen() const { return fd_ >= 0; } + void Open(OpenStatus, Position, IoErrorHandler &); + void Predefine(int fd); + void Close(CloseStatus, IoErrorHandler &); // Reads data into memory; returns amount acquired. Synchronous. // Partial reads (less than minBytes) signify end-of-file. If the @@ -69,10 +77,11 @@ class OpenFile { }; // lock_ must be held for these - void CheckOpen(Terminator &); + void CheckOpen(const Terminator &); bool Seek(FileOffset, IoErrorHandler &); bool RawSeek(FileOffset); - int PendingResult(Terminator &, int); + bool RawSeekToEnd(); + int PendingResult(const Terminator &, int); Lock lock_; int fd_{-1}; @@ -81,8 +90,11 @@ class OpenFile { bool mayRead_{false}; bool mayWrite_{false}; bool mayPosition_{false}; + bool mayAsynchronous_{false}; FileOffset position_{0}; std::optional knownSize_; + bool isTerminal_{false}; + int nextId_; OwningPtr pending_; }; diff --git a/runtime/format-implementation.h b/runtime/format-implementation.h new file mode 100644 index 000000000000..cb5fc2dfd8b5 --- /dev/null +++ b/runtime/format-implementation.h @@ -0,0 +1,355 @@ +//===-- runtime/format-implementation.h -------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +// Implements out-of-line member functions of template class FormatControl + +#ifndef FORTRAN_RUNTIME_FORMAT_IMPLEMENTATION_H_ +#define FORTRAN_RUNTIME_FORMAT_IMPLEMENTATION_H_ + +#include "format.h" +#include "io-stmt.h" +#include "main.h" +#include "flang/common/format.h" +#include "flang/decimal/decimal.h" +#include + +namespace Fortran::runtime::io { + +template +FormatControl::FormatControl(const Terminator &terminator, + const CharType *format, std::size_t formatLength, int maxHeight) + : maxHeight_{static_cast(maxHeight)}, format_{format}, + formatLength_{static_cast(formatLength)} { + if (maxHeight != maxHeight_) { + terminator.Crash("internal Fortran runtime error: maxHeight %d", maxHeight); + } + if (formatLength != static_cast(formatLength_)) { + terminator.Crash( + "internal Fortran runtime error: formatLength %zd", formatLength); + } + stack_[0].start = offset_; + stack_[0].remaining = Iteration::unlimited; // 13.4(8) +} + +template +int FormatControl::GetMaxParenthesisNesting( + const Terminator &terminator, const CharType *format, + std::size_t formatLength) { + using Validator = common::FormatValidator; + typename Validator::Reporter reporter{ + [&](const common::FormatMessage &message) { + terminator.Crash(message.text, message.arg); + return false; // crashes on error above + }}; + Validator validator{format, formatLength, reporter}; + validator.Check(); + return validator.maxNesting(); +} + +template +int FormatControl::GetIntField( + const Terminator &terminator, CharType firstCh) { + CharType ch{firstCh ? firstCh : PeekNext()}; + if (ch != '-' && ch != '+' && (ch < '0' || ch > '9')) { + terminator.Crash( + "Invalid FORMAT: integer expected at '%c'", static_cast(ch)); + } + int result{0}; + bool negate{ch == '-'}; + if (negate) { + firstCh = '\0'; + ch = PeekNext(); + } + while (ch >= '0' && ch <= '9') { + if (result > + std::numeric_limits::max() / 10 - (static_cast(ch) - '0')) { + terminator.Crash("FORMAT integer field out of range"); + } + result = 10 * result + ch - '0'; + if (firstCh) { + firstCh = '\0'; + } else { + ++offset_; + } + ch = PeekNext(); + } + if (negate && (result *= -1) > 0) { + terminator.Crash("FORMAT integer field out of range"); + } + return result; +} + +template +static void HandleControl(CONTEXT &context, char ch, char next, int n) { + MutableModes &modes{context.mutableModes()}; + switch (ch) { + case 'B': + if (next == 'Z') { + modes.editingFlags |= blankZero; + return; + } + if (next == 'N') { + modes.editingFlags &= ~blankZero; + return; + } + break; + case 'D': + if (next == 'C') { + modes.editingFlags |= decimalComma; + return; + } + if (next == 'P') { + modes.editingFlags &= ~decimalComma; + return; + } + break; + case 'P': + if (!next) { + modes.scale = n; // kP - decimal scaling by 10**k + return; + } + break; + case 'R': + switch (next) { + case 'N': modes.round = decimal::RoundNearest; return; + case 'Z': modes.round = decimal::RoundToZero; return; + case 'U': modes.round = decimal::RoundUp; return; + case 'D': modes.round = decimal::RoundDown; return; + case 'C': modes.round = decimal::RoundCompatible; return; + case 'P': + modes.round = executionEnvironment.defaultOutputRoundingMode; + return; + default: break; + } + break; + case 'X': + if (!next) { + context.HandleRelativePosition(n); + return; + } + break; + case 'S': + if (next == 'P') { + modes.editingFlags |= signPlus; + return; + } + if (!next || next == 'S') { + modes.editingFlags &= ~signPlus; + return; + } + break; + case 'T': { + if (!next) { // Tn + context.HandleAbsolutePosition(n - 1); // convert 1-based to 0-based + return; + } + if (next == 'L' || next == 'R') { // TLn & TRn + context.HandleRelativePosition(next == 'L' ? -n : n); + return; + } + } break; + default: break; + } + if (next) { + context.Crash("Unknown '%c%c' edit descriptor in FORMAT", ch, next); + } else { + context.Crash("Unknown '%c' edit descriptor in FORMAT", ch); + } +} + +// Locates the next data edit descriptor in the format. +// Handles all repetition counts and control edit descriptors. +// Generally assumes that the format string has survived the common +// format validator gauntlet. +template +int FormatControl::CueUpNextDataEdit(Context &context, bool stop) { + int unlimitedLoopCheck{-1}; + while (true) { + std::optional repeat; + bool unlimited{false}; + CharType ch{Capitalize(GetNextChar(context))}; + while (ch == ',' || ch == ':') { + // Skip commas, and don't complain if they're missing; the format + // validator does that. + if (stop && ch == ':') { + return 0; + } + ch = Capitalize(GetNextChar(context)); + } + if (ch == '-' || ch == '+' || (ch >= '0' && ch <= '9')) { + repeat = GetIntField(context, ch); + ch = GetNextChar(context); + } else if (ch == '*') { + unlimited = true; + ch = GetNextChar(context); + if (ch != '(') { + context.Crash("Invalid FORMAT: '*' may appear only before '('"); + } + } + if (ch == '(') { + if (height_ >= maxHeight_) { + context.Crash("FORMAT stack overflow: too many nested parentheses"); + } + stack_[height_].start = offset_ - 1; // the '(' + if (unlimited || height_ == 0) { + stack_[height_].remaining = Iteration::unlimited; + unlimitedLoopCheck = offset_ - 1; + } else if (repeat) { + if (*repeat <= 0) { + *repeat = 1; // error recovery + } + stack_[height_].remaining = *repeat - 1; + } else { + stack_[height_].remaining = 0; + } + ++height_; + } else if (height_ == 0) { + context.Crash("FORMAT lacks initial '('"); + } else if (ch == ')') { + if (height_ == 1) { + if (stop) { + return 0; // end of FORMAT and no data items remain + } + context.AdvanceRecord(); // implied / before rightmost ) + } + if (stack_[height_ - 1].remaining == Iteration::unlimited) { + offset_ = stack_[height_ - 1].start + 1; + if (offset_ == unlimitedLoopCheck) { + context.Crash( + "Unlimited repetition in FORMAT lacks data edit descriptors"); + } + } else if (stack_[height_ - 1].remaining-- > 0) { + offset_ = stack_[height_ - 1].start + 1; + } else { + --height_; + } + } else if (ch == '\'' || ch == '"') { + // Quoted 'character literal' + CharType quote{ch}; + auto start{offset_}; + while (offset_ < formatLength_ && format_[offset_] != quote) { + ++offset_; + } + if (offset_ >= formatLength_) { + context.Crash("FORMAT missing closing quote on character literal"); + } + ++offset_; + std::size_t chars{ + static_cast(&format_[offset_] - &format_[start])}; + if (PeekNext() == quote) { + // subtle: handle doubled quote character in a literal by including + // the first in the output, then treating the second as the start + // of another character literal. + } else { + --chars; + } + context.Emit(format_ + start, chars); + } else if (ch == 'H') { + // 9HHOLLERITH + if (!repeat || *repeat < 1 || offset_ + *repeat > formatLength_) { + context.Crash("Invalid width on Hollerith in FORMAT"); + } + context.Emit(format_ + offset_, static_cast(*repeat)); + offset_ += *repeat; + } else if (ch >= 'A' && ch <= 'Z') { + int start{offset_ - 1}; + CharType next{Capitalize(PeekNext())}; + if (next >= 'A' && next <= 'Z') { + ++offset_; + } else { + next = '\0'; + } + if (ch == 'E' || + (!next && + (ch == 'A' || ch == 'I' || ch == 'B' || ch == 'O' || ch == 'Z' || + ch == 'F' || ch == 'D' || ch == 'G' || ch == 'L'))) { + // Data edit descriptor found + offset_ = start; + return repeat && *repeat > 0 ? *repeat : 1; + } else { + // Control edit descriptor + if (ch == 'T') { // Tn, TLn, TRn + repeat = GetIntField(context); + } + HandleControl(context, static_cast(ch), static_cast(next), + repeat ? *repeat : 1); + } + } else if (ch == '/') { + context.AdvanceRecord(repeat && *repeat > 0 ? *repeat : 1); + } else { + context.Crash("Invalid character '%c' in FORMAT", static_cast(ch)); + } + } +} + +template +DataEdit FormatControl::GetNextDataEdit( + Context &context, int maxRepeat) { + + // TODO: DT editing + + // Return the next data edit descriptor + int repeat{CueUpNextDataEdit(context)}; + auto start{offset_}; + DataEdit edit; + edit.descriptor = static_cast(Capitalize(GetNextChar(context))); + if (edit.descriptor == 'E') { + edit.variation = static_cast(Capitalize(PeekNext())); + if (edit.variation >= 'A' && edit.variation <= 'Z') { + ++offset_; + } + } + + if (edit.descriptor == 'A') { // width is optional for A[w] + auto ch{PeekNext()}; + if (ch >= '0' && ch <= '9') { + edit.width = GetIntField(context); + } + } else { + edit.width = GetIntField(context); + } + edit.modes = context.mutableModes(); + if (PeekNext() == '.') { + ++offset_; + edit.digits = GetIntField(context); + CharType ch{PeekNext()}; + if (ch == 'e' || ch == 'E' || ch == 'd' || ch == 'D') { + ++offset_; + edit.expoDigits = GetIntField(context); + } + } + + // Handle repeated nonparenthesized edit descriptors + if (repeat > 1) { + stack_[height_].start = start; // after repeat count + stack_[height_].remaining = repeat; // full count + ++height_; + } + edit.repeat = 1; + if (height_ > 1) { + int start{stack_[height_ - 1].start}; + if (format_[start] != '(') { + if (stack_[height_ - 1].remaining > maxRepeat) { + edit.repeat = maxRepeat; + stack_[height_ - 1].remaining -= maxRepeat; + offset_ = start; // repeat same edit descriptor next time + } else { + edit.repeat = stack_[height_ - 1].remaining; + --height_; + } + } + } + return edit; +} + +template +void FormatControl::FinishOutput(Context &context) { + CueUpNextDataEdit(context, true /* stop at colon or end of FORMAT */); +} +} +#endif // FORTRAN_RUNTIME_FORMAT_IMPLEMENTATION_H_ diff --git a/runtime/format.cpp b/runtime/format.cpp index f31139ebb5ac..91a6b6749514 100644 --- a/runtime/format.cpp +++ b/runtime/format.cpp @@ -6,356 +6,48 @@ // //===----------------------------------------------------------------------===// -#include "format.h" -#include "io-stmt.h" -#include "main.h" -#include "flang/common/format.h" -#include "flang/decimal/decimal.h" -#include +#include "format-implementation.h" namespace Fortran::runtime::io { -template -FormatControl::FormatControl(Terminator &terminator, const CHAR *format, - std::size_t formatLength, int maxHeight) - : maxHeight_{static_cast(maxHeight)}, format_{format}, - formatLength_{static_cast(formatLength)} { - if (maxHeight != maxHeight_) { - terminator.Crash("internal Fortran runtime error: maxHeight %d", maxHeight); - } - if (formatLength != static_cast(formatLength_)) { - terminator.Crash( - "internal Fortran runtime error: formatLength %zd", formatLength); - } - stack_[0].start = offset_; - stack_[0].remaining = Iteration::unlimited; // 13.4(8) -} - -template -int FormatControl::GetMaxParenthesisNesting( - Terminator &terminator, const CHAR *format, std::size_t formatLength) { - using Validator = common::FormatValidator; - typename Validator::Reporter reporter{ - [&](const common::FormatMessage &message) { - terminator.Crash(message.text, message.arg); - return false; // crashes on error above - }}; - Validator validator{format, formatLength, reporter}; - validator.Check(); - return validator.maxNesting(); -} - -template -int FormatControl::GetIntField(Terminator &terminator, CHAR firstCh) { - CHAR ch{firstCh ? firstCh : PeekNext()}; - if (ch != '-' && ch != '+' && (ch < '0' || ch > '9')) { - terminator.Crash( - "Invalid FORMAT: integer expected at '%c'", static_cast(ch)); - } - int result{0}; - bool negate{ch == '-'}; - if (negate) { - firstCh = '\0'; - ch = PeekNext(); - } - while (ch >= '0' && ch <= '9') { - if (result > - std::numeric_limits::max() / 10 - (static_cast(ch) - '0')) { - terminator.Crash("FORMAT integer field out of range"); - } - result = 10 * result + ch - '0'; - if (firstCh) { - firstCh = '\0'; - } else { - ++offset_; - } - ch = PeekNext(); - } - if (negate && (result *= -1) > 0) { - terminator.Crash("FORMAT integer field out of range"); - } - return result; -} - -static void HandleControl(FormatContext &context, char ch, char next, int n) { - MutableModes &modes{context.mutableModes()}; - switch (ch) { - case 'B': - if (next == 'Z') { - modes.editingFlags |= blankZero; - return; - } - if (next == 'N') { - modes.editingFlags &= ~blankZero; - return; - } - break; - case 'D': - if (next == 'C') { - modes.editingFlags |= decimalComma; - return; - } - if (next == 'P') { - modes.editingFlags &= ~decimalComma; - return; - } - break; - case 'P': - if (!next) { - modes.scale = n; // kP - decimal scaling by 10**k - return; - } - break; - case 'R': - switch (next) { - case 'N': modes.roundingMode = common::RoundingMode::TiesToEven; return; - case 'Z': modes.roundingMode = common::RoundingMode::ToZero; return; - case 'U': modes.roundingMode = common::RoundingMode::Up; return; - case 'D': modes.roundingMode = common::RoundingMode::Down; return; - case 'C': - modes.roundingMode = common::RoundingMode::TiesAwayFromZero; - return; - case 'P': - modes.roundingMode = executionEnvironment.defaultOutputRoundingMode; - return; - default: break; - } - break; - case 'X': - if (!next) { - context.HandleRelativePosition(n); - return; - } - break; - case 'S': - if (next == 'P') { - modes.editingFlags |= signPlus; - return; - } - if (!next || next == 'S') { - modes.editingFlags &= ~signPlus; - return; - } - break; - case 'T': { - if (!next) { // Tn - context.HandleAbsolutePosition(n); - return; - } - if (next == 'L' || next == 'R') { // TLn & TRn - context.HandleRelativePosition(next == 'L' ? -n : n); - return; - } - } break; - default: break; - } - if (next) { - context.Crash("Unknown '%c%c' edit descriptor in FORMAT", ch, next); - } else { - context.Crash("Unknown '%c' edit descriptor in FORMAT", ch); - } -} - -// Locates the next data edit descriptor in the format. -// Handles all repetition counts and control edit descriptors. -// Generally assumes that the format string has survived the common -// format validator gauntlet. -template -int FormatControl::CueUpNextDataEdit(FormatContext &context, bool stop) { - int unlimitedLoopCheck{-1}; - while (true) { - std::optional repeat; - bool unlimited{false}; - CHAR ch{Capitalize(GetNextChar(context))}; - while (ch == ',' || ch == ':') { - // Skip commas, and don't complain if they're missing; the format - // validator does that. - if (stop && ch == ':') { - return 0; - } - ch = Capitalize(GetNextChar(context)); - } - if (ch == '-' || ch == '+' || (ch >= '0' && ch <= '9')) { - repeat = GetIntField(context, ch); - ch = GetNextChar(context); - } else if (ch == '*') { - unlimited = true; - ch = GetNextChar(context); - if (ch != '(') { - context.Crash("Invalid FORMAT: '*' may appear only before '('"); - } - } - if (ch == '(') { - if (height_ >= maxHeight_) { - context.Crash("FORMAT stack overflow: too many nested parentheses"); - } - stack_[height_].start = offset_ - 1; // the '(' - if (unlimited || height_ == 0) { - stack_[height_].remaining = Iteration::unlimited; - unlimitedLoopCheck = offset_ - 1; - } else if (repeat) { - if (*repeat <= 0) { - *repeat = 1; // error recovery - } - stack_[height_].remaining = *repeat - 1; - } else { - stack_[height_].remaining = 0; - } - ++height_; - } else if (height_ == 0) { - context.Crash("FORMAT lacks initial '('"); - } else if (ch == ')') { - if (height_ == 1) { - if (stop) { - return 0; // end of FORMAT and no data items remain - } - context.HandleSlash(); // implied / before rightmost ) - } - if (stack_[height_ - 1].remaining == Iteration::unlimited) { - offset_ = stack_[height_ - 1].start + 1; - if (offset_ == unlimitedLoopCheck) { - context.Crash( - "Unlimited repetition in FORMAT lacks data edit descriptors"); - } - } else if (stack_[height_ - 1].remaining-- > 0) { - offset_ = stack_[height_ - 1].start + 1; - } else { - --height_; - } - } else if (ch == '\'' || ch == '"') { - // Quoted 'character literal' - CHAR quote{ch}; - auto start{offset_}; - while (offset_ < formatLength_ && format_[offset_] != quote) { - ++offset_; - } - if (offset_ >= formatLength_) { - context.Crash("FORMAT missing closing quote on character literal"); - } - ++offset_; - std::size_t chars{ - static_cast(&format_[offset_] - &format_[start])}; - if (PeekNext() == quote) { - // subtle: handle doubled quote character in a literal by including - // the first in the output, then treating the second as the start - // of another character literal. - } else { - --chars; - } - context.Emit(format_ + start, chars); - } else if (ch == 'H') { - // 9HHOLLERITH - if (!repeat || *repeat < 1 || offset_ + *repeat > formatLength_) { - context.Crash("Invalid width on Hollerith in FORMAT"); - } - context.Emit(format_ + offset_, static_cast(*repeat)); - offset_ += *repeat; - } else if (ch >= 'A' && ch <= 'Z') { - int start{offset_ - 1}; - CHAR next{Capitalize(PeekNext())}; - if (next >= 'A' && next <= 'Z') { - ++offset_; - } else { - next = '\0'; - } - if (ch == 'E' || - (!next && - (ch == 'A' || ch == 'I' || ch == 'B' || ch == 'O' || ch == 'Z' || - ch == 'F' || ch == 'D' || ch == 'G' || ch == 'L'))) { - // Data edit descriptor found - offset_ = start; - return repeat && *repeat > 0 ? *repeat : 1; - } else { - // Control edit descriptor - if (ch == 'T') { // Tn, TLn, TRn - repeat = GetIntField(context); - } - HandleControl(context, static_cast(ch), static_cast(next), - repeat ? *repeat : 1); - } - } else if (ch == '/') { - context.HandleSlash(repeat && *repeat > 0 ? *repeat : 1); - } else { - context.Crash("Invalid character '%c' in FORMAT", static_cast(ch)); - } - } -} - -template -void FormatControl::GetNext( - FormatContext &context, DataEdit &edit, int maxRepeat) { - - // TODO: DT editing - - // Return the next data edit descriptor - int repeat{CueUpNextDataEdit(context)}; - auto start{offset_}; - edit.descriptor = static_cast(Capitalize(GetNextChar(context))); - if (edit.descriptor == 'E') { - edit.variation = static_cast(Capitalize(PeekNext())); - if (edit.variation >= 'A' && edit.variation <= 'Z') { - ++offset_; - } else { - edit.variation = '\0'; - } - } else { - edit.variation = '\0'; - } - - if (edit.descriptor == 'A') { // width is optional for A[w] - auto ch{PeekNext()}; - if (ch >= '0' && ch <= '9') { - edit.width = GetIntField(context); - } else { - edit.width.reset(); - } - } else { - edit.width = GetIntField(context); - } - edit.modes = context.mutableModes(); - if (PeekNext() == '.') { - ++offset_; - edit.digits = GetIntField(context); - CHAR ch{PeekNext()}; - if (ch == 'e' || ch == 'E' || ch == 'd' || ch == 'D') { - ++offset_; - edit.expoDigits = GetIntField(context); - } else { - edit.expoDigits.reset(); - } - } else { - edit.digits.reset(); - edit.expoDigits.reset(); - } - - // Handle repeated nonparenthesized edit descriptors - if (repeat > 1) { - stack_[height_].start = start; // after repeat count - stack_[height_].remaining = repeat; // full count - ++height_; - } - edit.repeat = 1; - if (height_ > 1) { - int start{stack_[height_ - 1].start}; - if (format_[start] != '(') { - if (stack_[height_ - 1].remaining > maxRepeat) { - edit.repeat = maxRepeat; - stack_[height_ - 1].remaining -= maxRepeat; - offset_ = start; // repeat same edit descriptor next time - } else { - edit.repeat = stack_[height_ - 1].remaining; - --height_; - } - } - } -} - -template -void FormatControl::FinishOutput(FormatContext &context) { - CueUpNextDataEdit(context, true /* stop at colon or end of FORMAT */); -} - -template class FormatControl; -template class FormatControl; -template class FormatControl; +DataEdit DefaultFormatControlCallbacks::GetNextDataEdit(int) { + Crash("DefaultFormatControlCallbacks::GetNextDataEdit() called for " + "non-formatted I/O statement"); + return {}; +} +bool DefaultFormatControlCallbacks::Emit(const char *, std::size_t) { + Crash("DefaultFormatControlCallbacks::Emit(char) called for non-output I/O " + "statement"); + return {}; +} +bool DefaultFormatControlCallbacks::Emit(const char16_t *, std::size_t) { + Crash("DefaultFormatControlCallbacks::Emit(char16_t) called for non-output " + "I/O statement"); + return {}; +} +bool DefaultFormatControlCallbacks::Emit(const char32_t *, std::size_t) { + Crash("DefaultFormatControlCallbacks::Emit(char32_t) called for non-output " + "I/O statement"); + return {}; +} +bool DefaultFormatControlCallbacks::AdvanceRecord(int) { + Crash("DefaultFormatControlCallbacks::AdvanceRecord() called unexpectedly"); + return {}; +} +bool DefaultFormatControlCallbacks::HandleAbsolutePosition(std::int64_t) { + Crash("DefaultFormatControlCallbacks::HandleAbsolutePosition() called for " + "non-formatted " + "I/O statement"); + return {}; +} +bool DefaultFormatControlCallbacks::HandleRelativePosition(std::int64_t) { + Crash("DefaultFormatControlCallbacks::HandleRelativePosition() called for " + "non-formatted " + "I/O statement"); + return {}; +} + +template class FormatControl>; +template class FormatControl>; +template class FormatControl>; } diff --git a/runtime/format.h b/runtime/format.h index c954c7f3872f..c072b3b9805d 100644 --- a/runtime/format.h +++ b/runtime/format.h @@ -12,8 +12,10 @@ #define FORTRAN_RUNTIME_FORMAT_H_ #include "environment.h" +#include "io-error.h" #include "terminator.h" #include "flang/common/Fortran.h" +#include "flang/decimal/decimal.h" #include #include @@ -27,7 +29,7 @@ enum EditingFlags { struct MutableModes { std::uint8_t editingFlags{0}; // BN, DP, SS - common::RoundingMode roundingMode{ + enum decimal::FortranRounding round{ executionEnvironment .defaultOutputRoundingMode}; // RP/ROUND='PROCESSOR_DEFAULT' bool pad{false}; // PAD= mode on READ @@ -38,6 +40,16 @@ struct MutableModes { // A single edit descriptor extracted from a FORMAT struct DataEdit { char descriptor; // capitalized: one of A, I, B, O, Z, F, E(N/S/X), D, G + + // Special internal data edit descriptors to distinguish list-directed I/O + static constexpr char ListDirected{'g'}; // non-COMPLEX list-directed + static constexpr char ListDirectedRealPart{'r'}; // emit "(r," or "(r;" + static constexpr char ListDirectedImaginaryPart{'z'}; // emit "z)" + constexpr bool IsListDirected() const { + return descriptor == ListDirected || descriptor == ListDirectedRealPart || + descriptor == ListDirectedImaginaryPart; + } + char variation{'\0'}; // N, S, or X for EN, ES, EX std::optional width; // the 'w' field; optional for A std::optional digits; // the 'm' or 'd' field @@ -46,37 +58,35 @@ struct DataEdit { int repeat{1}; }; -class FormatContext : virtual public Terminator { -public: - FormatContext() {} - virtual ~FormatContext() {} - explicit FormatContext(const MutableModes &modes) : mutableModes_{modes} {} - virtual bool Emit(const char *, std::size_t) = 0; - virtual bool Emit(const char16_t *, std::size_t) = 0; - virtual bool Emit(const char32_t *, std::size_t) = 0; - virtual bool HandleSlash(int = 1) = 0; - virtual bool HandleRelativePosition(std::int64_t) = 0; - virtual bool HandleAbsolutePosition(std::int64_t) = 0; - MutableModes &mutableModes() { return mutableModes_; } - -private: - MutableModes mutableModes_; +// FormatControl requires that A have these member functions; +// these default implementations just crash if called. +struct DefaultFormatControlCallbacks : public IoErrorHandler { + using IoErrorHandler::IoErrorHandler; + DataEdit GetNextDataEdit(int = 1); + bool Emit(const char *, std::size_t); + bool Emit(const char16_t *, std::size_t); + bool Emit(const char32_t *, std::size_t); + bool AdvanceRecord(int = 1); + bool HandleAbsolutePosition(std::int64_t); + bool HandleRelativePosition(std::int64_t); }; // Generates a sequence of DataEdits from a FORMAT statement or // default-CHARACTER string. Driven by I/O item list processing. // Errors are fatal. See clause 13.4 in Fortran 2018 for background. -template class FormatControl { +template class FormatControl { public: + using Context = CONTEXT; + using CharType = typename Context::CharType; + FormatControl() {} - // TODO: make 'format' a reference here and below - FormatControl(Terminator &, const CHAR *format, std::size_t formatLength, - int maxHeight = maxMaxHeight); + FormatControl(const Terminator &, const CharType *format, + std::size_t formatLength, int maxHeight = maxMaxHeight); // Determines the max parenthesis nesting level by scanning and validating // the FORMAT string. static int GetMaxParenthesisNesting( - Terminator &, const CHAR *format, std::size_t formatLength); + const Terminator &, const CharType *format, std::size_t formatLength); // For attempting to allocate in a user-supplied stack area static std::size_t GetNeededSize(int maxHeight) { @@ -86,10 +96,10 @@ template class FormatControl { // Extracts the next data edit descriptor, handling control edit descriptors // along the way. - void GetNext(FormatContext &, DataEdit &, int maxRepeat = 1); + DataEdit GetNextDataEdit(Context &, int maxRepeat = 1); // Emit any remaining character literals after the last data item. - void FinishOutput(FormatContext &); + void FinishOutput(Context &); private: static constexpr std::uint8_t maxMaxHeight{100}; @@ -105,27 +115,27 @@ template class FormatControl { ++offset_; } } - CHAR PeekNext() { + CharType PeekNext() { SkipBlanks(); return offset_ < formatLength_ ? format_[offset_] : '\0'; } - CHAR GetNextChar(Terminator &terminator) { + CharType GetNextChar(const Terminator &terminator) { SkipBlanks(); if (offset_ >= formatLength_) { terminator.Crash("FORMAT missing at least one ')'"); } return format_[offset_++]; } - int GetIntField(Terminator &, CHAR firstCh = '\0'); + int GetIntField(const Terminator &, CharType firstCh = '\0'); // Advances through the FORMAT until the next data edit // descriptor has been found; handles control edit descriptors // along the way. Returns the repeat count that appeared // before the descriptor (defaulting to 1) and leaves offset_ // pointing to the data edit. - int CueUpNextDataEdit(FormatContext &, bool stop = false); + int CueUpNextDataEdit(Context &, bool stop = false); - static constexpr CHAR Capitalize(CHAR ch) { + static constexpr CharType Capitalize(CharType ch) { return ch >= 'a' && ch <= 'z' ? ch + 'A' - 'a' : ch; } @@ -134,16 +144,12 @@ template class FormatControl { // user program for internal I/O. const std::uint8_t maxHeight_{maxMaxHeight}; std::uint8_t height_{0}; - const CHAR *format_{nullptr}; + const CharType *format_{nullptr}; int formatLength_{0}; int offset_{0}; // next item is at format_[offset_] // must be last, may be incomplete Iteration stack_[maxMaxHeight]; }; - -extern template class FormatControl; -extern template class FormatControl; -extern template class FormatControl; } #endif // FORTRAN_RUNTIME_FORMAT_H_ diff --git a/runtime/internal-unit.cpp b/runtime/internal-unit.cpp new file mode 100644 index 000000000000..737f0856e33f --- /dev/null +++ b/runtime/internal-unit.cpp @@ -0,0 +1,129 @@ +//===-- runtime/internal-unit.cpp -------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#include "internal-unit.h" +#include "descriptor.h" +#include "io-error.h" +#include +#include + +namespace Fortran::runtime::io { + +template +InternalDescriptorUnit::InternalDescriptorUnit( + Scalar scalar, std::size_t length) { + recordLength = length; + endfileRecordNumber = 2; + void *pointer{reinterpret_cast(const_cast(scalar))}; + descriptor().Establish(TypeCode{CFI_type_char}, length, pointer, 0, nullptr, + CFI_attribute_pointer); +} + +template +InternalDescriptorUnit::InternalDescriptorUnit( + const Descriptor &that, const Terminator &terminator) { + RUNTIME_CHECK(terminator, that.type().IsCharacter()); + Descriptor &d{descriptor()}; + RUNTIME_CHECK( + terminator, that.SizeInBytes() <= d.SizeInBytes(maxRank, true, 0)); + new (&d) Descriptor{that}; + d.Check(); + recordLength = d.ElementBytes(); + endfileRecordNumber = d.Elements() + 1; + d.GetLowerBounds(at_); +} + +template void InternalDescriptorUnit::EndIoStatement() { + if constexpr (!isInput) { + // blank fill + while (currentRecordNumber < endfileRecordNumber.value_or(0)) { + char *record{descriptor().template Element(at_)}; + std::fill_n(record + furthestPositionInRecord, + recordLength.value_or(0) - furthestPositionInRecord, ' '); + furthestPositionInRecord = 0; + ++currentRecordNumber; + descriptor().IncrementSubscripts(at_); + } + } +} + +template +bool InternalDescriptorUnit::Emit( + const char *data, std::size_t bytes, IoErrorHandler &handler) { + if constexpr (isInput) { + handler.Crash( + "InternalDescriptorUnit::Emit() called for an input statement"); + return false; + } + if (currentRecordNumber >= endfileRecordNumber.value_or(0)) { + handler.SignalEnd(); + return false; + } + char *record{descriptor().template Element(at_)}; + auto furthestAfter{std::max(furthestPositionInRecord, + positionInRecord + static_cast(bytes))}; + bool ok{true}; + if (furthestAfter > static_cast(recordLength.value_or(0))) { + handler.SignalEor(); + furthestAfter = recordLength.value_or(0); + bytes = std::max(std::int64_t{0}, furthestAfter - positionInRecord); + ok = false; + } + std::memcpy(record + positionInRecord, data, bytes); + positionInRecord += bytes; + furthestPositionInRecord = furthestAfter; + return ok; +} + +template +bool InternalDescriptorUnit::AdvanceRecord(IoErrorHandler &handler) { + if (currentRecordNumber >= endfileRecordNumber.value_or(0)) { + handler.SignalEnd(); + return false; + } + if (!HandleAbsolutePosition(recordLength.value_or(0), handler)) { + return false; + } + ++currentRecordNumber; + descriptor().IncrementSubscripts(at_); + positionInRecord = 0; + furthestPositionInRecord = 0; + return true; +} + +template +bool InternalDescriptorUnit::HandleAbsolutePosition( + std::int64_t n, IoErrorHandler &handler) { + n = std::max(0, n); + bool ok{true}; + if (n > static_cast(recordLength.value_or(n))) { + handler.SignalEor(); + n = *recordLength; + ok = false; + } + if (n > furthestPositionInRecord && ok) { + if constexpr (!isInput) { + char *record{descriptor().template Element(at_)}; + std::fill_n( + record + furthestPositionInRecord, n - furthestPositionInRecord, ' '); + } + furthestPositionInRecord = n; + } + positionInRecord = n; + return ok; +} + +template +bool InternalDescriptorUnit::HandleRelativePosition( + std::int64_t n, IoErrorHandler &handler) { + return HandleAbsolutePosition(positionInRecord + n, handler); +} + +template class InternalDescriptorUnit; +template class InternalDescriptorUnit; +} diff --git a/runtime/internal-unit.h b/runtime/internal-unit.h new file mode 100644 index 000000000000..837ddc6f588f --- /dev/null +++ b/runtime/internal-unit.h @@ -0,0 +1,46 @@ +//===-- runtime/internal-unit.h ---------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +// Fortran internal I/O "units" + +#ifndef FORTRAN_RUNTIME_IO_INTERNAL_UNIT_H_ +#define FORTRAN_RUNTIME_IO_INTERNAL_UNIT_H_ + +#include "connection.h" +#include "descriptor.h" +#include +#include + +namespace Fortran::runtime::io { + +class IoErrorHandler; + +// Points to (but does not own) a CHARACTER scalar or array for internal I/O. +// Does not buffer. +template class InternalDescriptorUnit : public ConnectionState { +public: + using Scalar = std::conditional_t; + InternalDescriptorUnit(Scalar, std::size_t); + InternalDescriptorUnit(const Descriptor &, const Terminator &); + void EndIoStatement(); + + bool Emit(const char *, std::size_t bytes, IoErrorHandler &); + bool AdvanceRecord(IoErrorHandler &); + bool HandleAbsolutePosition(std::int64_t, IoErrorHandler &); + bool HandleRelativePosition(std::int64_t, IoErrorHandler &); + +private: + Descriptor &descriptor() { return staticDescriptor_.descriptor(); } + StaticDescriptor staticDescriptor_; + SubscriptValue at_[maxRank]; +}; + +extern template class InternalDescriptorUnit; +extern template class InternalDescriptorUnit; +} +#endif // FORTRAN_RUNTIME_IO_INTERNAL_UNIT_H_ diff --git a/runtime/io-api.cpp b/runtime/io-api.cpp index d5840a03b75d..969315a49fa7 100644 --- a/runtime/io-api.cpp +++ b/runtime/io-api.cpp @@ -1,4 +1,4 @@ -//===-- runtime/io.cpp ------------------------------------------*- C++ -*-===// +//===-- runtime/io-api.cpp --------------------------------------*- C++ -*-===// // // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. // See https://llvm.org/LICENSE.txt for license information. @@ -9,24 +9,76 @@ // Implements the I/O statement API #include "io-api.h" +#include "environment.h" #include "format.h" #include "io-stmt.h" #include "memory.h" #include "numeric-output.h" #include "terminator.h" +#include "tools.h" #include "unit.h" #include #include namespace Fortran::runtime::io { +Cookie IONAME(BeginInternalArrayListOutput)(const Descriptor &descriptor, + void ** /*scratchArea*/, std::size_t /*scratchBytes*/, + const char *sourceFile, int sourceLine) { + Terminator oom{sourceFile, sourceLine}; + return &New>{}( + oom, descriptor, sourceFile, sourceLine) + .ioStatementState(); +} + +Cookie IONAME(BeginInternalArrayFormattedOutput)(const Descriptor &descriptor, + const char *format, std::size_t formatLength, void ** /*scratchArea*/, + std::size_t /*scratchBytes*/, const char *sourceFile, int sourceLine) { + Terminator oom{sourceFile, sourceLine}; + return &New>{}( + oom, descriptor, format, formatLength, sourceFile, sourceLine) + .ioStatementState(); +} + +Cookie IONAME(BeginInternalListOutput)(char *internal, + std::size_t internalLength, void ** /*scratchArea*/, + std::size_t /*scratchBytes*/, const char *sourceFile, int sourceLine) { + Terminator oom{sourceFile, sourceLine}; + return &New>{}( + oom, internal, internalLength, sourceFile, sourceLine) + .ioStatementState(); +} + Cookie IONAME(BeginInternalFormattedOutput)(char *internal, std::size_t internalLength, const char *format, std::size_t formatLength, void ** /*scratchArea*/, std::size_t /*scratchBytes*/, const char *sourceFile, int sourceLine) { Terminator oom{sourceFile, sourceLine}; return &New>{}(oom, internal, - internalLength, format, formatLength, sourceFile, sourceLine); + internalLength, format, formatLength, sourceFile, sourceLine) + .ioStatementState(); +} + +Cookie IONAME(BeginInternalFormattedInput)(char *internal, + std::size_t internalLength, const char *format, std::size_t formatLength, + void ** /*scratchArea*/, std::size_t /*scratchBytes*/, + const char *sourceFile, int sourceLine) { + Terminator oom{sourceFile, sourceLine}; + return &New>{}(oom, internal, + internalLength, format, formatLength, sourceFile, sourceLine) + .ioStatementState(); +} + +Cookie IONAME(BeginExternalListOutput)( + ExternalUnit unitNumber, const char *sourceFile, int sourceLine) { + Terminator terminator{sourceFile, sourceLine}; + int unit{unitNumber == DefaultUnit ? 6 : unitNumber}; + ExternalFileUnit &file{ExternalFileUnit::LookUpOrCrash(unit, terminator)}; + if (file.isUnformatted) { + terminator.Crash("List-directed output attempted to unformatted file"); + } + return &file.BeginIoStatement>( + file, sourceFile, sourceLine); } Cookie IONAME(BeginExternalFormattedOutput)(const char *format, @@ -34,53 +86,557 @@ Cookie IONAME(BeginExternalFormattedOutput)(const char *format, int sourceLine) { Terminator terminator{sourceFile, sourceLine}; int unit{unitNumber == DefaultUnit ? 6 : unitNumber}; - ExternalFile &file{ExternalFile::LookUpOrCrash(unit, terminator)}; - return &file.BeginIoStatement>( - file, format, formatLength, sourceFile, sourceLine); + ExternalFileUnit &file{ExternalFileUnit::LookUpOrCrash(unit, terminator)}; + if (file.isUnformatted) { + terminator.Crash("Formatted output attempted to unformatted file"); + } + IoStatementState &io{ + file.BeginIoStatement>( + file, format, formatLength, sourceFile, sourceLine)}; + return &io; +} + +Cookie IONAME(BeginUnformattedOutput)( + ExternalUnit unitNumber, const char *sourceFile, int sourceLine) { + Terminator terminator{sourceFile, sourceLine}; + ExternalFileUnit &file{ + ExternalFileUnit::LookUpOrCrash(unitNumber, terminator)}; + if (!file.isUnformatted) { + terminator.Crash("Unformatted output attempted to formatted file"); + } + IoStatementState &io{ + file.BeginIoStatement>( + file, sourceFile, sourceLine)}; + if (file.access == Access::Sequential && !file.recordLength.has_value()) { + // Filled in by UnformattedIoStatementState::EndIoStatement() + io.Emit("\0\0\0\0", 4); // placeholder for record length header + } + return &io; +} + +Cookie IONAME(BeginOpenUnit)( // OPEN(without NEWUNIT=) + ExternalUnit unitNumber, const char *sourceFile, int sourceLine) { + bool wasExtant{false}; + ExternalFileUnit &unit{ + ExternalFileUnit::LookUpOrCreate(unitNumber, &wasExtant)}; + return &unit.BeginIoStatement( + unit, wasExtant, sourceFile, sourceLine); +} + +Cookie IONAME(BeginOpenNewUnit)( // OPEN(NEWUNIT=j) + const char *sourceFile, int sourceLine) { + return IONAME(BeginOpenUnit)( + ExternalFileUnit::NewUnit(), sourceFile, sourceLine); +} + +Cookie IONAME(BeginClose)( + ExternalUnit unitNumber, const char *sourceFile, int sourceLine) { + if (ExternalFileUnit * unit{ExternalFileUnit::LookUp(unitNumber)}) { + return &unit->BeginIoStatement( + *unit, sourceFile, sourceLine); + } else { + // CLOSE(UNIT=bad unit) is just a no-op + Terminator oom{sourceFile, sourceLine}; + return &New{}(oom, sourceFile, sourceLine) + .ioStatementState(); + } +} + +// Control list items + +void IONAME(EnableHandlers)( + Cookie cookie, bool hasIoStat, bool hasErr, bool hasEnd, bool hasEor) { + IoErrorHandler &handler{cookie->GetIoErrorHandler()}; + if (hasIoStat) { + handler.HasIoStat(); + } + if (hasErr) { + handler.HasErrLabel(); + } + if (hasEnd) { + handler.HasEndLabel(); + } + if (hasEor) { + handler.HasEorLabel(); + } +} + +static bool YesOrNo(const char *keyword, std::size_t length, const char *what, + const Terminator &terminator) { + static const char *keywords[]{"YES", "NO", nullptr}; + switch (IdentifyValue(keyword, length, keywords)) { + case 0: return true; + case 1: return false; + default: + terminator.Crash( + "Invalid %s='%.*s'", what, static_cast(length), keyword); + return false; + } +} + +bool IONAME(SetAdvance)( + Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + ConnectionState &connection{io.GetConnectionState()}; + connection.nonAdvancing = + !YesOrNo(keyword, length, "ADVANCE", io.GetIoErrorHandler()); + return true; +} + +bool IONAME(SetBlank)(Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + ConnectionState &connection{io.GetConnectionState()}; + static const char *keywords[]{"NULL", "ZERO", nullptr}; + switch (IdentifyValue(keyword, length, keywords)) { + case 0: connection.modes.editingFlags &= ~blankZero; return true; + case 1: connection.modes.editingFlags |= blankZero; return true; + default: + io.GetIoErrorHandler().Crash( + "Invalid BLANK='%.*s'", static_cast(length), keyword); + return false; + } +} + +bool IONAME(SetDecimal)( + Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + ConnectionState &connection{io.GetConnectionState()}; + static const char *keywords[]{"COMMA", "POINT", nullptr}; + switch (IdentifyValue(keyword, length, keywords)) { + case 0: connection.modes.editingFlags |= decimalComma; return true; + case 1: connection.modes.editingFlags &= ~decimalComma; return true; + default: + io.GetIoErrorHandler().Crash( + "Invalid DECIMAL='%.*s'", static_cast(length), keyword); + return false; + } +} + +bool IONAME(SetDelim)(Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + ConnectionState &connection{io.GetConnectionState()}; + static const char *keywords[]{"APOSTROPHE", "QUOTE", "NONE", nullptr}; + switch (IdentifyValue(keyword, length, keywords)) { + case 0: connection.modes.delim = '\''; return true; + case 1: connection.modes.delim = '"'; return true; + case 2: connection.modes.delim = '\0'; return true; + default: + io.GetIoErrorHandler().Crash( + "Invalid DELIM='%.*s'", static_cast(length), keyword); + return false; + } +} + +bool IONAME(SetPad)(Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + ConnectionState &connection{io.GetConnectionState()}; + connection.modes.pad = + YesOrNo(keyword, length, "PAD", io.GetIoErrorHandler()); + return true; +} + +// TODO: SetPos (stream I/O) +// TODO: SetRec (direct I/O) + +bool IONAME(SetRound)(Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + ConnectionState &connection{io.GetConnectionState()}; + static const char *keywords[]{"UP", "DOWN", "ZERO", "NEAREST", "COMPATIBLE", + "PROCESSOR_DEFINED", nullptr}; + switch (IdentifyValue(keyword, length, keywords)) { + case 0: connection.modes.round = decimal::RoundUp; return true; + case 1: connection.modes.round = decimal::RoundDown; return true; + case 2: connection.modes.round = decimal::RoundToZero; return true; + case 3: connection.modes.round = decimal::RoundNearest; return true; + case 4: connection.modes.round = decimal::RoundCompatible; return true; + case 5: + connection.modes.round = executionEnvironment.defaultOutputRoundingMode; + return true; + default: + io.GetIoErrorHandler().Crash( + "Invalid ROUND='%.*s'", static_cast(length), keyword); + return false; + } +} + +bool IONAME(SetSign)(Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + ConnectionState &connection{io.GetConnectionState()}; + static const char *keywords[]{"PLUS", "YES", "PROCESSOR_DEFINED", nullptr}; + switch (IdentifyValue(keyword, length, keywords)) { + case 0: connection.modes.editingFlags |= signPlus; return true; + case 1: + case 2: // processor default is SS + connection.modes.editingFlags &= ~signPlus; + return true; + default: + io.GetIoErrorHandler().Crash( + "Invalid SIGN='%.*s'", static_cast(length), keyword); + return false; + } +} + +bool IONAME(SetAccess)(Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + auto *open{io.get_if()}; + if (!open) { + io.GetIoErrorHandler().Crash( + "SetAccess() called when not in an OPEN statement"); + } + ConnectionState &connection{open->GetConnectionState()}; + Access access{connection.access}; + static const char *keywords[]{"SEQUENTIAL", "DIRECT", "STREAM", nullptr}; + switch (IdentifyValue(keyword, length, keywords)) { + case 0: access = Access::Sequential; break; + case 1: access = Access::Direct; break; + case 2: access = Access::Stream; break; + default: + open->Crash("Invalid ACCESS='%.*s'", static_cast(length), keyword); + } + if (access != connection.access) { + if (open->wasExtant()) { + open->Crash("ACCESS= may not be changed on an open unit"); + } + connection.access = access; + } + return true; +} + +bool IONAME(SetAction)(Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + auto *open{io.get_if()}; + if (!open) { + io.GetIoErrorHandler().Crash( + "SetAction() called when not in an OPEN statement"); + } + bool mayRead{true}; + bool mayWrite{true}; + static const char *keywords[]{"READ", "WRITE", "READWRITE", nullptr}; + switch (IdentifyValue(keyword, length, keywords)) { + case 0: mayWrite = false; break; + case 1: mayRead = false; break; + case 2: break; + default: + open->Crash("Invalid ACTION='%.*s'", static_cast(length), keyword); + return false; + } + if (mayRead != open->unit().mayRead() || + mayWrite != open->unit().mayWrite()) { + if (open->wasExtant()) { + open->Crash("ACTION= may not be changed on an open unit"); + } + open->unit().set_mayRead(mayRead); + open->unit().set_mayWrite(mayWrite); + } + return true; +} + +bool IONAME(SetAsynchronous)( + Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + auto *open{io.get_if()}; + if (!open) { + io.GetIoErrorHandler().Crash( + "SetAsynchronous() called when not in an OPEN statement"); + } + static const char *keywords[]{"YES", "NO", nullptr}; + switch (IdentifyValue(keyword, length, keywords)) { + case 0: open->unit().set_mayAsynchronous(true); return true; + case 1: open->unit().set_mayAsynchronous(false); return true; + default: + open->Crash( + "Invalid ASYNCHRONOUS='%.*s'", static_cast(length), keyword); + return false; + } +} + +bool IONAME(SetEncoding)( + Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + auto *open{io.get_if()}; + if (!open) { + io.GetIoErrorHandler().Crash( + "SetEncoding() called when not in an OPEN statement"); + } + bool isUTF8{false}; + static const char *keywords[]{"UTF-8", "DEFAULT", nullptr}; + switch (IdentifyValue(keyword, length, keywords)) { + case 0: isUTF8 = true; break; + case 1: isUTF8 = false; break; + default: + open->Crash("Invalid ENCODING='%.*s'", static_cast(length), keyword); + } + if (isUTF8 != open->unit().isUTF8) { + if (open->wasExtant()) { + open->Crash("ENCODING= may not be changed on an open unit"); + } + open->unit().isUTF8 = isUTF8; + } + return true; +} + +bool IONAME(SetForm)(Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + auto *open{io.get_if()}; + if (!open) { + io.GetIoErrorHandler().Crash( + "SetEncoding() called when not in an OPEN statement"); + } + bool isUnformatted{false}; + static const char *keywords[]{"FORMATTED", "UNFORMATTED", nullptr}; + switch (IdentifyValue(keyword, length, keywords)) { + case 0: isUnformatted = false; break; + case 1: isUnformatted = true; break; + default: + open->Crash("Invalid FORM='%.*s'", static_cast(length), keyword); + } + if (isUnformatted != open->unit().isUnformatted) { + if (open->wasExtant()) { + open->Crash("FORM= may not be changed on an open unit"); + } + open->unit().isUnformatted = isUnformatted; + } + return true; +} + +bool IONAME(SetPosition)( + Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + auto *open{io.get_if()}; + if (!open) { + io.GetIoErrorHandler().Crash( + "SetPosition() called when not in an OPEN statement"); + } + static const char *positions[]{"ASIS", "REWIND", "APPEND", nullptr}; + switch (IdentifyValue(keyword, length, positions)) { + case 0: open->set_position(Position::AsIs); return true; + case 1: open->set_position(Position::Rewind); return true; + case 2: open->set_position(Position::Append); return true; + default: + io.GetIoErrorHandler().Crash( + "Invalid POSITION='%.*s'", static_cast(length), keyword); + } + return true; +} + +bool IONAME(SetRecl)(Cookie cookie, std::size_t n) { + IoStatementState &io{*cookie}; + auto *open{io.get_if()}; + if (!open) { + io.GetIoErrorHandler().Crash( + "SetRecl() called when not in an OPEN statement"); + } + if (open->wasExtant() && open->unit().recordLength.has_value() && + *open->unit().recordLength != n) { + open->Crash("RECL= may not be changed for an open unit"); + } + open->unit().recordLength = n; + return true; +} + +bool IONAME(SetStatus)(Cookie cookie, const char *keyword, std::size_t length) { + IoStatementState &io{*cookie}; + if (auto *open{io.get_if()}) { + static const char *statuses[]{ + "OLD", "NEW", "SCRATCH", "REPLACE", "UNKNOWN", nullptr}; + switch (IdentifyValue(keyword, length, statuses)) { + case 0: open->set_status(OpenStatus::Old); return true; + case 1: open->set_status(OpenStatus::New); return true; + case 2: open->set_status(OpenStatus::Scratch); return true; + case 3: open->set_status(OpenStatus::Replace); return true; + case 4: open->set_status(OpenStatus::Unknown); return true; + default: + io.GetIoErrorHandler().Crash( + "Invalid STATUS='%.*s'", static_cast(length), keyword); + } + return false; + } + if (auto *close{io.get_if()}) { + static const char *statuses[]{"KEEP", "DELETE", nullptr}; + switch (IdentifyValue(keyword, length, statuses)) { + case 0: close->set_status(CloseStatus::Keep); return true; + case 1: close->set_status(CloseStatus::Delete); return true; + default: + io.GetIoErrorHandler().Crash( + "Invalid STATUS='%.*s'", static_cast(length), keyword); + } + return false; + } + if (io.get_if()) { + return true; // don't bother validating STATUS= in a no-op CLOSE + } + io.GetIoErrorHandler().Crash( + "SetStatus() called when not in an OPEN or CLOSE statement"); +} + +bool IONAME(SetFile)( + Cookie cookie, const char *path, std::size_t chars, int kind) { + IoStatementState &io{*cookie}; + if (auto *open{io.get_if()}) { + open->set_path(path, chars, kind); + return true; + } + io.GetIoErrorHandler().Crash( + "SetFile() called when not in an OPEN statement"); + return false; +} + +static bool SetInteger(int &x, int kind, int value) { + switch (kind) { + case 1: reinterpret_cast(x) = value; return true; + case 2: reinterpret_cast(x) = value; return true; + case 4: x = value; return true; + case 8: reinterpret_cast(x) = value; return true; + default: return false; + } +} + +bool IONAME(GetNewUnit)(Cookie cookie, int &unit, int kind) { + IoStatementState &io{*cookie}; + auto *open{io.get_if()}; + if (!open) { + io.GetIoErrorHandler().Crash( + "GetNewUnit() called when not in an OPEN statement"); + } + if (!SetInteger(unit, kind, open->unit().unitNumber())) { + open->Crash("GetNewUnit(): Bad INTEGER kind(%d) for result"); + } + return true; +} + +// Data transfers +// TODO: Input + +bool IONAME(OutputDescriptor)(Cookie cookie, const Descriptor &) { + IoStatementState &io{*cookie}; + io.GetIoErrorHandler().Crash( + "OutputDescriptor: not yet implemented"); // TODO +} + +bool IONAME(OutputUnformattedBlock)( + Cookie cookie, const char *x, std::size_t length) { + IoStatementState &io{*cookie}; + if (auto *unf{io.get_if>()}) { + return unf->Emit(x, length); + } + io.GetIoErrorHandler().Crash("OutputUnformatted() called for an I/O " + "statement that is not unformatted output"); + return false; } bool IONAME(OutputInteger64)(Cookie cookie, std::int64_t n) { IoStatementState &io{*cookie}; - DataEdit edit; - io.GetNext(edit); - return EditIntegerOutput(io, edit, n); + if (!io.get_if()) { + io.GetIoErrorHandler().Crash( + "OutputInteger64() called for a non-output I/O statement"); + return false; + } + return EditIntegerOutput(io, io.GetNextDataEdit(), n); } bool IONAME(OutputReal64)(Cookie cookie, double x) { IoStatementState &io{*cookie}; - DataEdit edit; - io.GetNext(edit); - return RealOutputEditing{io, x}.Edit(edit); + if (!io.get_if()) { + io.GetIoErrorHandler().Crash( + "OutputReal64() called for a non-output I/O statement"); + return false; + } + return RealOutputEditing<53>{io, x}.Edit(io.GetNextDataEdit()); +} + +bool IONAME(OutputComplex64)(Cookie cookie, double r, double z) { + IoStatementState &io{*cookie}; + if (io.get_if>()) { + DataEdit real, imaginary; + real.descriptor = DataEdit::ListDirectedRealPart; + imaginary.descriptor = DataEdit::ListDirectedImaginaryPart; + return RealOutputEditing<53>{io, r}.Edit(real) && + RealOutputEditing<53>{io, z}.Edit(imaginary); + } + return IONAME(OutputReal64)(cookie, r) && IONAME(OutputReal64)(cookie, z); } bool IONAME(OutputAscii)(Cookie cookie, const char *x, std::size_t length) { IoStatementState &io{*cookie}; - DataEdit edit; - io.GetNext(edit); - if (edit.descriptor != 'A' && edit.descriptor != 'G') { - io.Crash( - "Data edit descriptor '%c' may not be used with a CHARACTER data item", - edit.descriptor); + if (!io.get_if()) { + io.GetIoErrorHandler().Crash( + "OutputAscii() called for a non-output I/O statement"); return false; } - int len{static_cast(length)}; - int width{edit.width.value_or(len)}; - return EmitRepeated(io, ' ', std::max(0, width - len)) && - io.Emit(x, std::min(width, len)); + bool ok{true}; + if (auto *list{io.get_if>()}) { + // List-directed default CHARACTER output + ok &= list->EmitLeadingSpaceOrAdvance(io, length, true); + MutableModes &modes{io.mutableModes()}; + ConnectionState &connection{io.GetConnectionState()}; + if (modes.delim) { + ok &= io.Emit(&modes.delim, 1); + for (std::size_t j{0}; j < length; ++j) { + if (list->NeedAdvance(connection, 2)) { + ok &= io.Emit(&modes.delim, 1) && io.AdvanceRecord() && + io.Emit(&modes.delim, 1); + } + if (x[j] == modes.delim) { + ok &= io.EmitRepeated(modes.delim, 2); + } else { + ok &= io.Emit(&x[j], 1); + } + } + ok &= io.Emit(&modes.delim, 1); + } else { + std::size_t put{0}; + while (put < length) { + auto chunk{std::min(length - put, connection.RemainingSpaceInRecord())}; + ok &= io.Emit(x + put, chunk); + put += chunk; + if (put < length) { + ok &= io.AdvanceRecord() && io.Emit(" ", 1); + } + } + list->lastWasUndelimitedCharacter = true; + } + } else { + // Formatted default CHARACTER output + DataEdit edit{io.GetNextDataEdit()}; + if (edit.descriptor != 'A' && edit.descriptor != 'G') { + io.GetIoErrorHandler().Crash("Data edit descriptor '%c' may not be used " + "with a CHARACTER data item", + edit.descriptor); + return false; + } + int len{static_cast(length)}; + int width{edit.width.value_or(len)}; + ok &= io.EmitRepeated(' ', std::max(0, width - len)) && + io.Emit(x, std::min(width, len)); + } + return ok; } bool IONAME(OutputLogical)(Cookie cookie, bool truth) { IoStatementState &io{*cookie}; - DataEdit edit; - io.GetNext(edit); - if (edit.descriptor != 'L' && edit.descriptor != 'G') { - io.Crash( - "Data edit descriptor '%c' may not be used with a LOGICAL data item", - edit.descriptor); + if (!io.get_if()) { + io.GetIoErrorHandler().Crash( + "OutputLogical() called for a non-output I/O statement"); return false; } - return EmitRepeated(io, ' ', std::max(0, edit.width.value_or(1) - 1)) && - io.Emit(truth ? "T" : "F", 1); + if (auto *unf{io.get_if>()}) { + char x = truth; + return unf->Emit(&x, 1); + } + bool ok{true}; + if (auto *list{io.get_if>()}) { + ok &= list->EmitLeadingSpaceOrAdvance(io, 1); + } else { + DataEdit edit{io.GetNextDataEdit()}; + if (edit.descriptor != 'L' && edit.descriptor != 'G') { + io.GetIoErrorHandler().Crash( + "Data edit descriptor '%c' may not be used with a LOGICAL data item", + edit.descriptor); + return false; + } + ok &= io.EmitRepeated(' ', std::max(0, edit.width.value_or(1) - 1)); + } + return ok && io.Emit(truth ? "T" : "F", 1); } enum Iostat IONAME(EndIoStatement)(Cookie cookie) { diff --git a/runtime/io-api.h b/runtime/io-api.h index 1c1f81ea4c6f..417c0b5a3981 100644 --- a/runtime/io-api.h +++ b/runtime/io-api.h @@ -51,8 +51,7 @@ constexpr std::size_t RecommendedInternalIoScratchAreaBytes( } // Internal I/O to/from character arrays &/or non-default-kind character -// requires a descriptor, which must remain unchanged until the I/O -// statement is complete. +// requires a descriptor, which is copied. Cookie IONAME(BeginInternalArrayListOutput)(const Descriptor &, void **scratchArea = nullptr, std::size_t scratchBytes = 0, const char *sourceFile = nullptr, int sourceLine = 0); @@ -172,8 +171,8 @@ Cookie IONAME(BeginInquireIoLength)( // } // } // if (EndIoStatement(cookie) == FORTRAN_RUTIME_IOSTAT_END) goto label666; -void IONAME(EnableHandlers)(Cookie, bool HasIostat = false, bool HasErr = false, - bool HasEnd = false, bool HasEor = false); +void IONAME(EnableHandlers)(Cookie, bool hasIoStat = false, bool hasErr = false, + bool hasEnd = false, bool hasEor = false); // Control list options. These return false on a error that the // Begin...() call has specified will be handled by the caller. @@ -253,12 +252,10 @@ bool IONAME(SetStatus)(Cookie, const char *, std::size_t); // SetFile() may pass a CHARACTER argument of non-default kind, // and such filenames are converted to UTF-8 before being // presented to the filesystem. -bool IONAME(SetFile)(Cookie, const char *, std::size_t, int kind = 1); +bool IONAME(SetFile)(Cookie, const char *, std::size_t chars, int kind = 1); -// GetNewUnit() must not be called until after all Set...() -// connection list specifiers have been called after -// BeginOpenNewUnit(). -bool IONAME(GetNewUnit)(Cookie, int &, int kind = 4); // NEWUNIT= +// Acquires the runtime-created unit number for OPEN(NEWUNIT=) +bool IONAME(GetNewUnit)(Cookie, int &, int kind = 4); // READ(SIZE=), after all input items bool IONAME(GetSize)(Cookie, std::int64_t, int kind = 8); diff --git a/runtime/io-error.h b/runtime/io-error.h index 6cab725186e3..80f5fa817910 100644 --- a/runtime/io-error.h +++ b/runtime/io-error.h @@ -18,9 +18,10 @@ namespace Fortran::runtime::io { -class IoErrorHandler : virtual public Terminator { +class IoErrorHandler : public Terminator { public: using Terminator::Terminator; + explicit IoErrorHandler(const Terminator &that) : Terminator{that} {} void Begin(const char *sourceFileName, int sourceLine); void HasIoStat() { flags_ |= hasIoStat; } void HasErrLabel() { flags_ |= hasErr; } diff --git a/runtime/io-stmt.cpp b/runtime/io-stmt.cpp index e54a67a328e2..adc9bae6c150 100644 --- a/runtime/io-stmt.cpp +++ b/runtime/io-stmt.cpp @@ -7,130 +7,66 @@ //===----------------------------------------------------------------------===// #include "io-stmt.h" +#include "connection.h" +#include "format.h" #include "memory.h" +#include "tools.h" #include "unit.h" #include #include +#include namespace Fortran::runtime::io { -IoStatementState::IoStatementState(const char *sourceFile, int sourceLine) - : IoErrorHandler{sourceFile, sourceLine} {} +int IoStatementBase::EndIoStatement() { return GetIoStat(); } -int IoStatementState::EndIoStatement() { return GetIoStat(); } - -// Defaults -void IoStatementState::GetNext(DataEdit &, int) { - Crash("GetNext() called for I/O statement that is not a formatted data " - "transfer statement"); -} -bool IoStatementState::Emit(const char *, std::size_t) { - Crash("Emit() called for I/O statement that is not an output statement"); - return false; -} -bool IoStatementState::Emit(const char16_t *, std::size_t) { - Crash("Emit() called for I/O statement that is not an output statement"); - return false; -} -bool IoStatementState::Emit(const char32_t *, std::size_t) { - Crash("Emit() called for I/O statement that is not an output statement"); - return false; -} -bool IoStatementState::HandleSlash(int) { - Crash("HandleSlash() called for I/O statement that is not a formatted data " - "transfer statement"); - return false; -} -bool IoStatementState::HandleRelativePosition(std::int64_t) { - Crash("HandleRelativePosition() called for I/O statement that is not a " - "formatted data transfer statement"); - return false; -} -bool IoStatementState::HandleAbsolutePosition(std::int64_t) { - Crash("HandleAbsolutePosition() called for I/O statement that is not a " - "formatted data transfer statement"); - return false; +DataEdit IoStatementBase::GetNextDataEdit(int) { + Crash("IoStatementBase::GetNextDataEdit() called for non-formatted I/O " + "statement"); } template -FixedRecordIoStatementState::FixedRecordIoStatementState( - Buffer buffer, std::size_t length, const char *sourceFile, int sourceLine) - : IoStatementState{sourceFile, sourceLine}, buffer_{buffer}, length_{length} { -} +InternalIoStatementState::InternalIoStatementState( + Buffer scalar, std::size_t length, const char *sourceFile, int sourceLine) + : IoStatementBase{sourceFile, sourceLine}, unit_{scalar, length} {} + +template +InternalIoStatementState::InternalIoStatementState( + const Descriptor &d, const char *sourceFile, int sourceLine) + : IoStatementBase{sourceFile, sourceLine}, unit_{d, *this} {} template -bool FixedRecordIoStatementState::Emit( - const CHAR *data, std::size_t chars) { +bool InternalIoStatementState::Emit( + const CharType *data, std::size_t chars) { if constexpr (isInput) { - IoStatementState::Emit(data, chars); // default Crash() + Crash("InternalIoStatementState::Emit() called for input statement"); return false; - } else if (at_ + chars > length_) { - SignalEor(); - if (at_ < length_) { - std::memcpy(buffer_ + at_, data, (length_ - at_) * sizeof(CHAR)); - at_ = furthest_ = length_; - } - return false; - } else { - std::memcpy(buffer_ + at_, data, chars * sizeof(CHAR)); - at_ += chars; - furthest_ = std::max(furthest_, at_); - return true; } + return unit_.Emit(data, chars, *this); } template -bool FixedRecordIoStatementState::HandleAbsolutePosition( - std::int64_t n) { - if (n < 0) { - n = 0; - } - n += leftTabLimit_; - bool ok{true}; - if (static_cast(n) > length_) { - SignalEor(); - n = length_; - ok = false; - } - if constexpr (!isInput) { - if (static_cast(n) > furthest_) { - std::fill_n(buffer_ + furthest_, n - furthest_, static_cast(' ')); +bool InternalIoStatementState::AdvanceRecord(int n) { + while (n-- > 0) { + if (!unit_.AdvanceRecord(*this)) { + return false; } } - at_ = n; - furthest_ = std::max(furthest_, at_); - return ok; -} - -template -bool FixedRecordIoStatementState::HandleRelativePosition( - std::int64_t n) { - return HandleAbsolutePosition(n + at_ - leftTabLimit_); + return true; } template -int FixedRecordIoStatementState::EndIoStatement() { +int InternalIoStatementState::EndIoStatement() { if constexpr (!isInput) { - HandleAbsolutePosition(length_ - leftTabLimit_); // fill + unit_.EndIoStatement(); // fill } - return GetIoStat(); -} - -template -int InternalIoStatementState::EndIoStatement() { - auto result{FixedRecordIoStatementState::EndIoStatement()}; + auto result{IoStatementBase::EndIoStatement()}; if (free_) { FreeMemory(this); } return result; } -template -InternalIoStatementState::InternalIoStatementState( - Buffer buffer, std::size_t length, const char *sourceFile, int sourceLine) - : FixedRecordIoStatementState( - buffer, length, sourceFile, sourceLine) {} - template InternalFormattedIoStatementState::InternalFormattedIoStatementState(Buffer buffer, std::size_t length, @@ -138,63 +74,289 @@ InternalFormattedIoStatementState{buffer, length, sourceFile, sourceLine}, - format_{*this, format, formatLength} {} + ioStatementState_{*this}, format_{*this, format, formatLength} {} + +template +InternalFormattedIoStatementState::InternalFormattedIoStatementState(const Descriptor &d, + const CHAR *format, std::size_t formatLength, const char *sourceFile, + int sourceLine) + : InternalIoStatementState{d, sourceFile, sourceLine}, + ioStatementState_{*this}, format_{*this, format, formatLength} {} template int InternalFormattedIoStatementState::EndIoStatement() { - format_.FinishOutput(*this); + if constexpr (!isInput) { + format_.FinishOutput(*this); + } return InternalIoStatementState::EndIoStatement(); } template -ExternalFormattedIoStatementState::ExternalFormattedIoStatementState(ExternalFile &file, - const CHAR *format, std::size_t formatLength, const char *sourceFile, - int sourceLine) - : IoStatementState{sourceFile, sourceLine}, file_{file}, format_{*this, - format, - formatLength} {} +bool InternalFormattedIoStatementState::HandleAbsolutePosition( + std::int64_t n) { + return unit_.HandleAbsolutePosition(n, *this); +} template -bool ExternalFormattedIoStatementState::Emit( - const CHAR *data, std::size_t chars) { - // TODO: UTF-8 encoding of 2- and 4-byte characters - return file_.Emit(data, chars * sizeof(CHAR), *this); +bool InternalFormattedIoStatementState::HandleRelativePosition( + std::int64_t n) { + return unit_.HandleRelativePosition(n, *this); } template -bool ExternalFormattedIoStatementState::HandleSlash(int n) { +InternalListIoStatementState::InternalListIoStatementState( + Buffer buffer, std::size_t length, const char *sourceFile, int sourceLine) + : InternalIoStatementState{buffer, length, sourceFile, + sourceLine}, + ioStatementState_{*this} {} + +template +InternalListIoStatementState::InternalListIoStatementState( + const Descriptor &d, const char *sourceFile, int sourceLine) + : InternalIoStatementState{d, sourceFile, sourceLine}, + ioStatementState_{*this} {} + +ExternalIoStatementBase::ExternalIoStatementBase( + ExternalFileUnit &unit, const char *sourceFile, int sourceLine) + : IoStatementBase{sourceFile, sourceLine}, unit_{unit} {} + +MutableModes &ExternalIoStatementBase::mutableModes() { return unit_.modes; } + +ConnectionState &ExternalIoStatementBase::GetConnectionState() { return unit_; } + +int ExternalIoStatementBase::EndIoStatement() { + if (unit_.nonAdvancing) { + unit_.leftTabLimit = unit_.furthestPositionInRecord; + unit_.nonAdvancing = false; + } else { + unit_.leftTabLimit.reset(); + } + auto result{IoStatementBase::EndIoStatement()}; + unit_.EndIoStatement(); // annihilates *this in unit_.u_ + return result; +} + +void OpenStatementState::set_path( + const char *path, std::size_t length, int kind) { + if (kind != 1) { // TODO + Crash("OPEN: FILE= with unimplemented: CHARACTER(KIND=%d)", kind); + } + std::size_t bytes{length * kind}; // TODO: UTF-8 encoding of Unicode path + path_ = SaveDefaultCharacter(path, bytes, *this); + pathLength_ = length; +} + +int OpenStatementState::EndIoStatement() { + if (wasExtant_ && status_ != OpenStatus::Old) { + Crash("OPEN statement for connected unit must have STATUS='OLD'"); + } + unit().OpenUnit(status_, position_, std::move(path_), pathLength_, *this); + return IoStatementBase::EndIoStatement(); +} + +int CloseStatementState::EndIoStatement() { + unit().CloseUnit(status_, *this); + return IoStatementBase::EndIoStatement(); +} + +int NoopCloseStatementState::EndIoStatement() { + auto result{IoStatementBase::EndIoStatement()}; + FreeMemory(this); + return result; +} + +template int ExternalIoStatementState::EndIoStatement() { + if constexpr (!isInput) { + if (!unit().nonAdvancing) { + unit().AdvanceRecord(*this); + } + unit().FlushIfTerminal(*this); + } + return ExternalIoStatementBase::EndIoStatement(); +} + +template +bool ExternalIoStatementState::Emit( + const char *data, std::size_t chars) { + if (isInput) { + Crash("ExternalIoStatementState::Emit called for input statement"); + } + return unit().Emit(data, chars * sizeof(*data), *this); +} + +template +bool ExternalIoStatementState::Emit( + const char16_t *data, std::size_t chars) { + if (isInput) { + Crash("ExternalIoStatementState::Emit called for input statement"); + } + // TODO: UTF-8 encoding + return unit().Emit( + reinterpret_cast(data), chars * sizeof(*data), *this); +} + +template +bool ExternalIoStatementState::Emit( + const char32_t *data, std::size_t chars) { + if (isInput) { + Crash("ExternalIoStatementState::Emit called for input statement"); + } + // TODO: UTF-8 encoding + return unit().Emit( + reinterpret_cast(data), chars * sizeof(*data), *this); +} + +template +bool ExternalIoStatementState::AdvanceRecord(int n) { while (n-- > 0) { - if (!file_.NextOutputRecord(*this)) { + if (!unit().AdvanceRecord(*this)) { return false; } } return true; } -template -bool ExternalFormattedIoStatementState::HandleAbsolutePosition( - std::int64_t n) { - return file_.HandleAbsolutePosition(n, *this); +template +bool ExternalIoStatementState::HandleAbsolutePosition(std::int64_t n) { + return unit().HandleAbsolutePosition(n, *this); } -template -bool ExternalFormattedIoStatementState::HandleRelativePosition( - std::int64_t n) { - return file_.HandleRelativePosition(n, *this); +template +bool ExternalIoStatementState::HandleRelativePosition(std::int64_t n) { + return unit().HandleRelativePosition(n, *this); } +template +ExternalFormattedIoStatementState::ExternalFormattedIoStatementState(ExternalFileUnit &unit, + const CHAR *format, std::size_t formatLength, const char *sourceFile, + int sourceLine) + : ExternalIoStatementState{unit, sourceFile, sourceLine}, + mutableModes_{unit.modes}, format_{*this, format, formatLength} {} + template int ExternalFormattedIoStatementState::EndIoStatement() { format_.FinishOutput(*this); - if constexpr (!isInput) { - file_.NextOutputRecord(*this); // TODO: non-advancing I/O + return ExternalIoStatementState::EndIoStatement(); +} + +DataEdit IoStatementState::GetNextDataEdit(int n) { + return std::visit([&](auto &x) { return x.get().GetNextDataEdit(n); }, u_); +} + +bool IoStatementState::Emit(const char *data, std::size_t n) { + return std::visit([=](auto &x) { return x.get().Emit(data, n); }, u_); +} + +bool IoStatementState::AdvanceRecord(int n) { + return std::visit([=](auto &x) { return x.get().AdvanceRecord(n); }, u_); +} + +int IoStatementState::EndIoStatement() { + return std::visit([](auto &x) { return x.get().EndIoStatement(); }, u_); +} + +ConnectionState &IoStatementState::GetConnectionState() { + return std::visit( + [](auto &x) -> ConnectionState & { return x.get().GetConnectionState(); }, + u_); +} + +MutableModes &IoStatementState::mutableModes() { + return std::visit( + [](auto &x) -> MutableModes & { return x.get().mutableModes(); }, u_); +} + +IoErrorHandler &IoStatementState::GetIoErrorHandler() const { + return std::visit( + [](auto &x) -> IoErrorHandler & { + return static_cast(x.get()); + }, + u_); +} + +bool IoStatementState::EmitRepeated(char ch, std::size_t n) { + return std::visit( + [=](auto &x) { + for (std::size_t j{0}; j < n; ++j) { + if (!x.get().Emit(&ch, 1)) { + return false; + } + } + return true; + }, + u_); +} + +bool IoStatementState::EmitField( + const char *p, std::size_t length, std::size_t width) { + if (width <= 0) { + width = static_cast(length); } - int result{GetIoStat()}; - file_.EndIoStatement(); // annihilates *this in file_.u_ - return result; + if (length > static_cast(width)) { + return EmitRepeated('*', width); + } else { + return EmitRepeated(' ', static_cast(width - length)) && + Emit(p, length); + } +} + +bool ListDirectedStatementState::NeedAdvance( + const ConnectionState &connection, std::size_t width) const { + return connection.positionInRecord > 0 && + width > connection.RemainingSpaceInRecord(); +} + +bool ListDirectedStatementState::EmitLeadingSpaceOrAdvance( + IoStatementState &io, std::size_t length, bool isCharacter) { + if (length == 0) { + return true; + } + const ConnectionState &connection{io.GetConnectionState()}; + int space{connection.positionInRecord == 0 || + !(isCharacter && lastWasUndelimitedCharacter)}; + lastWasUndelimitedCharacter = false; + if (NeedAdvance(connection, space + length)) { + return io.AdvanceRecord(); + } + if (space) { + return io.Emit(" ", 1); + } + return true; +} + +template +int UnformattedIoStatementState::EndIoStatement() { + auto &ext{static_cast &>(*this)}; + ExternalFileUnit &unit{ext.unit()}; + if (unit.access == Access::Sequential && !unit.recordLength.has_value()) { + // Overwrite the first four bytes of the record with its length, + // and also append the length. These four bytes were skipped over + // in BeginUnformattedOutput(). + // TODO: Break very large records up into subrecords with negative + // headers &/or footers + union { + std::uint32_t u; + char c[sizeof u]; + } u; + u.u = unit.furthestPositionInRecord - sizeof u.c; + // TODO: Convert record length to little-endian on big-endian host? + if (!(ext.Emit(u.c, sizeof u.c) && ext.HandleAbsolutePosition(0) && + ext.Emit(u.c, sizeof u.c) && ext.AdvanceRecord())) { + return false; + } + } + return ext.EndIoStatement(); } +template class InternalIoStatementState; +template class InternalIoStatementState; template class InternalFormattedIoStatementState; +template class InternalFormattedIoStatementState; +template class InternalListIoStatementState; +template class ExternalIoStatementState; template class ExternalFormattedIoStatementState; +template class ExternalListIoStatementState; +template class UnformattedIoStatementState; } diff --git a/runtime/io-stmt.h b/runtime/io-stmt.h index 002f38e82596..17549388b060 100644 --- a/runtime/io-stmt.h +++ b/runtime/io-stmt.h @@ -6,112 +6,312 @@ // //===----------------------------------------------------------------------===// -// Represents state of an I/O statement in progress +// Representations of the state of an I/O statement in progress #ifndef FORTRAN_RUNTIME_IO_STMT_H_ #define FORTRAN_RUNTIME_IO_STMT_H_ #include "descriptor.h" +#include "file.h" #include "format.h" +#include "internal-unit.h" #include "io-error.h" +#include #include +#include namespace Fortran::runtime::io { -class ExternalFile; +struct ConnectionState; +class ExternalFileUnit; -class IoStatementState : public IoErrorHandler, public FormatContext { +class OpenStatementState; +class CloseStatementState; +class NoopCloseStatementState; +template +class InternalFormattedIoStatementState; +template class InternalListIoStatementState; +template +class ExternalFormattedIoStatementState; +template class ExternalListIoStatementState; +template class UnformattedIoStatementState; + +// The Cookie type in the I/O API is a pointer (for C) to this class. +class IoStatementState { public: - IoStatementState(const char *sourceFile, int sourceLine); - virtual ~IoStatementState() {} - - virtual int EndIoStatement(); - - // Default (crashing) callback overrides for FormatContext - virtual void GetNext(DataEdit &, int maxRepeat = 1); - virtual bool Emit(const char *, std::size_t); - virtual bool Emit(const char16_t *, std::size_t); - virtual bool Emit(const char32_t *, std::size_t); - virtual bool HandleSlash(int); - virtual bool HandleRelativePosition(std::int64_t); - virtual bool HandleAbsolutePosition(std::int64_t); -}; + template explicit IoStatementState(A &x) : u_{x} {} -template -class FixedRecordIoStatementState : public IoStatementState { -protected: - using Buffer = std::conditional_t; + // These member functions each project themselves into the active alternative. + // They're used by per-data-item routines in the I/O API(e.g., OutputReal64) + // to interact with the state of the I/O statement in progress. + // This design avoids virtual member functions and function pointers, + // which may not have good support in some use cases. + DataEdit GetNextDataEdit(int = 1); + bool Emit(const char *, std::size_t); + bool AdvanceRecord(int = 1); + int EndIoStatement(); + ConnectionState &GetConnectionState(); + MutableModes &mutableModes(); -public: - FixedRecordIoStatementState( - Buffer, std::size_t, const char *sourceFile, int sourceLine); + // N.B.: this also works with base classes + template A *get_if() const { + return std::visit( + [](auto &x) -> A * { + if constexpr (std::is_convertible_v) { + return &x.get(); + } + return nullptr; + }, + u_); + } + IoErrorHandler &GetIoErrorHandler() const; - virtual bool Emit(const CHAR *, std::size_t chars /* not bytes */); - // TODO virtual void HandleSlash(int); - virtual bool HandleRelativePosition(std::int64_t); - virtual bool HandleAbsolutePosition(std::int64_t); - virtual int EndIoStatement(); + bool EmitRepeated(char, std::size_t); + bool EmitField(const char *, std::size_t length, std::size_t width); private: - Buffer buffer_{nullptr}; - std::size_t length_; // RECL= or internal I/O character variable length - std::size_t leftTabLimit_{0}; // nonzero only when non-advancing - std::size_t at_{0}; - std::size_t furthest_{0}; + std::variant, + std::reference_wrapper, + std::reference_wrapper, + std::reference_wrapper>, + std::reference_wrapper>, + std::reference_wrapper>, + std::reference_wrapper>, + std::reference_wrapper>, + std::reference_wrapper>> + u_; +}; + +// Base class for all per-I/O statement state classes. +// Inherits IoErrorHandler from its base. +struct IoStatementBase : public DefaultFormatControlCallbacks { + using DefaultFormatControlCallbacks::DefaultFormatControlCallbacks; + int EndIoStatement(); + DataEdit GetNextDataEdit(int = 1); // crashing default +}; + +struct InputStatementState {}; +struct OutputStatementState {}; +template +using IoDirectionState = + std::conditional_t; + +struct FormattedStatementState {}; + +template struct ListDirectedStatementState {}; +template<> struct ListDirectedStatementState { + static std::size_t RemainingSpaceInRecord(const ConnectionState &); + bool NeedAdvance(const ConnectionState &, std::size_t) const; + bool EmitLeadingSpaceOrAdvance( + IoStatementState &, std::size_t, bool isCharacter = false); + bool lastWasUndelimitedCharacter{false}; }; template -class InternalIoStatementState - : public FixedRecordIoStatementState { +class InternalIoStatementState : public IoStatementBase, + public IoDirectionState { public: - using typename FixedRecordIoStatementState::Buffer; + using CharType = CHAR; + using Buffer = std::conditional_t; InternalIoStatementState(Buffer, std::size_t, const char *sourceFile = nullptr, int sourceLine = 0); - virtual int EndIoStatement(); + InternalIoStatementState( + const Descriptor &, const char *sourceFile = nullptr, int sourceLine = 0); + int EndIoStatement(); + bool Emit(const CharType *, std::size_t chars /* not bytes */); + bool AdvanceRecord(int = 1); + ConnectionState &GetConnectionState() { return unit_; } + MutableModes &mutableModes() { return unit_.modes; } protected: bool free_{true}; + InternalDescriptorUnit unit_; }; -template +template class InternalFormattedIoStatementState - : public InternalIoStatementState { + : public InternalIoStatementState, + public FormattedStatementState { public: - using typename InternalIoStatementState::Buffer; + using CharType = CHAR; + using typename InternalIoStatementState::Buffer; InternalFormattedIoStatementState(Buffer internal, std::size_t internalLength, - const CHAR *format, std::size_t formatLength, + const CharType *format, std::size_t formatLength, const char *sourceFile = nullptr, int sourceLine = 0); - void GetNext(DataEdit &edit, int maxRepeat = 1) { - format_.GetNext(*this, edit, maxRepeat); + InternalFormattedIoStatementState(const Descriptor &, const CharType *format, + std::size_t formatLength, const char *sourceFile = nullptr, + int sourceLine = 0); + IoStatementState &ioStatementState() { return ioStatementState_; } + int EndIoStatement(); + DataEdit GetNextDataEdit(int maxRepeat = 1) { + return format_.GetNextDataEdit(*this, maxRepeat); } + bool HandleRelativePosition(std::int64_t); + bool HandleAbsolutePosition(std::int64_t); + +private: + IoStatementState ioStatementState_; // points to *this + using InternalIoStatementState::unit_; + // format_ *must* be last; it may be partial someday + FormatControl format_; +}; + +template +class InternalListIoStatementState + : public InternalIoStatementState, + public ListDirectedStatementState { +public: + using CharType = CHAR; + using typename InternalIoStatementState::Buffer; + InternalListIoStatementState(Buffer internal, std::size_t internalLength, + const char *sourceFile = nullptr, int sourceLine = 0); + InternalListIoStatementState( + const Descriptor &, const char *sourceFile = nullptr, int sourceLine = 0); + IoStatementState &ioStatementState() { return ioStatementState_; } + DataEdit GetNextDataEdit(int maxRepeat = 1) { + DataEdit edit; + edit.descriptor = DataEdit::ListDirected; + edit.repeat = maxRepeat; + edit.modes = InternalIoStatementState::mutableModes(); + return edit; + } + +private: + using InternalIoStatementState::unit_; + IoStatementState ioStatementState_; // points to *this +}; + +class ExternalIoStatementBase : public IoStatementBase { +public: + ExternalIoStatementBase( + ExternalFileUnit &, const char *sourceFile = nullptr, int sourceLine = 0); + ExternalFileUnit &unit() { return unit_; } + MutableModes &mutableModes(); + ConnectionState &GetConnectionState(); int EndIoStatement(); private: - FormatControl format_; // must be last, may be partial + ExternalFileUnit &unit_; }; -template -class ExternalFormattedIoStatementState : public IoStatementState { +template +class ExternalIoStatementState : public ExternalIoStatementBase, + public IoDirectionState { public: - ExternalFormattedIoStatementState(ExternalFile &, const CHAR *format, + using ExternalIoStatementBase::ExternalIoStatementBase; + int EndIoStatement(); + bool Emit(const char *, std::size_t chars /* not bytes */); + bool Emit(const char16_t *, std::size_t chars /* not bytes */); + bool Emit(const char32_t *, std::size_t chars /* not bytes */); + bool AdvanceRecord(int = 1); + bool HandleRelativePosition(std::int64_t); + bool HandleAbsolutePosition(std::int64_t); +}; + +template +class ExternalFormattedIoStatementState + : public ExternalIoStatementState, + public FormattedStatementState { +public: + using CharType = CHAR; + ExternalFormattedIoStatementState(ExternalFileUnit &, const CharType *format, std::size_t formatLength, const char *sourceFile = nullptr, int sourceLine = 0); - void GetNext(DataEdit &edit, int maxRepeat = 1) { - format_.GetNext(*this, edit, maxRepeat); + MutableModes &mutableModes() { return mutableModes_; } + int EndIoStatement(); + DataEdit GetNextDataEdit(int maxRepeat = 1) { + return format_.GetNextDataEdit(*this, maxRepeat); } - bool Emit(const CHAR *, std::size_t chars /* not bytes */); - bool HandleSlash(int); - bool HandleRelativePosition(std::int64_t); - bool HandleAbsolutePosition(std::int64_t); + +private: + // These are forked from ConnectionState's modes at the beginning + // of each formatted I/O statement so they may be overridden by control + // edit descriptors during the statement. + MutableModes mutableModes_; + FormatControl format_; +}; + +template +class ExternalListIoStatementState + : public ExternalIoStatementState, + public ListDirectedStatementState { +public: + using ExternalIoStatementState::ExternalIoStatementState; + DataEdit GetNextDataEdit(int maxRepeat = 1) { + DataEdit edit; + edit.descriptor = DataEdit::ListDirected; + edit.repeat = maxRepeat; + edit.modes = ExternalIoStatementState::mutableModes(); + return edit; + } +}; + +template +class UnformattedIoStatementState : public ExternalIoStatementState { +public: + using ExternalIoStatementState::ExternalIoStatementState; + int EndIoStatement(); +}; + +class OpenStatementState : public ExternalIoStatementBase { +public: + OpenStatementState(ExternalFileUnit &unit, bool wasExtant, + const char *sourceFile = nullptr, int sourceLine = 0) + : ExternalIoStatementBase{unit, sourceFile, sourceLine}, wasExtant_{ + wasExtant} {} + bool wasExtant() const { return wasExtant_; } + void set_status(OpenStatus status) { status_ = status; } + void set_path(const char *, std::size_t, int kind); // FILE= + void set_position(Position position) { position_ = position; } // POSITION= + int EndIoStatement(); + +private: + bool wasExtant_; + OpenStatus status_{OpenStatus::Unknown}; + Position position_{Position::AsIs}; + OwningPtr path_; + std::size_t pathLength_; +}; + +class CloseStatementState : public ExternalIoStatementBase { +public: + CloseStatementState(ExternalFileUnit &unit, const char *sourceFile = nullptr, + int sourceLine = 0) + : ExternalIoStatementBase{unit, sourceFile, sourceLine} {} + void set_status(CloseStatus status) { status_ = status; } + int EndIoStatement(); + +private: + CloseStatus status_{CloseStatus::Keep}; +}; + +class NoopCloseStatementState : public IoStatementBase { +public: + NoopCloseStatementState(const char *sourceFile, int sourceLine) + : IoStatementBase{sourceFile, sourceLine}, ioStatementState_{*this} {} + IoStatementState &ioStatementState() { return ioStatementState_; } + void set_status(CloseStatus) {} // discards + MutableModes &mutableModes() { return connection_.modes; } + ConnectionState &GetConnectionState() { return connection_; } int EndIoStatement(); private: - ExternalFile &file_; - FormatControl format_; + IoStatementState ioStatementState_; // points to *this + ConnectionState connection_; }; +extern template class InternalIoStatementState; +extern template class InternalIoStatementState; extern template class InternalFormattedIoStatementState; +extern template class InternalFormattedIoStatementState; +extern template class InternalListIoStatementState; +extern template class ExternalIoStatementState; extern template class ExternalFormattedIoStatementState; +extern template class ExternalListIoStatementState; +extern template class UnformattedIoStatementState; +extern template class FormatControl>; +extern template class FormatControl>; +extern template class FormatControl>; } #endif // FORTRAN_RUNTIME_IO_STMT_H_ diff --git a/runtime/lock.h b/runtime/lock.h index 19f0cea79b01..a26c96542c88 100644 --- a/runtime/lock.h +++ b/runtime/lock.h @@ -23,7 +23,7 @@ class Lock { bool Try() { return pthread_mutex_trylock(&mutex_) != 0; } void Drop() { pthread_mutex_unlock(&mutex_); } - void CheckLocked(Terminator &terminator) { + void CheckLocked(const Terminator &terminator) { if (Try()) { Drop(); terminator.Crash("Lock::CheckLocked() failed"); diff --git a/runtime/main.cpp b/runtime/main.cpp index 8c2caa570df5..e7f4200b2777 100644 --- a/runtime/main.cpp +++ b/runtime/main.cpp @@ -33,7 +33,6 @@ void RTNAME(ProgramStart)(int argc, const char *argv[], const char *envp[]) { std::atexit(Fortran::runtime::NotifyOtherImagesOfNormalEnd); Fortran::runtime::executionEnvironment.Configure(argc, argv, envp); ConfigureFloatingPoint(); - Fortran::runtime::Terminator terminator{"ProgramStart()"}; - Fortran::runtime::io::ExternalFile::InitializePredefinedUnits(terminator); + Fortran::runtime::io::ExternalFileUnit::InitializePredefinedUnits(); } } diff --git a/runtime/memory.cpp b/runtime/memory.cpp index ac456a5dd9d1..84fd35da48ef 100644 --- a/runtime/memory.cpp +++ b/runtime/memory.cpp @@ -12,7 +12,7 @@ namespace Fortran::runtime { -void *AllocateMemoryOrCrash(Terminator &terminator, std::size_t bytes) { +void *AllocateMemoryOrCrash(const Terminator &terminator, std::size_t bytes) { if (void *p{std::malloc(bytes)}) { return p; } diff --git a/runtime/memory.h b/runtime/memory.h index d41f5f95407e..1bd5bca1b78a 100644 --- a/runtime/memory.h +++ b/runtime/memory.h @@ -18,8 +18,9 @@ namespace Fortran::runtime { class Terminator; -[[nodiscard]] void *AllocateMemoryOrCrash(Terminator &, std::size_t bytes); -template[[nodiscard]] A &AllocateOrCrash(Terminator &t) { +[[nodiscard]] void *AllocateMemoryOrCrash( + const Terminator &, std::size_t bytes); +template[[nodiscard]] A &AllocateOrCrash(const Terminator &t) { return *reinterpret_cast(AllocateMemoryOrCrash(t, sizeof(A))); } void FreeMemory(void *); @@ -33,7 +34,7 @@ template void FreeMemoryAndNullify(A *&p) { template struct New { template - [[nodiscard]] A &operator()(Terminator &terminator, X &&... x) { + [[nodiscard]] A &operator()(const Terminator &terminator, X &&... x) { return *new (AllocateMemoryOrCrash(terminator, sizeof(A))) A{std::forward(x)...}; } @@ -47,7 +48,7 @@ template using OwningPtr = std::unique_ptr>; template struct Allocator { using value_type = A; - explicit Allocator(Terminator &t) : terminator{t} {} + explicit Allocator(const Terminator &t) : terminator{t} {} template explicit constexpr Allocator(const Allocator &that) noexcept : terminator{that.terminator} {} @@ -58,7 +59,7 @@ template struct Allocator { AllocateMemoryOrCrash(terminator, n * sizeof(A))); } constexpr void deallocate(A *p, std::size_t) { FreeMemory(p); } - Terminator &terminator; + const Terminator &terminator; }; } diff --git a/runtime/numeric-output.cpp b/runtime/numeric-output.cpp new file mode 100644 index 000000000000..daef7aba879a --- /dev/null +++ b/runtime/numeric-output.cpp @@ -0,0 +1,152 @@ +//===-- runtime/numeric-output.cpp ------------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#include "numeric-output.h" +#include "flang/common/unsigned-const-division.h" + +namespace Fortran::runtime::io { + +bool EditIntegerOutput( + IoStatementState &io, const DataEdit &edit, std::int64_t n) { + char buffer[66], *end = &buffer[sizeof buffer], *p = end; + std::uint64_t un{static_cast(n < 0 ? -n : n)}; + int signChars{0}; + switch (edit.descriptor) { + case DataEdit::ListDirected: + case 'G': + case 'I': + if (n < 0 || (edit.modes.editingFlags & signPlus)) { + signChars = 1; // '-' or '+' + } + while (un > 0) { + auto quotient{common::DivideUnsignedBy(un)}; + *--p = '0' + un - 10 * quotient; + un = quotient; + } + break; + case 'B': + for (; un > 0; un >>= 1) { + *--p = '0' + (un & 1); + } + break; + case 'O': + for (; un > 0; un >>= 3) { + *--p = '0' + (un & 7); + } + break; + case 'Z': + for (; un > 0; un >>= 4) { + int digit = un & 0xf; + *--p = digit >= 10 ? 'A' + (digit - 10) : '0' + digit; + } + break; + default: + io.GetIoErrorHandler().Crash( + "Data edit descriptor '%c' may not be used with an INTEGER data item", + edit.descriptor); + return false; + } + + int digits = end - p; + int leadingZeroes{0}; + int editWidth{edit.width.value_or(0)}; + if (edit.digits && digits <= *edit.digits) { // Iw.m + if (*edit.digits == 0 && n == 0) { + // Iw.0 with zero value: output field must be blank. For I0.0 + // and a zero value, emit one blank character. + signChars = 0; // in case of SP + editWidth = std::max(1, editWidth); + } else { + leadingZeroes = *edit.digits - digits; + } + } else if (n == 0) { + leadingZeroes = 1; + } + int total{signChars + leadingZeroes + digits}; + if (editWidth > 0 && total > editWidth) { + return io.EmitRepeated('*', editWidth); + } + int leadingSpaces{std::max(0, editWidth - total)}; + if (edit.IsListDirected()) { + if (static_cast(total) > + io.GetConnectionState().RemainingSpaceInRecord() && + !io.AdvanceRecord()) { + return false; + } + leadingSpaces = 1; + } + return io.EmitRepeated(' ', leadingSpaces) && + io.Emit(n < 0 ? "-" : "+", signChars) && + io.EmitRepeated('0', leadingZeroes) && io.Emit(p, digits); +} + +// Formats the exponent (see table 13.1 for all the cases) +const char *RealOutputEditingBase::FormatExponent( + int expo, const DataEdit &edit, int &length) { + char *eEnd{&exponent_[sizeof exponent_]}; + char *exponent{eEnd}; + for (unsigned e{static_cast(std::abs(expo))}; e > 0;) { + unsigned quotient{common::DivideUnsignedBy(e)}; + *--exponent = '0' + e - 10 * quotient; + e = quotient; + } + if (edit.expoDigits) { + if (int ed{*edit.expoDigits}) { // Ew.dEe with e > 0 + while (exponent > exponent_ + 2 /*E+*/ && exponent + ed > eEnd) { + *--exponent = '0'; + } + } else if (exponent == eEnd) { + *--exponent = '0'; // Ew.dE0 with zero-valued exponent + } + } else { // ensure at least two exponent digits + while (exponent + 2 > eEnd) { + *--exponent = '0'; + } + } + *--exponent = expo < 0 ? '-' : '+'; + if (edit.expoDigits || exponent + 3 == eEnd) { + *--exponent = edit.descriptor == 'D' ? 'D' : 'E'; // not 'G' + } + length = eEnd - exponent; + return exponent; +} + +bool RealOutputEditingBase::EmitPrefix( + const DataEdit &edit, std::size_t length, std::size_t width) { + if (edit.IsListDirected()) { + int prefixLength{edit.descriptor == DataEdit::ListDirectedRealPart + ? 2 + : edit.descriptor == DataEdit::ListDirectedImaginaryPart ? 0 : 1}; + int suffixLength{edit.descriptor == DataEdit::ListDirectedRealPart || + edit.descriptor == DataEdit::ListDirectedImaginaryPart + ? 1 + : 0}; + length += prefixLength + suffixLength; + ConnectionState &connection{io_.GetConnectionState()}; + return (connection.positionInRecord == 0 || + length <= connection.RemainingSpaceInRecord() || + io_.AdvanceRecord()) && + io_.Emit(" (", prefixLength); + } else if (width > length) { + return io_.EmitRepeated(' ', width - length); + } else { + return true; + } +} + +bool RealOutputEditingBase::EmitSuffix(const DataEdit &edit) { + if (edit.descriptor == DataEdit::ListDirectedRealPart) { + return io_.Emit(edit.modes.editingFlags & decimalComma ? ";" : ",", 1); + } else if (edit.descriptor == DataEdit::ListDirectedImaginaryPart) { + return io_.Emit(")", 1); + } else { + return true; + } +} + +} diff --git a/runtime/numeric-output.h b/runtime/numeric-output.h index a0f40c700b7b..f8c5437ca31b 100644 --- a/runtime/numeric-output.h +++ b/runtime/numeric-output.h @@ -14,191 +14,99 @@ // components, I and G for INTEGER, and B/O/Z for both. // See subclauses in 13.7.2.3 of Fortran 2018 for the // detailed specifications of these descriptors. -// Drives the same binary-to-decimal formatting templates used -// by the f18 compiler. +// List-directed output (13.10.4) for numeric types is also done here. +// Drives the same fast binary-to-decimal formatting templates used +// in the f18 front-end. #include "format.h" -#include "flang/common/unsigned-const-division.h" +#include "io-stmt.h" #include "flang/decimal/decimal.h" namespace Fortran::runtime::io { class IoStatementState; -// Utility subroutines -static bool EmitRepeated(IoStatementState &io, char ch, int n) { - while (n-- > 0) { - if (!io.Emit(&ch, 1)) { - return false; - } - } - return true; -} +// I, B, O, Z, and G output editing for INTEGER. +// edit is const here (and elsewhere in this header) so that one +// edit descriptor with a repeat factor may safely serve to edit +// multiple elements of an array. +bool EditIntegerOutput(IoStatementState &, const DataEdit &, std::int64_t); -static bool EmitField( - IoStatementState &io, const char *p, std::size_t length, int width) { - if (width <= 0) { - width = static_cast(length); - } - if (length > static_cast(width)) { - return EmitRepeated(io, '*', width); - } else { - return EmitRepeated(io, ' ', static_cast(width - length)) && - io.Emit(p, length); - } -} +// Encapsulates the state of a REAL output conversion. +class RealOutputEditingBase { +protected: + explicit RealOutputEditingBase(IoStatementState &io) : io_{io} {} -// I, B, O, Z, and (for INTEGER) G output editing. -// edit is const here so that a repeated edit descriptor may safely serve -// multiple array elements -static bool EditIntegerOutput( - IoStatementState &io, const DataEdit &edit, std::int64_t n) { - char buffer[66], *end = &buffer[sizeof buffer], *p = end; - std::uint64_t un{static_cast(n < 0 ? -n : n)}; - int signChars{0}; - switch (edit.descriptor) { - case 'G': - case 'I': - if (n < 0 || (edit.modes.editingFlags & signPlus)) { - signChars = 1; // '-' or '+' - } - while (un > 0) { - auto quotient{common::DivideUnsignedBy(un)}; - *--p = '0' + un - 10 * quotient; - un = quotient; - } - break; - case 'B': - for (; un > 0; un >>= 1) { - *--p = '0' + (un & 1); - } - break; - case 'O': - for (; un > 0; un >>= 3) { - *--p = '0' + (un & 7); + static bool IsDecimalNumber(const char *p) { + if (!p) { + return false; } - break; - case 'Z': - for (; un > 0; un >>= 4) { - int digit = un & 0xf; - *--p = digit >= 10 ? 'A' + (digit - 10) : '0' + digit; + if (*p == '-' || *p == '+') { + ++p; } - break; - default: - io.Crash( - "Data edit descriptor '%c' may not be used with an INTEGER data item", - edit.descriptor); - return false; + return *p >= '0' && *p <= '9'; } - int digits = end - p; - int leadingZeroes{0}; - int editWidth{edit.width.value_or(0)}; - if (edit.digits && digits <= *edit.digits) { // Iw.m - if (*edit.digits == 0 && n == 0) { - // Iw.0 with zero value: output field must be blank. For I0.0 - // and a zero value, emit one blank character. - signChars = 0; // in case of SP - editWidth = std::max(1, editWidth); - } else { - leadingZeroes = *edit.digits - digits; - } - } else if (n == 0) { - leadingZeroes = 1; - } - int total{signChars + leadingZeroes + digits}; - if (edit.width > 0 && total > editWidth) { - return EmitRepeated(io, '*', editWidth); - } - if (total < editWidth) { - EmitRepeated(io, '*', editWidth - total); - return false; - } - if (signChars) { - if (!io.Emit(n < 0 ? "-" : "+", 1)) { - return false; - } - } - return EmitRepeated(io, '0', leadingZeroes) && io.Emit(p, digits); -} + const char *FormatExponent(int, const DataEdit &edit, int &length); + bool EmitPrefix(const DataEdit &, std::size_t length, std::size_t width); + bool EmitSuffix(const DataEdit &); -// Encapsulates the state of a REAL output conversion. -template -class RealOutputEditing { + IoStatementState &io_; + int trailingBlanks_{0}; // created when Gw editing maps to Fw + char exponent_[16]; +}; + +template +class RealOutputEditing : public RealOutputEditingBase { public: - RealOutputEditing(IoStatementState &io, FLOAT x) : io_{io}, x_{x} {} - bool Edit(const DataEdit &edit); + template + RealOutputEditing(IoStatementState &io, A x) + : RealOutputEditingBase{io}, x_{x} {} + bool Edit(const DataEdit &); private: + using BinaryFloatingPoint = + decimal::BinaryFloatingPointNumber; + // The DataEdit arguments here are const references or copies so that - // the original DataEdit can safely serve multiple array elements if + // the original DataEdit can safely serve multiple array elements when // it has a repeat count. bool EditEorDOutput(const DataEdit &); bool EditFOutput(const DataEdit &); DataEdit EditForGOutput(DataEdit); // returns an E or F edit bool EditEXOutput(const DataEdit &); + bool EditListDirectedOutput(const DataEdit &); - bool IsZero() const { return x_ == 0; } - const char *FormatExponent(int, const DataEdit &edit, int &length); - - static enum decimal::FortranRounding SetRounding( - common::RoundingMode rounding) { - switch (rounding) { - case common::RoundingMode::TiesToEven: break; - case common::RoundingMode::Up: return decimal::RoundUp; - case common::RoundingMode::Down: return decimal::RoundDown; - case common::RoundingMode::ToZero: return decimal::RoundToZero; - case common::RoundingMode::TiesAwayFromZero: - return decimal::RoundCompatible; - } - return decimal::RoundNearest; // arranged thus to dodge bogus G++ warning - } - - static bool IsDecimalNumber(const char *p) { - if (!p) { - return false; - } - if (*p == '-' || *p == '+') { - ++p; - } - return *p >= '0' && *p <= '9'; - } + bool IsZero() const { return x_.IsZero(); } decimal::ConversionToDecimalResult Convert( int significantDigits, const DataEdit &, int flags = 0); - IoStatementState &io_; - FLOAT x_; - char buffer_[bufferSize]; - int trailingBlanks_{0}; // created when G editing maps to F - char exponent_[16]; + BinaryFloatingPoint x_; + char buffer_[BinaryFloatingPoint::maxDecimalConversionDigits + + EXTRA_DECIMAL_CONVERSION_SPACE]; }; -template -decimal::ConversionToDecimalResult RealOutputEditing::Convert(int significantDigits, - const DataEdit &edit, int flags) { +template +decimal::ConversionToDecimalResult RealOutputEditing::Convert( + int significantDigits, const DataEdit &edit, int flags) { if (edit.modes.editingFlags & signPlus) { flags |= decimal::AlwaysSign; } - auto converted{decimal::ConvertToDecimal(buffer_, bufferSize, - static_cast(flags), - significantDigits, SetRounding(edit.modes.roundingMode), - decimal::BinaryFloatingPointNumber(x_))}; + auto converted{decimal::ConvertToDecimal(buffer_, + sizeof buffer_, static_cast(flags), + significantDigits, edit.modes.round, x_)}; if (!converted.str) { // overflow - io_.Crash("RealOutputEditing::Convert : buffer size %zd was insufficient", - bufferSize); + io_.GetIoErrorHandler().Crash( + "RealOutputEditing::Convert : buffer size %zd was insufficient", + sizeof buffer_); } return converted; } // 13.7.2.3.3 in F'2018 -template -bool RealOutputEditing::EditEorDOutput(const DataEdit &edit) { +template +bool RealOutputEditing::EditEorDOutput(const DataEdit &edit) { int editDigits{edit.digits.value_or(0)}; // 'd' field int editWidth{edit.width.value_or(0)}; // 'w' field int significantDigits{editDigits}; @@ -209,7 +117,7 @@ bool RealOutputEditing 0 && !IsDecimalNumber(converted.str)) { // Inf, NaN - return EmitField(io_, converted.str, converted.length, editWidth); + return EmitPrefix(edit, converted.length, editWidth) && + io_.Emit(converted.str, converted.length) && EmitSuffix(edit); } if (!IsZero()) { converted.decimalExponent -= scale; @@ -258,63 +167,28 @@ bool RealOutputEditing 0 ? editWidth : totalLength}; if (totalLength > width) { - return EmitRepeated(io_, '*', width); + return io_.EmitRepeated('*', width); } if (totalLength < width && digitsBeforePoint == 0 && zeroesBeforePoint == 0) { zeroesBeforePoint = 1; ++totalLength; } - return EmitRepeated(io_, ' ', width - totalLength) && + return EmitPrefix(edit, totalLength, width) && io_.Emit(converted.str, signLength + digitsBeforePoint) && - EmitRepeated(io_, '0', zeroesBeforePoint) && + io_.EmitRepeated('0', zeroesBeforePoint) && io_.Emit(edit.modes.editingFlags & decimalComma ? "," : ".", 1) && - EmitRepeated(io_, '0', zeroesAfterPoint) && + io_.EmitRepeated('0', zeroesAfterPoint) && io_.Emit( converted.str + signLength + digitsBeforePoint, digitsAfterPoint) && - EmitRepeated(io_, '0', trailingZeroes) && - io_.Emit(exponent, expoLength); - } -} - -// Formats the exponent (see table 13.1 for all the cases) -template -const char *RealOutputEditing::FormatExponent(int expo, const DataEdit &edit, int &length) { - char *eEnd{&exponent_[sizeof exponent_]}; - char *exponent{eEnd}; - for (unsigned e{static_cast(std::abs(expo))}; e > 0;) { - unsigned quotient{common::DivideUnsignedBy(e)}; - *--exponent = '0' + e - 10 * quotient; - e = quotient; - } - if (edit.expoDigits) { - if (int ed{*edit.expoDigits}) { // Ew.dEe with e > 0 - while (exponent > exponent_ + 2 /*E+*/ && exponent + ed > eEnd) { - *--exponent = '0'; - } - } else if (exponent == eEnd) { - *--exponent = '0'; // Ew.dE0 with zero-valued exponent - } - } else { // ensure at least two exponent digits - while (exponent + 2 > eEnd) { - *--exponent = '0'; - } + io_.EmitRepeated('0', trailingZeroes) && + io_.Emit(exponent, expoLength) && EmitSuffix(edit); } - *--exponent = expo < 0 ? '-' : '+'; - if (edit.expoDigits || exponent + 3 == eEnd) { - *--exponent = edit.descriptor == 'D' ? 'D' : 'E'; // not 'G' - } - length = eEnd - exponent; - return exponent; } // 13.7.2.3.2 in F'2018 -template -bool RealOutputEditing::EditFOutput(const DataEdit &edit) { +template +bool RealOutputEditing::EditFOutput(const DataEdit &edit) { int fracDigits{edit.digits.value_or(0)}; // 'd' field int extraDigits{0}; int editWidth{edit.width.value_or(0)}; // 'w' field @@ -322,7 +196,7 @@ bool RealOutputEditing 0 && !IsDecimalNumber(converted.str)) { // Inf, NaN - return EmitField(io_, converted.str, converted.length, editWidth); + return EmitPrefix(edit, converted.length, editWidth) && + io_.Emit(converted.str, converted.length) && EmitSuffix(edit); } int scale{IsZero() ? -1 : edit.modes.scale}; int expo{converted.decimalExponent - scale}; if (expo > extraDigits) { extraDigits = expo; if (flags & decimal::Minimize) { - fracDigits = bufferSize - extraDigits - 2; // sign & NUL + fracDigits = sizeof buffer_ - extraDigits - 2; // sign & NUL } continue; // try again } @@ -360,29 +235,27 @@ bool RealOutputEditing 0 ? editWidth : totalLength}; if (totalLength > width) { - return EmitRepeated(io_, '*', width); + return io_.EmitRepeated('*', width); } if (totalLength < width && digitsBeforePoint + zeroesBeforePoint == 0) { zeroesBeforePoint = 1; ++totalLength; } - return EmitRepeated(io_, ' ', width - totalLength) && + return EmitPrefix(edit, totalLength, width) && io_.Emit(converted.str, signLength + digitsBeforePoint) && - EmitRepeated(io_, '0', zeroesBeforePoint) && + io_.EmitRepeated('0', zeroesBeforePoint) && io_.Emit(edit.modes.editingFlags & decimalComma ? "," : ".", 1) && - EmitRepeated(io_, '0', zeroesAfterPoint) && + io_.EmitRepeated('0', zeroesAfterPoint) && io_.Emit( converted.str + signLength + digitsBeforePoint, digitsAfterPoint) && - EmitRepeated(io_, '0', trailingZeroes) && - EmitRepeated(io_, ' ', trailingBlanks_); + io_.EmitRepeated('0', trailingZeroes) && + io_.EmitRepeated(' ', trailingBlanks_) && EmitSuffix(edit); } } // 13.7.5.2.3 in F'2018 -template -DataEdit RealOutputEditing::EditForGOutput(DataEdit edit) { +template +DataEdit RealOutputEditing::EditForGOutput(DataEdit edit) { edit.descriptor = 'E'; if (!edit.width.has_value() || (*edit.width > 0 && edit.digits.value_or(-1) == 0)) { @@ -393,7 +266,8 @@ DataEdit RealOutputEditing significantDigits) { return edit; // Ew.d } @@ -412,18 +286,32 @@ DataEdit RealOutputEditing +bool RealOutputEditing::EditListDirectedOutput( + const DataEdit &edit) { + decimal::ConversionToDecimalResult converted{Convert(1, edit)}; + if (!IsDecimalNumber(converted.str)) { // Inf, NaN + return EditEorDOutput(edit); + } + int expo{converted.decimalExponent}; + if (expo < 0 || expo > BinaryFloatingPoint::decimalPrecision) { + DataEdit copy{edit}; + copy.modes.scale = 1; // 1P + return EditEorDOutput(copy); + } + return EditFOutput(edit); +} + // 13.7.5.2.6 in F'2018 -template -bool RealOutputEditing::EditEXOutput(const DataEdit &) { - io_.Crash("EX output editing is not yet implemented"); // TODO +template +bool RealOutputEditing::EditEXOutput(const DataEdit &) { + io_.GetIoErrorHandler().Crash( + "EX output editing is not yet implemented"); // TODO } -template -bool RealOutputEditing::Edit(const DataEdit &edit) { +template +bool RealOutputEditing::Edit(const DataEdit &edit) { switch (edit.descriptor) { case 'D': return EditEorDOutput(edit); case 'E': @@ -436,14 +324,20 @@ bool RealOutputEditing{x_}.raw); + return EditIntegerOutput( + io_, edit, decimal::BinaryFloatingPointNumber{x_}.raw); case 'G': return Edit(EditForGOutput(edit)); default: - io_.Crash("Data edit descriptor '%c' may not be used with a REAL data item", + if (edit.IsListDirected()) { + return EditListDirectedOutput(edit); + } + io_.GetIoErrorHandler().Crash( + "Data edit descriptor '%c' may not be used with a REAL data item", edit.descriptor); return false; } return false; } + } #endif // FORTRAN_RUNTIME_NUMERIC_OUTPUT_H_ diff --git a/runtime/stop.cpp b/runtime/stop.cpp index 85bf9c4a14ac..46ad558dfe4c 100644 --- a/runtime/stop.cpp +++ b/runtime/stop.cpp @@ -71,7 +71,7 @@ static void DescribeIEEESignaledExceptions() { [[noreturn]] void RTNAME(ProgramEndStatement)() { Fortran::runtime::io::IoErrorHandler handler{"END statement"}; - Fortran::runtime::io::ExternalFile::CloseAll(handler); + Fortran::runtime::io::ExternalFileUnit::CloseAll(handler); std::exit(EXIT_SUCCESS); } } diff --git a/runtime/terminator.cpp b/runtime/terminator.cpp index c516af3c854a..74594ba65d84 100644 --- a/runtime/terminator.cpp +++ b/runtime/terminator.cpp @@ -12,13 +12,14 @@ namespace Fortran::runtime { -[[noreturn]] void Terminator::Crash(const char *message, ...) { +[[noreturn]] void Terminator::Crash(const char *message, ...) const { va_list ap; va_start(ap, message); CrashArgs(message, ap); } -[[noreturn]] void Terminator::CrashArgs(const char *message, va_list &ap) { +[[noreturn]] void Terminator::CrashArgs( + const char *message, va_list &ap) const { std::fputs("\nfatal Fortran runtime error", stderr); if (sourceFileName_) { std::fprintf(stderr, "(%s", sourceFileName_); @@ -31,23 +32,19 @@ namespace Fortran::runtime { std::vfprintf(stderr, message, ap); fputc('\n', stderr); va_end(ap); + io::FlushOutputOnCrash(*this); NotifyOtherImagesOfErrorTermination(); std::abort(); } [[noreturn]] void Terminator::CheckFailed( - const char *predicate, const char *file, int line) { + const char *predicate, const char *file, int line) const { Crash("Internal error: RUNTIME_CHECK(%s) failed at %s(%d)", predicate, file, line); } -void NotifyOtherImagesOfNormalEnd() { - // TODO -} -void NotifyOtherImagesOfFailImageStatement() { - // TODO -} -void NotifyOtherImagesOfErrorTermination() { - // TODO -} +// TODO: These will be defined in the coarray runtime library +void NotifyOtherImagesOfNormalEnd() {} +void NotifyOtherImagesOfFailImageStatement() {} +void NotifyOtherImagesOfErrorTermination() {} } diff --git a/runtime/terminator.h b/runtime/terminator.h index 5fe381e5167a..8cfc5cc8b123 100644 --- a/runtime/terminator.h +++ b/runtime/terminator.h @@ -21,16 +21,17 @@ namespace Fortran::runtime { class Terminator { public: Terminator() {} + Terminator(const Terminator &) = default; explicit Terminator(const char *sourceFileName, int sourceLine = 0) : sourceFileName_{sourceFileName}, sourceLine_{sourceLine} {} void SetLocation(const char *sourceFileName = nullptr, int sourceLine = 0) { sourceFileName_ = sourceFileName; sourceLine_ = sourceLine; } - [[noreturn]] void Crash(const char *message, ...); - [[noreturn]] void CrashArgs(const char *message, va_list &); + [[noreturn]] void Crash(const char *message, ...) const; + [[noreturn]] void CrashArgs(const char *message, va_list &) const; [[noreturn]] void CheckFailed( - const char *predicate, const char *file, int line); + const char *predicate, const char *file, int line) const; private: const char *sourceFileName_{nullptr}; @@ -47,4 +48,9 @@ void NotifyOtherImagesOfNormalEnd(); void NotifyOtherImagesOfFailImageStatement(); void NotifyOtherImagesOfErrorTermination(); } + +namespace Fortran::runtime::io { +void FlushOutputOnCrash(const Terminator &); +} + #endif // FORTRAN_RUNTIME_TERMINATOR_H_ diff --git a/runtime/tools.cpp b/runtime/tools.cpp index 43a0f68b0fe8..b254baf07b46 100644 --- a/runtime/tools.cpp +++ b/runtime/tools.cpp @@ -12,7 +12,7 @@ namespace Fortran::runtime { OwningPtr SaveDefaultCharacter( - const char *s, std::size_t length, Terminator &terminator) { + const char *s, std::size_t length, const Terminator &terminator) { if (s) { auto *p{static_cast(AllocateMemoryOrCrash(terminator, length + 1))}; std::memcpy(p, s, length); diff --git a/runtime/tools.h b/runtime/tools.h index d1b90b1ad3c9..99571782dc07 100644 --- a/runtime/tools.h +++ b/runtime/tools.h @@ -18,7 +18,8 @@ namespace Fortran::runtime { class Terminator; -OwningPtr SaveDefaultCharacter(const char *, std::size_t, Terminator &); +OwningPtr SaveDefaultCharacter( + const char *, std::size_t, const Terminator &); // For validating and recognizing default CHARACTER values in a // case-insensitive manner. Returns the zero-based index into the diff --git a/runtime/unit.cpp b/runtime/unit.cpp index f7a342ccbb73..277d36b39a08 100644 --- a/runtime/unit.cpp +++ b/runtime/unit.cpp @@ -10,55 +10,98 @@ #include "lock.h" #include "memory.h" #include "tools.h" -#include +#include #include namespace Fortran::runtime::io { static Lock mapLock; static Terminator mapTerminator; -static Map unitMap{MapAllocator{mapTerminator}}; +static Map unitMap{ + MapAllocator{mapTerminator}}; +static ExternalFileUnit *defaultOutput{nullptr}; + +void FlushOutputOnCrash(const Terminator &terminator) { + if (defaultOutput) { + IoErrorHandler handler{terminator}; + handler.HasIoStat(); // prevent nested crash if flush has error + defaultOutput->Flush(handler); + } +} -ExternalFile *ExternalFile::LookUp(int unit) { +ExternalFileUnit *ExternalFileUnit::LookUp(int unit) { CriticalSection criticalSection{mapLock}; auto iter{unitMap.find(unit)}; return iter == unitMap.end() ? nullptr : &iter->second; } -ExternalFile &ExternalFile::LookUpOrCrash(int unit, Terminator &terminator) { +ExternalFileUnit &ExternalFileUnit::LookUpOrCrash( + int unit, const Terminator &terminator) { CriticalSection criticalSection{mapLock}; - ExternalFile *file{LookUp(unit)}; + ExternalFileUnit *file{LookUp(unit)}; if (!file) { terminator.Crash("Not an open I/O unit number: %d", unit); } return *file; } -ExternalFile &ExternalFile::Create(int unit, Terminator &terminator) { +ExternalFileUnit &ExternalFileUnit::LookUpOrCreate(int unit, bool *wasExtant) { CriticalSection criticalSection{mapLock}; auto pair{unitMap.emplace(unit, unit)}; - if (!pair.second) { - terminator.Crash("Already opened I/O unit number: %d", unit); + if (wasExtant) { + *wasExtant = !pair.second; } return pair.first->second; } -void ExternalFile::CloseUnit(IoErrorHandler &handler) { +int ExternalFileUnit::NewUnit() { + CriticalSection criticalSection{mapLock}; + static int nextNewUnit{-1000}; // see 12.5.6.12 in Fortran 2018 + return --nextNewUnit; +} + +void ExternalFileUnit::OpenUnit(OpenStatus status, Position position, + OwningPtr &&newPath, std::size_t newPathLength, + IoErrorHandler &handler) { + CriticalSection criticalSection{lock()}; + if (IsOpen()) { + if (status == OpenStatus::Old && + (!newPath.get() || + (path() && pathLength() == newPathLength && + std::memcmp(path(), newPath.get(), newPathLength) == 0))) { + // OPEN of existing unit, STATUS='OLD', not new FILE= + newPath.reset(); + return; + } + // Otherwise, OPEN on open unit with new FILE= implies CLOSE + Flush(handler); + Close(CloseStatus::Keep, handler); + } + set_path(std::move(newPath), newPathLength); + Open(status, position, handler); +} + +void ExternalFileUnit::CloseUnit(CloseStatus status, IoErrorHandler &handler) { + { + CriticalSection criticalSection{lock()}; + Flush(handler); + Close(status, handler); + } CriticalSection criticalSection{mapLock}; - Flush(handler); auto iter{unitMap.find(unitNumber_)}; if (iter != unitMap.end()) { unitMap.erase(iter); } } -void ExternalFile::InitializePredefinedUnits(Terminator &terminator) { - ExternalFile &out{ExternalFile::Create(6, terminator)}; +void ExternalFileUnit::InitializePredefinedUnits() { + ExternalFileUnit &out{ExternalFileUnit::LookUpOrCreate(6)}; out.Predefine(1); out.set_mayRead(false); out.set_mayWrite(true); out.set_mayPosition(false); - ExternalFile &in{ExternalFile::Create(5, terminator)}; + defaultOutput = &out; + ExternalFileUnit &in{ExternalFileUnit::LookUpOrCreate(5)}; in.Predefine(0); in.set_mayRead(true); in.set_mayWrite(false); @@ -66,18 +109,20 @@ void ExternalFile::InitializePredefinedUnits(Terminator &terminator) { // TODO: Set UTF-8 mode from the environment } -void ExternalFile::CloseAll(IoErrorHandler &handler) { +void ExternalFileUnit::CloseAll(IoErrorHandler &handler) { CriticalSection criticalSection{mapLock}; + defaultOutput = nullptr; while (!unitMap.empty()) { auto &pair{*unitMap.begin()}; - pair.second.CloseUnit(handler); + pair.second.CloseUnit(CloseStatus::Keep, handler); } } -bool ExternalFile::SetPositionInRecord(std::int64_t n, IoErrorHandler &handler) { - n = std::max(std::int64_t{0}, n); +bool ExternalFileUnit::SetPositionInRecord( + std::int64_t n, IoErrorHandler &handler) { + n = std::max(0, n); bool ok{true}; - if (n > recordLength.value_or(n)) { + if (n > static_cast(recordLength.value_or(n))) { handler.SignalEor(); n = *recordLength; ok = false; @@ -85,7 +130,8 @@ bool ExternalFile::SetPositionInRecord(std::int64_t n, IoErrorHandler &handler) if (n > furthestPositionInRecord) { if (!isReading_ && ok) { WriteFrame(recordOffsetInFile, n, handler); - std::fill_n(Frame() + furthestPositionInRecord, n - furthestPositionInRecord, ' '); + std::fill_n(Frame() + furthestPositionInRecord, + n - furthestPositionInRecord, ' '); } furthestPositionInRecord = n; } @@ -93,8 +139,10 @@ bool ExternalFile::SetPositionInRecord(std::int64_t n, IoErrorHandler &handler) return ok; } -bool ExternalFile::Emit(const char *data, std::size_t bytes, IoErrorHandler &handler) { - auto furthestAfter{std::max(furthestPositionInRecord, positionInRecord + static_cast(bytes))}; +bool ExternalFileUnit::Emit( + const char *data, std::size_t bytes, IoErrorHandler &handler) { + auto furthestAfter{std::max(furthestPositionInRecord, + positionInRecord + static_cast(bytes))}; WriteFrame(recordOffsetInFile, furthestAfter, handler); std::memcpy(Frame() + positionInRecord, data, bytes); positionInRecord += bytes; @@ -102,36 +150,46 @@ bool ExternalFile::Emit(const char *data, std::size_t bytes, IoErrorHandler &han return true; } -void ExternalFile::SetLeftTabLimit() { +void ExternalFileUnit::SetLeftTabLimit() { leftTabLimit = furthestPositionInRecord; positionInRecord = furthestPositionInRecord; } -bool ExternalFile::NextOutputRecord(IoErrorHandler &handler) { +bool ExternalFileUnit::AdvanceRecord(IoErrorHandler &handler) { bool ok{true}; if (recordLength.has_value()) { // fill fixed-size record ok &= SetPositionInRecord(*recordLength, handler); - } else if (!unformatted && !isReading_) { + } else if (!isUnformatted && !isReading_) { ok &= SetPositionInRecord(furthestPositionInRecord, handler) && - Emit("\n", 1, handler); + Emit("\n", 1, handler); } recordOffsetInFile += furthestPositionInRecord; ++currentRecordNumber; positionInRecord = 0; - positionInRecord = furthestPositionInRecord = 0; + furthestPositionInRecord = 0; leftTabLimit.reset(); return ok; } -bool ExternalFile::HandleAbsolutePosition(std::int64_t n, IoErrorHandler &handler) { - return SetPositionInRecord(std::max(n, std::int64_t{0}) + leftTabLimit.value_or(0), handler); +bool ExternalFileUnit::HandleAbsolutePosition( + std::int64_t n, IoErrorHandler &handler) { + return SetPositionInRecord( + std::max(n, std::int64_t{0}) + leftTabLimit.value_or(0), handler); } -bool ExternalFile::HandleRelativePosition(std::int64_t n, IoErrorHandler &handler) { +bool ExternalFileUnit::HandleRelativePosition( + std::int64_t n, IoErrorHandler &handler) { return HandleAbsolutePosition(positionInRecord + n, handler); } -void ExternalFile::EndIoStatement() { +void ExternalFileUnit::FlushIfTerminal(IoErrorHandler &handler) { + if (isTerminal()) { + Flush(handler); + } +} + +void ExternalFileUnit::EndIoStatement() { + io_.reset(); u_.emplace(); } } diff --git a/runtime/unit.h b/runtime/unit.h index a6b80b22587e..62f664b8f32a 100644 --- a/runtime/unit.h +++ b/runtime/unit.h @@ -6,13 +6,13 @@ // //===----------------------------------------------------------------------===// -// Fortran I/O units +// Fortran external I/O units #ifndef FORTRAN_RUNTIME_IO_UNIT_H_ #define FORTRAN_RUNTIME_IO_UNIT_H_ #include "buffer.h" -#include "descriptor.h" +#include "connection.h" #include "file.h" #include "format.h" #include "io-error.h" @@ -27,87 +27,57 @@ namespace Fortran::runtime::io { -enum class Access { Sequential, Direct, Stream }; - -inline bool IsRecordFile(Access a) { return a != Access::Stream; } - -// These characteristics of a connection are immutable after being -// established in an OPEN statement. -struct ConnectionAttributes { - Access access{Access::Sequential}; // ACCESS='SEQUENTIAL', 'DIRECT', 'STREAM' - std::optional recordLength; // RECL= when fixed-length - bool unformatted{false}; // FORM='UNFORMATTED' - bool isUTF8{false}; // ENCODING='UTF-8' - bool asynchronousAllowed{false}; // ASYNCHRONOUS='YES' -}; - -struct ConnectionState : public ConnectionAttributes { - // Positions in a record file (sequential or direct, but not stream) - std::int64_t recordOffsetInFile{0}; - std::int64_t currentRecordNumber{1}; // 1 is first - std::int64_t positionInRecord{0}; // offset in current record - std::int64_t furthestPositionInRecord{0}; // max(positionInRecord) - std::optional leftTabLimit; // offset in current record - // nextRecord value captured after ENDFILE/REWIND/BACKSPACE statement - // on a sequential access file - std::optional endfileRecordNumber; - // Mutable modes set at OPEN() that can be overridden in READ/WRITE & FORMAT - MutableModes modes; // BLANK=, DECIMAL=, SIGN=, ROUND=, PAD=, DELIM=, kP -}; - -class InternalUnit : public ConnectionState, public IoErrorHandler { +class ExternalFileUnit : public ConnectionState, + public OpenFile, + public FileFrame { public: - InternalUnit(Descriptor &, const char *sourceFile, int sourceLine) - : IoErrorHandler{sourceFile, sourceLine} { -// TODO pmk descriptor_.Establish(...); - descriptor_.GetLowerBounds(at_); - recordLength = descriptor_.ElementBytes(); - endfileRecordNumber = descriptor_.Elements(); - } - ~InternalUnit() { - if (!doNotFree_) { - std::free(this); - } - } + explicit ExternalFileUnit(int unitNumber) : unitNumber_{unitNumber} {} + int unitNumber() const { return unitNumber_; } -private: - bool doNotFree_{false}; - Descriptor descriptor_; - SubscriptValue at_[maxRank]; -}; - -class ExternalFile : public ConnectionState, // TODO: privatize these - public OpenFile, - public FileFrame { -public: - explicit ExternalFile(int unitNumber) : unitNumber_{unitNumber} {} - static ExternalFile *LookUp(int unit); - static ExternalFile &LookUpOrCrash(int unit, Terminator &); - static ExternalFile &Create(int unit, Terminator &); - static void InitializePredefinedUnits(Terminator &); + static ExternalFileUnit *LookUp(int unit); + static ExternalFileUnit &LookUpOrCrash(int unit, const Terminator &); + static ExternalFileUnit &LookUpOrCreate(int unit, bool *wasExtant = nullptr); + static int NewUnit(); + static void InitializePredefinedUnits(); static void CloseAll(IoErrorHandler &); - void CloseUnit(IoErrorHandler &); + void OpenUnit(OpenStatus, Position, OwningPtr &&path, + std::size_t pathLength, IoErrorHandler &); + void CloseUnit(CloseStatus, IoErrorHandler &); - // TODO: accessors & mutators for many OPEN() specifiers - template A &BeginIoStatement(X&&... xs) { - // TODO: lock_.Take() here, and keep it until EndIoStatement()? + template + IoStatementState &BeginIoStatement(X &&... xs) { + // TODO: lock().Take() here, and keep it until EndIoStatement()? // Nested I/O from derived types wouldn't work, though. - return u_.emplace(std::forward(xs)...); + A &state{u_.emplace(std::forward(xs)...)}; + if constexpr (!std::is_same_v) { + state.mutableModes() = ConnectionState::modes; + } + io_.emplace(state); + return *io_; } - void EndIoStatement(); - bool SetPositionInRecord(std::int64_t, IoErrorHandler &); bool Emit(const char *, std::size_t bytes, IoErrorHandler &); void SetLeftTabLimit(); - bool NextOutputRecord(IoErrorHandler &); + bool AdvanceRecord(IoErrorHandler &); bool HandleAbsolutePosition(std::int64_t, IoErrorHandler &); bool HandleRelativePosition(std::int64_t, IoErrorHandler &); + + void FlushIfTerminal(IoErrorHandler &); + void EndIoStatement(); + private: + bool SetPositionInRecord(std::int64_t, IoErrorHandler &); + int unitNumber_{-1}; - Lock lock_; bool isReading_{false}; - std::variant> u_; + // When an I/O statement is in progress on this unit, holds its state. + std::variant, + ExternalListIoStatementState, UnformattedIoStatementState> + u_; + // Points to the active alternative, if any, in u_, for use as a Cookie + std::optional io_; }; } diff --git a/test/evaluate/real.cpp b/test/evaluate/real.cpp index 919bc3ca87c7..85101e513726 100644 --- a/test/evaluate/real.cpp +++ b/test/evaluate/real.cpp @@ -91,7 +91,7 @@ template void basicTests(int rm, Rounding rounding) { TEST(nan.Compare(zero) == Relation::Unordered)(desc); TEST(nan.Compare(minusZero) == Relation::Unordered)(desc); TEST(nan.Compare(nan) == Relation::Unordered)(desc); - int significandBits{R::precision - R::implicitMSB}; + int significandBits{R::binaryPrecision - R::isImplicitMSB}; int exponentBits{R::bits - significandBits - 1}; std::uint64_t maxExponent{(std::uint64_t{1} << exponentBits) - 1}; MATCH(nan.Exponent(), maxExponent)(desc); diff --git a/test/runtime/external-hello.cpp b/test/runtime/external-hello.cpp index af7151f6c44e..400d345e1b39 100644 --- a/test/runtime/external-hello.cpp +++ b/test/runtime/external-hello.cpp @@ -6,9 +6,20 @@ using namespace Fortran::runtime::io; int main(int argc, const char *argv[], const char *envp[]) { - static const char *format{"(12HHELLO, WORLD)"}; RTNAME(ProgramStart)(argc, argv, envp); - auto *io{IONAME(BeginExternalFormattedOutput)(format, std::strlen(format))}; + auto *io{IONAME(BeginExternalListOutput)()}; + const char str[]{"Hello, world!"}; + IONAME(OutputAscii)(io, str, std::strlen(str)); + IONAME(OutputInteger64)(io, 678); + IONAME(OutputReal64)(io, 0.0); + IONAME(OutputReal64)(io, 2.0 / 3.0); + IONAME(OutputReal64)(io, 1.0e99); + IONAME(OutputReal64)(io, 1.0 / 0.0); + IONAME(OutputReal64)(io, -1.0 / 0.0); + IONAME(OutputReal64)(io, 0.0 / 0.0); + IONAME(OutputComplex64)(io, 123.0, -234.0); + IONAME(OutputLogical)(io, false); + IONAME(OutputLogical)(io, true); IONAME(EndIoStatement)(io); RTNAME(ProgramEndStatement)(); return 0; diff --git a/test/runtime/format.cpp b/test/runtime/format.cpp index 31e3261d8f88..05ec9d3e280b 100644 --- a/test/runtime/format.cpp +++ b/test/runtime/format.cpp @@ -1,37 +1,43 @@ // Tests basic FORMAT string traversal -#include "../runtime/format.h" +#include "../runtime/format-implementation.h" #include "../runtime/terminator.h" #include #include #include -#include #include +#include using namespace Fortran::runtime; using namespace Fortran::runtime::io; using namespace std::literals::string_literals; static int failures{0}; -using Results = std::list; +using Results = std::vector; -// Test harness context for format control -struct TestFormatContext : virtual public Terminator, public FormatContext { +// A test harness context for testing FormatControl +class TestFormatContext : public Terminator { +public: + using CharType = char; TestFormatContext() : Terminator{"format.cpp", 1} {} bool Emit(const char *, std::size_t); bool Emit(const char16_t *, std::size_t); bool Emit(const char32_t *, std::size_t); - bool HandleSlash(int = 1); + bool AdvanceRecord(int = 1); bool HandleRelativePosition(std::int64_t); bool HandleAbsolutePosition(std::int64_t); void Report(const DataEdit &); void Check(Results &); Results results; + MutableModes &mutableModes() { return mutableModes_; } + +private: + MutableModes mutableModes_; }; // Override the runtime's Crash() for testing purposes [[noreturn]] void Fortran::runtime::Terminator::Crash( - const char *message, ...) { + const char *message, ...) const { std::va_list ap; va_start(ap, message); char buffer[1000]; @@ -54,7 +60,7 @@ bool TestFormatContext::Emit(const char32_t *, std::size_t) { return false; } -bool TestFormatContext::HandleSlash(int n) { +bool TestFormatContext::AdvanceRecord(int n) { while (n-- > 0) { results.emplace_back("/"); } @@ -115,12 +121,11 @@ void TestFormatContext::Check(Results &expect) { static void Test(int n, const char *format, Results &&expect, int repeat = 1) { TestFormatContext context; - FormatControl control{context, format, std::strlen(format)}; + FormatControl control{ + context, format, std::strlen(format)}; try { for (int j{0}; j < n; ++j) { - DataEdit edit; - control.GetNext(context, edit, repeat); - context.Report(edit); + context.Report(control.GetNextDataEdit(context, repeat)); } control.FinishOutput(context); } catch (const std::string &crash) { diff --git a/test/runtime/hello.cpp b/test/runtime/hello.cpp index 86354a36de5e..4bb65acd565e 100644 --- a/test/runtime/hello.cpp +++ b/test/runtime/hello.cpp @@ -1,9 +1,11 @@ // Basic sanity tests of I/O API; exhaustive testing will be done in Fortran +#include "../../runtime/descriptor.h" #include "../../runtime/io-api.h" #include #include +using namespace Fortran::runtime; using namespace Fortran::runtime::io; static int failures{0}; @@ -28,7 +30,7 @@ static void hello() { IONAME(OutputInteger64)(cookie, 0xfeedface); IONAME(OutputLogical)(cookie, true); if (auto status{IONAME(EndIoStatement)(cookie)}) { - std::cerr << '\'' << format << "' failed, status " + std::cerr << "hello: '" << format << "' failed, status " << static_cast(status) << '\n'; ++failures; } else { @@ -37,6 +39,49 @@ static void hello() { } } +static void multiline() { + char buffer[4][32]; + StaticDescriptor<1> staticDescriptor[2]; + Descriptor &whole{staticDescriptor[0].descriptor()}; + SubscriptValue extent[]{4}; + whole.Establish(TypeCode{CFI_type_char}, sizeof buffer[0], &buffer, 1, extent, + CFI_attribute_pointer); + // whole.Dump(std::cout); + whole.Check(); + Descriptor §ion{staticDescriptor[1].descriptor()}; + SubscriptValue lowers[]{0}, uppers[]{3}, strides[]{1}; + section.Establish(whole.type(), whole.ElementBytes(), nullptr, 1, extent, + CFI_attribute_pointer); + // section.Dump(std::cout); + section.Check(); + if (auto error{ + CFI_section(§ion.raw(), &whole.raw(), lowers, uppers, strides)}) { + std::cerr << "multiline: CFI_section failed: " << error << '\n'; + ++failures; + return; + } + section.Dump(std::cout); + section.Check(); + const char *format{"('?abcde,',T1,'>',T9,A,TL12,A,TR25,'<'//G0,25X,'done')"}; + auto cookie{IONAME(BeginInternalArrayFormattedOutput)( + section, format, std::strlen(format))}; + IONAME(OutputAscii)(cookie, "WORLD", 5); + IONAME(OutputAscii)(cookie, "HELLO", 5); + IONAME(OutputInteger64)(cookie, 789); + if (auto status{IONAME(EndIoStatement)(cookie)}) { + std::cerr << "multiline: '" << format << "' failed, status " + << static_cast(status) << '\n'; + ++failures; + } else { + test(format, + ">HELLO, WORLD <" + " " + "789 done" + " ", + std::string{buffer[0], sizeof buffer}); + } +} + static void realTest(const char *format, double x, const char *expect) { char buffer[800]; auto cookie{IONAME(BeginInternalFormattedOutput)( @@ -53,6 +98,7 @@ static void realTest(const char *format, double x, const char *expect) { int main() { hello(); + multiline(); static const char *zeroes[][2]{ {"(E32.17,';')", " 0.00000000000000000E+00;"}, From 403faf847d0beacac26421bc82318aaef0e973c9 Mon Sep 17 00:00:00 2001 From: David Truby Date: Fri, 14 Feb 2020 04:46:29 +0000 Subject: [PATCH 15/18] Add zlib to drone files so that linking LLVM works. (#983) --- .drone.star | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.drone.star b/.drone.star index f08549f289d1..5911a5b15bc4 100644 --- a/.drone.star +++ b/.drone.star @@ -7,7 +7,7 @@ def clang(arch): "name": "test", "image": "ubuntu", "commands": [ - "apt-get update && apt-get install -y clang-8 cmake ninja-build lld-8 llvm-dev libc++-8-dev libc++abi-8-dev", + "apt-get update && apt-get install -y clang-8 cmake ninja-build lld-8 llvm-dev libc++-8-dev libc++abi-8-dev libz-dev", "mkdir build && cd build", 'env CC=clang-8 CXX=clang++-8 CXXFLAGS="-UNDEBUG -stdlib=libc++" LDFLAGS="-fuse-ld=lld" cmake -GNinja -DCMAKE_BUILD_TYPE=Release ..', "ninja -j8", @@ -27,7 +27,7 @@ def gcc(arch): "name": "test", "image": "gcc", "commands": [ - "apt-get update && apt-get install -y cmake ninja-build llvm-dev", + "apt-get update && apt-get install -y cmake ninja-build llvm-dev libz-dev", "mkdir build && cd build", 'env CC=gcc CXX=g++ CXXFLAGS="-UNDEBUG" LDFLAGS="-fuse-ld=gold" cmake -GNinja -DCMAKE_BUILD_TYPE=Release ..', "ninja -j8", From 5dd0b0bbe811a908374b2907bb38c75ca76127d2 Mon Sep 17 00:00:00 2001 From: Pete Steinfeld Date: Tue, 11 Feb 2020 12:14:04 -0800 Subject: [PATCH 16/18] Semantic check for C708 An entity declared with the CLASS keyword shall be a dummy argument or have the ALLOCATABLE or POINTER attribute. Implementing this check revealed a problem in the test resolve44.cpp. It also showed that we were doing semantic checking on the entities created by the compiler for LOCAL and LOCAL_INIT locality-specs. So I changed the creation of symbols associated with LOCAL and LOCAL_INIT locality-specs to be host associated with the outer symbol rather than new object entities. In the process, I also changed things so that the `parser::Name` associated with the newly created symbols was set to the symbol rather than being set to nullptr. --- lib/semantics/check-declarations.cpp | 8 ++++++++ lib/semantics/resolve-names.cpp | 8 ++------ test/semantics/CMakeLists.txt | 1 + test/semantics/allocate01.f90 | 3 ++- test/semantics/allocate09.f90 | 8 +++++--- test/semantics/resolve44.f90 | 3 +++ test/semantics/resolve70.f90 | 4 ++-- test/semantics/resolve71.f90 | 23 +++++++++++++++++++++++ test/semantics/symbol09.f90 | 4 ++-- 9 files changed, 48 insertions(+), 14 deletions(-) create mode 100644 test/semantics/resolve71.f90 diff --git a/lib/semantics/check-declarations.cpp b/lib/semantics/check-declarations.cpp index 7cd81c91c348..57f4d788bcc7 100644 --- a/lib/semantics/check-declarations.cpp +++ b/lib/semantics/check-declarations.cpp @@ -371,6 +371,14 @@ void CheckHelper::CheckObjectEntity( } } } + if (const DeclTypeSpec * type{details.type()}) { // C708 + if (type->IsPolymorphic() && + !(IsAllocatableOrPointer(symbol) || symbol.IsDummy())) { + messages_.Say("CLASS entity '%s' must be a dummy argument or have " + "ALLOCATABLE or POINTER attribute"_err_en_US, + symbol.name()); + } + } } // The six different kinds of array-specs: diff --git a/lib/semantics/resolve-names.cpp b/lib/semantics/resolve-names.cpp index f075fa30a4b8..61e9ed02711d 100644 --- a/lib/semantics/resolve-names.cpp +++ b/lib/semantics/resolve-names.cpp @@ -4314,12 +4314,8 @@ Symbol *DeclarationVisitor::DeclareLocalEntity(const parser::Name &name) { if (!PassesLocalityChecks(name, prev)) { return nullptr; } - name.symbol = nullptr; - Symbol &symbol{DeclareEntity(name, {})}; - if (auto *type{prev.GetType()}) { - symbol.SetType(*type); - symbol.set(Symbol::Flag::Implicit, prev.test(Symbol::Flag::Implicit)); - } + Symbol &symbol{MakeSymbol(name, HostAssocDetails{prev})}; + name.symbol = &symbol; return &symbol; } diff --git a/test/semantics/CMakeLists.txt b/test/semantics/CMakeLists.txt index 4873a0f50ebd..c29282442cd9 100644 --- a/test/semantics/CMakeLists.txt +++ b/test/semantics/CMakeLists.txt @@ -101,6 +101,7 @@ set(ERROR_TESTS resolve68.f90 resolve69.f90 resolve70.f90 + resolve71.f90 stop01.f90 structconst01.f90 structconst02.f90 diff --git a/test/semantics/allocate01.f90 b/test/semantics/allocate01.f90 index 137286e47cf6..6944e2b30090 100644 --- a/test/semantics/allocate01.f90 +++ b/test/semantics/allocate01.f90 @@ -16,7 +16,8 @@ module m contains function mfoo(x) - class(a_type) :: foo, x + class(a_type) :: x + class(a_type), allocatable :: foo foo = x end function subroutine mbar(x) diff --git a/test/semantics/allocate09.f90 b/test/semantics/allocate09.f90 index 49736f905743..e47cd8134b49 100644 --- a/test/semantics/allocate09.f90 +++ b/test/semantics/allocate09.f90 @@ -24,7 +24,7 @@ subroutine C946(param_ca_4_assumed, param_ta_4_assumed, param_ca_4_deferred) real(kind=4) srcx, srcx_array(10) real(kind=8) srcx8, srcx8_array(10) - class(WithParam(4, 2)) src_a_4_2 + class(WithParam(4, 2)), allocatable :: src_a_4_2 type(WithParam(8, 2)) src_a_8_2 class(WithParam(4, :)), allocatable :: src_a_4_def class(WithParam(8, :)), allocatable :: src_a_8_def @@ -33,8 +33,10 @@ subroutine C946(param_ca_4_assumed, param_ta_4_assumed, param_ca_4_deferred) type(WithParamExtent(8, 2, 8, 3)) src_b_8_2_8_3 class(WithParamExtent(8, :, 8, 3)), allocatable :: src_b_8_def_8_3 type(WithParamExtent2(k1=4, l1=5, k2=5, l2=6, l3=8 )) src_c_4_5_5_6_8_8 - class(WithParamExtent2(k1=4, l1=2, k2=5, l2=6, k3=5, l3=8)) src_c_4_2_5_6_5_8 - class(WithParamExtent2(k2=5, l2=6, k3=5, l3=8)) src_c_1_2_5_6_5_8 + class(WithParamExtent2(k1=4, l1=2, k2=5, l2=6, k3=5, l3=8)), & + allocatable :: src_c_4_2_5_6_5_8 + class(WithParamExtent2(k2=5, l2=6, k3=5, l3=8)), & + allocatable :: src_c_1_2_5_6_5_8 type(WithParamExtent2(k1=5, l1=5, k2=5, l2=6, l3=8 )) src_c_5_5_5_6_8_8 type(WithParamExtent2(k1=5, l1=2, k2=5, l2=6, k3=5, l3=8)) src_c_5_2_5_6_5_8 diff --git a/test/semantics/resolve44.f90 b/test/semantics/resolve44.f90 index af6a40dff6b4..f6e7a89ba5c3 100644 --- a/test/semantics/resolve44.f90 +++ b/test/semantics/resolve44.f90 @@ -7,6 +7,7 @@ program main type(recursive1), pointer :: ok1 type(recursive1), allocatable :: ok2 !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE + !ERROR: CLASS entity 'bad2' must be a dummy argument or have ALLOCATABLE or POINTER attribute class(recursive1) :: bad2 class(recursive1), pointer :: ok3 class(recursive1), allocatable :: ok4 @@ -19,6 +20,7 @@ program main type(recursive2(kind,len)), pointer :: ok1 type(recursive2(kind,len)), allocatable :: ok2 !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE + !ERROR: CLASS entity 'bad2' must be a dummy argument or have ALLOCATABLE or POINTER attribute class(recursive2(kind,len)) :: bad2 class(recursive2(kind,len)), pointer :: ok3 class(recursive2(kind,len)), allocatable :: ok4 @@ -31,6 +33,7 @@ program main type(recursive3), pointer :: ok1 type(recursive3), allocatable :: ok2 !ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE + !ERROR: CLASS entity 'bad2' must be a dummy argument or have ALLOCATABLE or POINTER attribute class(recursive3) :: bad2 class(recursive3), pointer :: ok3 class(recursive3), allocatable :: ok4 diff --git a/test/semantics/resolve70.f90 b/test/semantics/resolve70.f90 index b771fd0677be..8824ea4249af 100644 --- a/test/semantics/resolve70.f90 +++ b/test/semantics/resolve70.f90 @@ -51,8 +51,8 @@ subroutine s1() end type ! This one's OK - class(extensible) :: y + class(extensible), allocatable :: y !ERROR: Non-extensible derived type 'inextensible' may not be used with CLASS keyword - class(inextensible) :: x + class(inextensible), allocatable :: x end subroutine s1 diff --git a/test/semantics/resolve71.f90 b/test/semantics/resolve71.f90 new file mode 100644 index 000000000000..d570233d4633 --- /dev/null +++ b/test/semantics/resolve71.f90 @@ -0,0 +1,23 @@ +! C708 An entity declared with the CLASS keyword shall be a dummy argument +! or have the ALLOCATABLE or POINTER attribute. +subroutine s() + type :: parentType + end type + + class(parentType), pointer :: pvar + class(parentType), allocatable :: avar + class(*), allocatable :: starAllocatableVar + class(*), pointer :: starPointerVar + !ERROR: CLASS entity 'barevar' must be a dummy argument or have ALLOCATABLE or POINTER attribute + class(parentType) :: bareVar + !ERROR: CLASS entity 'starvar' must be a dummy argument or have ALLOCATABLE or POINTER attribute + class(*) :: starVar + + contains + subroutine inner(arg1, arg2, arg3, arg4, arg5) + class (parenttype) :: arg1, arg3 + type(parentType) :: arg2 + class (parenttype), pointer :: arg4 + class (parenttype), allocatable :: arg5 + end subroutine inner +end subroutine s diff --git a/test/semantics/symbol09.f90 b/test/semantics/symbol09.f90 index 480f7198c8b0..8dca1332a538 100644 --- a/test/semantics/symbol09.f90 +++ b/test/semantics/symbol09.f90 @@ -104,8 +104,8 @@ subroutine s6 !DEF: /s6/a ObjectEntity INTEGER(4) integer :: a(5) = 1 !DEF: /s6/Block1/i ObjectEntity INTEGER(4) - !DEF: /s6/Block1/j (LocalityLocal) ObjectEntity INTEGER(8) - !DEF: /s6/Block1/k (Implicit, LocalityLocalInit) ObjectEntity INTEGER(4) + !DEF: /s6/Block1/j (LocalityLocal) HostAssoc INTEGER(8) + !DEF: /s6/Block1/k (LocalityLocalInit) HostAssoc INTEGER(4) !DEF: /s6/Block1/a (LocalityShared) HostAssoc INTEGER(4) do concurrent(integer::i=1:5)local(j)local_init(k)shared(a) !REF: /s6/Block1/a From 00d8d5121cdaed09e584a0aea7d59baf322bfaa3 Mon Sep 17 00:00:00 2001 From: Jean Perier Date: Tue, 21 Jan 2020 07:41:52 -0800 Subject: [PATCH 17/18] Add clang-format files for FIR source (LLVM style) Note: This commit does not reflect an actual work log, it is a feature based split of the changes done in the FIR experimental branch. The related work log can be found in the commits between: https://github.com/schweitzpgi/f18/commit/8c320e3bf2c3e9cdac66c81db3bf4634bf972e1d and: https://github.com/schweitzpgi/f18/commit/9b9ea05f9a75608c7bb5372c56bf7b9363569a69 --- include/fir/.clang-format | 2 ++ include/flang/lower/.clang-format | 2 ++ include/flang/optimizer/.clang-format | 2 ++ lib/fir/.clang-format | 2 ++ lib/lower/.clang-format | 2 ++ lib/optimizer/.clang-format | 2 ++ tools/bbc/.clang-format | 2 ++ tools/tco/.clang-format | 2 ++ 8 files changed, 16 insertions(+) create mode 100644 include/fir/.clang-format create mode 100644 include/flang/lower/.clang-format create mode 100644 include/flang/optimizer/.clang-format create mode 100644 lib/fir/.clang-format create mode 100644 lib/lower/.clang-format create mode 100644 lib/optimizer/.clang-format create mode 100644 tools/bbc/.clang-format create mode 100644 tools/tco/.clang-format diff --git a/include/fir/.clang-format b/include/fir/.clang-format new file mode 100644 index 000000000000..a74fda4b6734 --- /dev/null +++ b/include/fir/.clang-format @@ -0,0 +1,2 @@ +BasedOnStyle: LLVM +AlwaysBreakTemplateDeclarations: Yes diff --git a/include/flang/lower/.clang-format b/include/flang/lower/.clang-format new file mode 100644 index 000000000000..a74fda4b6734 --- /dev/null +++ b/include/flang/lower/.clang-format @@ -0,0 +1,2 @@ +BasedOnStyle: LLVM +AlwaysBreakTemplateDeclarations: Yes diff --git a/include/flang/optimizer/.clang-format b/include/flang/optimizer/.clang-format new file mode 100644 index 000000000000..a74fda4b6734 --- /dev/null +++ b/include/flang/optimizer/.clang-format @@ -0,0 +1,2 @@ +BasedOnStyle: LLVM +AlwaysBreakTemplateDeclarations: Yes diff --git a/lib/fir/.clang-format b/lib/fir/.clang-format new file mode 100644 index 000000000000..a74fda4b6734 --- /dev/null +++ b/lib/fir/.clang-format @@ -0,0 +1,2 @@ +BasedOnStyle: LLVM +AlwaysBreakTemplateDeclarations: Yes diff --git a/lib/lower/.clang-format b/lib/lower/.clang-format new file mode 100644 index 000000000000..a74fda4b6734 --- /dev/null +++ b/lib/lower/.clang-format @@ -0,0 +1,2 @@ +BasedOnStyle: LLVM +AlwaysBreakTemplateDeclarations: Yes diff --git a/lib/optimizer/.clang-format b/lib/optimizer/.clang-format new file mode 100644 index 000000000000..a74fda4b6734 --- /dev/null +++ b/lib/optimizer/.clang-format @@ -0,0 +1,2 @@ +BasedOnStyle: LLVM +AlwaysBreakTemplateDeclarations: Yes diff --git a/tools/bbc/.clang-format b/tools/bbc/.clang-format new file mode 100644 index 000000000000..a74fda4b6734 --- /dev/null +++ b/tools/bbc/.clang-format @@ -0,0 +1,2 @@ +BasedOnStyle: LLVM +AlwaysBreakTemplateDeclarations: Yes diff --git a/tools/tco/.clang-format b/tools/tco/.clang-format new file mode 100644 index 000000000000..a74fda4b6734 --- /dev/null +++ b/tools/tco/.clang-format @@ -0,0 +1,2 @@ +BasedOnStyle: LLVM +AlwaysBreakTemplateDeclarations: Yes From edb0943bca4b81689f320bda341040bf255d6e2e Mon Sep 17 00:00:00 2001 From: Jean Perier Date: Tue, 28 Jan 2020 04:58:30 -0800 Subject: [PATCH 18/18] Add Pre-FIR Tree structure to help lowering the parse-tree The Pre-FIR Tree structure is a transient data structure that is meant to be built from the parse tree just before lowering to FIR and that will be deleted just afterwards. It is not meant to perfrom optimization analysis and transformations. It only provides temporary information, such as label target information or parse tree parent nodes, that is meant to be used to lower the parse tree structure into FIR operations. A PFTBuilder class builds the Pre-Fir Tree from the parse-tree. A pretty printer is available to visualize this data structure. - Lit tests are added to: 1. that the PFT tree structure is as expected 2. that the PFT captures all intented nodes - Cmake changes: Prevent warnings inisde LLVM headers when compiling flang The issue is that some LLVM headers define functions where the usage of the parameters depend on environment ifdef. See for instance Size in: https://github.com/llvm/llvm-project/blob/5f940220bf9438e95ffa4a627ac1591be1e1ba6e/llvm/include/llvm/Support/Compiler.h#L574 Because flang is build with -Werror and -Wunused-parameter is default in clang, this may breaks build in some environments (like with clang9 on macos). A solution would be to add -Wno-unused-parameter to flang CmakLists.txt, but it is wished to keep this warning on flang sources for quality purposes. Fixing LLVM headers is not an easy task and `[[maybe_unused]]` is C++17 and cannot be used yet in LLVM headers. Hence, this fix simply silence warnings coming from LLVM headers by telling CMake they are to be considered as if they were system headers. - drone.io changes: remove llvm 6.0 from clang config in drone.io and link flang with libstdc++ instead of libc++ llvm-dev resolved to llvm-6.0 in clang builds on drone.io. llvm 6.0 too old. LLVM packages are linked with libstdc++ standard library whereas libc++ was used for flang. This caused link time failure when building clang. Change frone.io to build flang with libc++. Note: This commit does not reflect an actual work log, it is a feature based split of the changes done in the FIR experimental branch. The related work log can be found in the commits between: 864898cbe509d032abfe1172ec367dbd3dd92bc1 and 137c23da9c64cf90584cf81fd646053a69e91f63 Other changes come from https://github.com/flang-compiler/f18/pull/959 review. --- .drone.star | 4 +- CMakeLists.txt | 9 +- include/flang/lower/PFTBuilder.h | 394 ++++++++++++++ include/flang/parser/dump-parse-tree.h | 6 +- lib/CMakeLists.txt | 1 + lib/lower/CMakeLists.txt | 13 + lib/lower/PFTBuilder.cpp | 697 +++++++++++++++++++++++++ test-lit/CMakeLists.txt | 2 + test-lit/lit.cfg.py | 5 +- test-lit/lit.site.cfg.py.in | 1 + test-lit/lower/pre-fir-tree01.f90 | 130 +++++ test-lit/lower/pre-fir-tree02.f90 | 334 ++++++++++++ test-lit/lower/pre-fir-tree03.f90 | 60 +++ test-lit/lower/pre-fir-tree04.f90 | 70 +++ tools/f18/CMakeLists.txt | 2 + tools/f18/f18.cpp | 14 + 16 files changed, 1735 insertions(+), 7 deletions(-) create mode 100644 include/flang/lower/PFTBuilder.h create mode 100644 lib/lower/CMakeLists.txt create mode 100644 lib/lower/PFTBuilder.cpp create mode 100644 test-lit/lower/pre-fir-tree01.f90 create mode 100644 test-lit/lower/pre-fir-tree02.f90 create mode 100644 test-lit/lower/pre-fir-tree03.f90 create mode 100644 test-lit/lower/pre-fir-tree04.f90 diff --git a/.drone.star b/.drone.star index 5911a5b15bc4..47dfca7c2460 100644 --- a/.drone.star +++ b/.drone.star @@ -7,9 +7,9 @@ def clang(arch): "name": "test", "image": "ubuntu", "commands": [ - "apt-get update && apt-get install -y clang-8 cmake ninja-build lld-8 llvm-dev libc++-8-dev libc++abi-8-dev libz-dev", + "apt-get update && apt-get install -y clang-8 cmake ninja-build lld-8 llvm-8-dev libc++-8-dev libc++abi-8-dev libz-dev", "mkdir build && cd build", - 'env CC=clang-8 CXX=clang++-8 CXXFLAGS="-UNDEBUG -stdlib=libc++" LDFLAGS="-fuse-ld=lld" cmake -GNinja -DCMAKE_BUILD_TYPE=Release ..', + 'env CC=clang-8 CXX=clang++-8 CXXFLAGS="-UNDEBUG" LDFLAGS="-fuse-ld=lld" cmake -GNinja -DCMAKE_BUILD_TYPE=Release ..', "ninja -j8", "ctest --output-on-failure -j24", ], diff --git a/CMakeLists.txt b/CMakeLists.txt index 999fd1f252c4..2b7a823f7ec3 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -70,7 +70,14 @@ include(AddLLVM) # https://stackoverflow.com/questions/41924375/llvm-how-to-specify-all-link-libraries-as-input-to-llvm-map-components-to-libna # https://stackoverflow.com/questions/33948633/how-do-i-link-when-building-with-llvm-libraries -include_directories(${LLVM_INCLUDE_DIRS}) +# Add LLVM include files as if they were SYSTEM because there are complex unused +# parameter issues that may or may not appear depending on the environments and +# compilers (ifdefs are involved). This allows warnings from LLVM headers to be +# ignored while keeping -Wunused-parameter a fatal error inside f18 code base. +# This may have to be fine-tuned if flang headers are consider part of this +# LLVM_INCLUDE_DIRS when merging in the monorepo (Warning from flang headers +# should not be suppressed). +include_directories(SYSTEM ${LLVM_INCLUDE_DIRS}) add_definitions(${LLVM_DEFINITIONS}) # LLVM_LIT_EXTERNAL store in cache so it could be used by AddLLVM.cmake diff --git a/include/flang/lower/PFTBuilder.h b/include/flang/lower/PFTBuilder.h new file mode 100644 index 000000000000..0b1345ef8bee --- /dev/null +++ b/include/flang/lower/PFTBuilder.h @@ -0,0 +1,394 @@ +//===-- include/flang/lower/PFTBuilder.h ------------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_LOWER_PFT_BUILDER_H_ +#define FORTRAN_LOWER_PFT_BUILDER_H_ + +#include "flang/common/template.h" +#include "flang/parser/parse-tree.h" +#include "llvm/Support/raw_ostream.h" +#include + +/// Build a light-weight tree over the parse-tree to help with lowering to FIR. +/// It is named Pre-FIR Tree (PFT) to underline it has no other usage than +/// helping lowering to FIR. +/// The PFT will capture pointers back into the parse tree, so the parse tree +/// data structure may not be changed between the construction of the +/// PFT and all of its uses. +/// +/// The PFT captures a structured view of the program. The program is a list of +/// units. Function like units will contain lists of evaluations. Evaluations +/// are either statements or constructs, where a construct contains a list of +/// evaluations. The resulting PFT structure can then be used to create FIR. + +namespace Fortran::lower { +namespace pft { + +struct Evaluation; +struct Program; +struct ModuleLikeUnit; +struct FunctionLikeUnit; + +// TODO: A collection of Evaluations can obviously be any of the container +// types; leaving this as a std::list _for now_ because we reserve the right to +// insert PFT nodes in any order in O(1) time. +using EvaluationCollection = std::list; + +struct ParentType { + template + ParentType(A &parent) : p{&parent} {} + const std::variant + p; +}; + +/// Flags to describe the impact of parse-trees nodes on the program +/// control flow. These annotations to parse-tree nodes are later used to +/// build the control flow graph when lowering to FIR. +enum class CFGAnnotation { + None, // Node does not impact control flow. + Goto, // Node acts like a goto on the control flow. + CondGoto, // Node acts like a conditional goto on the control flow. + IndGoto, // Node acts like an indirect goto on the control flow. + IoSwitch, // Node is an IO statement with ERR, END, or EOR specifier. + Switch, // Node acts like a switch on the control flow. + Iterative, // Node creates iterations in the control flow. + FirStructuredOp, // Node is a structured loop. + Return, // Node triggers a return from the current procedure. + Terminate // Node terminates the program. +}; + +/// Compiler-generated jump +/// +/// This is used to convert implicit control-flow edges to explicit form in the +/// decorated PFT +struct CGJump { + CGJump(Evaluation &to) : target{to} {} + Evaluation ⌖ +}; + +/// Classify the parse-tree nodes from ExecutablePartConstruct + +using ActionStmts = std::tuple< + parser::AllocateStmt, parser::AssignmentStmt, parser::BackspaceStmt, + parser::CallStmt, parser::CloseStmt, parser::ContinueStmt, + parser::CycleStmt, parser::DeallocateStmt, parser::EndfileStmt, + parser::EventPostStmt, parser::EventWaitStmt, parser::ExitStmt, + parser::FailImageStmt, parser::FlushStmt, parser::FormTeamStmt, + parser::GotoStmt, parser::IfStmt, parser::InquireStmt, parser::LockStmt, + parser::NullifyStmt, parser::OpenStmt, parser::PointerAssignmentStmt, + parser::PrintStmt, parser::ReadStmt, parser::ReturnStmt, parser::RewindStmt, + parser::StopStmt, parser::SyncAllStmt, parser::SyncImagesStmt, + parser::SyncMemoryStmt, parser::SyncTeamStmt, parser::UnlockStmt, + parser::WaitStmt, parser::WhereStmt, parser::WriteStmt, + parser::ComputedGotoStmt, parser::ForallStmt, parser::ArithmeticIfStmt, + parser::AssignStmt, parser::AssignedGotoStmt, parser::PauseStmt>; + +using OtherStmts = std::tuple; + +using Constructs = + std::tuple; + +using ConstructStmts = std::tuple< + parser::AssociateStmt, parser::EndAssociateStmt, parser::BlockStmt, + parser::EndBlockStmt, parser::SelectCaseStmt, parser::CaseStmt, + parser::EndSelectStmt, parser::ChangeTeamStmt, parser::EndChangeTeamStmt, + parser::CriticalStmt, parser::EndCriticalStmt, parser::NonLabelDoStmt, + parser::EndDoStmt, parser::IfThenStmt, parser::ElseIfStmt, parser::ElseStmt, + parser::EndIfStmt, parser::SelectRankStmt, parser::SelectRankCaseStmt, + parser::SelectTypeStmt, parser::TypeGuardStmt, parser::WhereConstructStmt, + parser::MaskedElsewhereStmt, parser::ElsewhereStmt, parser::EndWhereStmt, + parser::ForallConstructStmt, parser::EndForallStmt>; + +template +constexpr static bool isActionStmt{common::HasMember}; + +template +constexpr static bool isConstruct{common::HasMember}; + +template +constexpr static bool isConstructStmt{common::HasMember}; + +template +constexpr static bool isOtherStmt{common::HasMember}; + +template +constexpr static bool isGenerated{std::is_same_v}; + +template +constexpr static bool isFunctionLike{common::HasMember< + A, std::tuple>}; + +/// Function-like units can contains lists of evaluations. These can be +/// (simple) statements or constructs, where a construct contains its own +/// evaluations. +struct Evaluation { + using EvalTuple = common::CombineTuples; + + /// Hide non-nullable pointers to the parse-tree node. + template + using MakeRefType = const A *const; + using EvalVariant = + common::CombineVariants, + std::variant>; + template + constexpr auto visit(A visitor) const { + return std::visit(common::visitors{ + [&](const auto *p) { return visitor(*p); }, + [&](auto &r) { return visitor(r); }, + }, + u); + } + template + constexpr const A *getIf() const { + if constexpr (!std::is_same_v) { + if (auto *ptr{std::get_if>(&u)}) { + return *ptr; + } + } else { + return std::get_if(&u); + } + return nullptr; + } + template + constexpr bool isA() const { + if constexpr (!std::is_same_v) { + return std::holds_alternative>(u); + } + return std::holds_alternative(u); + } + + Evaluation() = delete; + Evaluation(const Evaluation &) = delete; + Evaluation(Evaluation &&) = default; + + /// General ctor + template + Evaluation(const A &a, const ParentType &p, const parser::CharBlock &pos, + const std::optional &lab) + : u{&a}, parent{p}, pos{pos}, lab{lab} {} + + /// Compiler-generated jump + Evaluation(const CGJump &jump, const ParentType &p) + : u{jump}, parent{p}, cfg{CFGAnnotation::Goto} {} + + /// Construct ctor + template + Evaluation(const A &a, const ParentType &parent) : u{&a}, parent{parent} { + static_assert(pft::isConstruct, "must be a construct"); + } + + constexpr bool isActionOrGenerated() const { + return visit(common::visitors{ + [](auto &r) { + using T = std::decay_t; + return isActionStmt || isGenerated; + }, + }); + } + + constexpr bool isStmt() const { + return visit(common::visitors{ + [](auto &r) { + using T = std::decay_t; + static constexpr bool isStmt{isActionStmt || isOtherStmt || + isConstructStmt}; + static_assert(!(isStmt && pft::isConstruct), + "statement classification is inconsistent"); + return isStmt; + }, + }); + } + constexpr bool isConstruct() const { return !isStmt(); } + + /// Set the type of originating control flow type for this evaluation. + void setCFG(CFGAnnotation a, Evaluation *cstr) { + cfg = a; + setBranches(cstr); + } + + /// Is this evaluation a control-flow origin? (The PFT must be annotated) + bool isControlOrigin() const { return cfg != CFGAnnotation::None; } + + /// Is this evaluation a control-flow target? (The PFT must be annotated) + bool isControlTarget() const { return isTarget; } + + /// Set the containsBranches flag iff this evaluation (a construct) contains + /// control flow + void setBranches() { containsBranches = true; } + + EvaluationCollection *getConstructEvals() { + auto *evals{subs.get()}; + if (isStmt() && !evals) { + return nullptr; + } + if (isConstruct() && evals) { + return evals; + } + llvm_unreachable("evaluation subs is inconsistent"); + return nullptr; + } + + /// Set that the construct `cstr` (if not a nullptr) has branches. + static void setBranches(Evaluation *cstr) { + if (cstr) + cstr->setBranches(); + } + + EvalVariant u; + ParentType parent; + parser::CharBlock pos; + std::optional lab; + std::unique_ptr subs; // construct sub-statements + CFGAnnotation cfg{CFGAnnotation::None}; + bool isTarget{false}; // this evaluation is a control target + bool containsBranches{false}; // construct contains branches +}; + +/// A program is a list of program units. +/// These units can be function like, module like, or block data +struct ProgramUnit { + template + ProgramUnit(const A &ptr, const ParentType &parent) + : p{&ptr}, parent{parent} {} + ProgramUnit(ProgramUnit &&) = default; + ProgramUnit(const ProgramUnit &) = delete; + + const std::variant< + const parser::MainProgram *, const parser::FunctionSubprogram *, + const parser::SubroutineSubprogram *, const parser::Module *, + const parser::Submodule *, const parser::SeparateModuleSubprogram *, + const parser::BlockData *> + p; + ParentType parent; +}; + +/// Function-like units have similar structure. They all can contain executable +/// statements as well as other function-like units (internal procedures and +/// function statements). +struct FunctionLikeUnit : public ProgramUnit { + // wrapper statements for function-like syntactic structures + using FunctionStatement = + std::variant *, + const parser::Statement *, + const parser::Statement *, + const parser::Statement *, + const parser::Statement *, + const parser::Statement *, + const parser::Statement *, + const parser::Statement *>; + + FunctionLikeUnit(const parser::MainProgram &f, const ParentType &parent); + FunctionLikeUnit(const parser::FunctionSubprogram &f, + const ParentType &parent); + FunctionLikeUnit(const parser::SubroutineSubprogram &f, + const ParentType &parent); + FunctionLikeUnit(const parser::SeparateModuleSubprogram &f, + const ParentType &parent); + FunctionLikeUnit(FunctionLikeUnit &&) = default; + FunctionLikeUnit(const FunctionLikeUnit &) = delete; + + bool isMainProgram() { + return std::holds_alternative< + const parser::Statement *>(endStmt); + } + const parser::FunctionStmt *getFunction() { + return getA(); + } + const parser::SubroutineStmt *getSubroutine() { + return getA(); + } + const parser::MpSubprogramStmt *getMPSubp() { + return getA(); + } + + /// Anonymous programs do not have a begin statement + std::optional beginStmt; + FunctionStatement endStmt; + EvaluationCollection evals; // statements + std::list funcs; // internal procedures + +private: + template + const A *getA() { + if (beginStmt) { + if (auto p = + std::get_if *>(&beginStmt.value())) + return &(*p)->statement; + } + return nullptr; + } +}; + +/// Module-like units have similar structure. They all can contain a list of +/// function-like units. +struct ModuleLikeUnit : public ProgramUnit { + // wrapper statements for module-like syntactic structures + using ModuleStatement = + std::variant *, + const parser::Statement *, + const parser::Statement *, + const parser::Statement *>; + + ModuleLikeUnit(const parser::Module &m, const ParentType &parent); + ModuleLikeUnit(const parser::Submodule &m, const ParentType &parent); + ~ModuleLikeUnit() = default; + ModuleLikeUnit(ModuleLikeUnit &&) = default; + ModuleLikeUnit(const ModuleLikeUnit &) = delete; + + ModuleStatement beginStmt; + ModuleStatement endStmt; + std::list funcs; +}; + +struct BlockDataUnit : public ProgramUnit { + BlockDataUnit(const parser::BlockData &bd, const ParentType &parent); + BlockDataUnit(BlockDataUnit &&) = default; + BlockDataUnit(const BlockDataUnit &) = delete; +}; + +/// A Program is the top-level PFT +struct Program { + using Units = std::variant; + + Program() = default; + Program(Program &&) = default; + Program(const Program &) = delete; + + std::list &getUnits() { return units; } + +private: + std::list units; +}; + +} // namespace pft + +/// Create an PFT from the parse tree +std::unique_ptr createPFT(const parser::Program &root); + +/// Decorate the PFT with control flow annotations +/// +/// The PFT must be decorated with control-flow annotations to prepare it for +/// use in generating a CFG-like structure. +void annotateControl(pft::Program &); + +void dumpPFT(llvm::raw_ostream &o, pft::Program &); + +} // namespace Fortran::lower + +#endif // FORTRAN_LOWER_PFT_BUILDER_H_ diff --git a/include/flang/parser/dump-parse-tree.h b/include/flang/parser/dump-parse-tree.h index aca18137f955..a6181834c94f 100644 --- a/include/flang/parser/dump-parse-tree.h +++ b/include/flang/parser/dump-parse-tree.h @@ -40,11 +40,11 @@ class ParseTreeDumper { std::ostream &out, const AnalyzedObjectsAsFortran *asFortran = nullptr) : out_(out), asFortran_{asFortran} {} - constexpr const char *GetNodeName(const char *) { return "char *"; } + static constexpr const char *GetNodeName(const char *) { return "char *"; } #define NODE_NAME(T, N) \ - constexpr const char *GetNodeName(const T &) { return N; } + static constexpr const char *GetNodeName(const T &) { return N; } #define NODE_ENUM(T, E) \ - std::string GetNodeName(const T::E &x) { \ + static std::string GetNodeName(const T::E &x) { \ return #E " = "s + T::EnumToString(x); \ } #define NODE(T1, T2) NODE_NAME(T1::T2, #T2) diff --git a/lib/CMakeLists.txt b/lib/CMakeLists.txt index 343195bae2b0..35c3e139b1bf 100644 --- a/lib/CMakeLists.txt +++ b/lib/CMakeLists.txt @@ -9,5 +9,6 @@ add_subdirectory(common) add_subdirectory(evaluate) add_subdirectory(decimal) +add_subdirectory(lower) add_subdirectory(parser) add_subdirectory(semantics) diff --git a/lib/lower/CMakeLists.txt b/lib/lower/CMakeLists.txt new file mode 100644 index 000000000000..87131cd9fa53 --- /dev/null +++ b/lib/lower/CMakeLists.txt @@ -0,0 +1,13 @@ +add_library(FortranLower + PFTBuilder.cpp +) + +target_link_libraries(FortranLower + LLVMSupport +) + +install (TARGETS FortranLower + ARCHIVE DESTINATION lib + LIBRARY DESTINATION lib + RUNTIME DESTINATION bin +) diff --git a/lib/lower/PFTBuilder.cpp b/lib/lower/PFTBuilder.cpp new file mode 100644 index 000000000000..d7998e259f78 --- /dev/null +++ b/lib/lower/PFTBuilder.cpp @@ -0,0 +1,697 @@ +//===-- lib/lower/PFTBuilder.cc -------------------------------------------===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#include "flang/lower/PFTBuilder.h" +#include "flang/parser/dump-parse-tree.h" +#include "flang/parser/parse-tree-visitor.h" +#include "llvm/ADT/DenseMap.h" +#include +#include +#include + +namespace Fortran::lower { +namespace { + +/// Helpers to unveil parser node inside parser::Statement<>, +/// parser::UnlabeledStatement, and common::Indirection<> +template +struct RemoveIndirectionHelper { + using Type = A; + static constexpr const Type &unwrap(const A &a) { return a; } +}; +template +struct RemoveIndirectionHelper> { + using Type = A; + static constexpr const Type &unwrap(const common::Indirection &a) { + return a.value(); + } +}; + +template +const auto &removeIndirection(const A &a) { + return RemoveIndirectionHelper::unwrap(a); +} + +template +struct UnwrapStmt { + static constexpr bool isStmt{false}; +}; +template +struct UnwrapStmt> { + static constexpr bool isStmt{true}; + using Type = typename RemoveIndirectionHelper::Type; + constexpr UnwrapStmt(const parser::Statement &a) + : unwrapped{removeIndirection(a.statement)}, pos{a.source}, lab{a.label} { + } + const Type &unwrapped; + parser::CharBlock pos; + std::optional lab; +}; +template +struct UnwrapStmt> { + static constexpr bool isStmt{true}; + using Type = typename RemoveIndirectionHelper::Type; + constexpr UnwrapStmt(const parser::UnlabeledStatement &a) + : unwrapped{removeIndirection(a.statement)}, pos{a.source} {} + const Type &unwrapped; + parser::CharBlock pos; + std::optional lab; +}; + +/// The instantiation of a parse tree visitor (Pre and Post) is extremely +/// expensive in terms of compile and link time, so one goal here is to limit +/// the bridge to one such instantiation. +class PFTBuilder { +public: + PFTBuilder() : pgm{new pft::Program}, parents{*pgm.get()} {} + + /// Get the result + std::unique_ptr result() { return std::move(pgm); } + + template + constexpr bool Pre(const A &a) { + bool visit{true}; + if constexpr (pft::isFunctionLike) { + return enterFunc(a); + } else if constexpr (pft::isConstruct) { + return enterConstruct(a); + } else if constexpr (UnwrapStmt::isStmt) { + using T = typename UnwrapStmt::Type; + // Node "a" being visited has one of the following types: + // Statement, Statement, UnlabeledStatement, + // or UnlabeledStatement> + auto stmt{UnwrapStmt(a)}; + if constexpr (pft::isConstructStmt || pft::isOtherStmt) { + addEval(pft::Evaluation{stmt.unwrapped, parents.back(), stmt.pos, + stmt.lab}); + visit = false; + } else if constexpr (std::is_same_v) { + addEval(makeEvalAction(stmt.unwrapped, stmt.pos, stmt.lab)); + visit = false; + } + } + return visit; + } + + template + constexpr void Post(const A &) { + if constexpr (pft::isFunctionLike) { + exitFunc(); + } else if constexpr (pft::isConstruct) { + exitConstruct(); + } + } + + // Module like + bool Pre(const parser::Module &node) { return enterModule(node); } + bool Pre(const parser::Submodule &node) { return enterModule(node); } + + void Post(const parser::Module &) { exitModule(); } + void Post(const parser::Submodule &) { exitModule(); } + + // Block data + bool Pre(const parser::BlockData &node) { + addUnit(pft::BlockDataUnit{node, parents.back()}); + return false; + } + + // Get rid of production wrapper + bool Pre(const parser::UnlabeledStatement + &statement) { + addEval(std::visit( + [&](const auto &x) { + return pft::Evaluation{x, parents.back(), statement.source, {}}; + }, + statement.statement.u)); + return false; + } + bool Pre(const parser::Statement &statement) { + addEval(std::visit( + [&](const auto &x) { + return pft::Evaluation{x, parents.back(), statement.source, + statement.label}; + }, + statement.statement.u)); + return false; + } + bool Pre(const parser::WhereBodyConstruct &whereBody) { + return std::visit( + common::visitors{ + [&](const parser::Statement &stmt) { + // Not caught as other AssignmentStmt because it is not + // wrapped in a parser::ActionStmt. + addEval(pft::Evaluation{stmt.statement, parents.back(), + stmt.source, stmt.label}); + return false; + }, + [&](const auto &) { return true; }, + }, + whereBody.u); + } + +private: + // ActionStmt has a couple of non-conforming cases, which get handled + // explicitly here. The other cases use an Indirection, which we discard in + // the PFT. + pft::Evaluation makeEvalAction(const parser::ActionStmt &statement, + parser::CharBlock pos, + std::optional lab) { + return std::visit( + common::visitors{ + [&](const auto &x) { + return pft::Evaluation{removeIndirection(x), parents.back(), pos, + lab}; + }, + }, + statement.u); + } + + // When we enter a function-like structure, we want to build a new unit and + // set the builder's cursors to point to it. + template + bool enterFunc(const A &func) { + auto &unit = addFunc(pft::FunctionLikeUnit{func, parents.back()}); + funclist = &unit.funcs; + pushEval(&unit.evals); + parents.emplace_back(unit); + return true; + } + /// Make funclist to point to current parent function list if it exists. + void setFunctListToParentFuncs() { + if (!parents.empty()) { + std::visit(common::visitors{ + [&](pft::FunctionLikeUnit *p) { funclist = &p->funcs; }, + [&](pft::ModuleLikeUnit *p) { funclist = &p->funcs; }, + [&](auto *) { funclist = nullptr; }, + }, + parents.back().p); + } + } + + void exitFunc() { + popEval(); + parents.pop_back(); + setFunctListToParentFuncs(); + } + + // When we enter a construct structure, we want to build a new construct and + // set the builder's evaluation cursor to point to it. + template + bool enterConstruct(const A &construct) { + auto &con = addEval(pft::Evaluation{construct, parents.back()}); + con.subs.reset(new pft::EvaluationCollection); + pushEval(con.subs.get()); + parents.emplace_back(con); + return true; + } + + void exitConstruct() { + popEval(); + parents.pop_back(); + } + + // When we enter a module structure, we want to build a new module and + // set the builder's function cursor to point to it. + template + bool enterModule(const A &func) { + auto &unit = addUnit(pft::ModuleLikeUnit{func, parents.back()}); + funclist = &unit.funcs; + parents.emplace_back(unit); + return true; + } + + void exitModule() { + parents.pop_back(); + setFunctListToParentFuncs(); + } + + template + A &addUnit(A &&unit) { + pgm->getUnits().emplace_back(std::move(unit)); + return std::get(pgm->getUnits().back()); + } + + template + A &addFunc(A &&func) { + if (funclist) { + funclist->emplace_back(std::move(func)); + return funclist->back(); + } + return addUnit(std::move(func)); + } + + /// move the Evaluation to the end of the current list + pft::Evaluation &addEval(pft::Evaluation &&eval) { + assert(funclist && "not in a function"); + assert(evallist.size() > 0); + evallist.back()->emplace_back(std::move(eval)); + return evallist.back()->back(); + } + + /// push a new list on the stack of Evaluation lists + void pushEval(pft::EvaluationCollection *eval) { + assert(funclist && "not in a function"); + assert(eval && eval->empty() && "evaluation list isn't correct"); + evallist.emplace_back(eval); + } + + /// pop the current list and return to the last Evaluation list + void popEval() { + assert(funclist && "not in a function"); + evallist.pop_back(); + } + + std::unique_ptr pgm; + /// funclist points to FunctionLikeUnit::funcs list (resp. + /// ModuleLikeUnit::funcs) when building a FunctionLikeUnit (resp. + /// ModuleLikeUnit) to store internal procedures (resp. module procedures). + /// Otherwise (e.g. when building the top level Program), it is null. + std::list *funclist{nullptr}; + /// evallist is a stack of pointer to FunctionLikeUnit::evals (or + /// Evaluation::subs) that are being build. + std::vector evallist; + std::vector parents; +}; + +template +constexpr bool hasLabel(const A &stmt) { + auto isLabel{ + [](const auto &v) { return std::holds_alternative, + "All ConstructStmts impact on the control flow " + "should be explicitly handled"); + } + /* else do nothing */ + }, + }); + } +} + +/// Annotate the PFT with CFG source decorations (see CFGAnnotation) and mark +/// potential branch targets +inline void annotateFuncCFG(pft::FunctionLikeUnit &functionLikeUnit) { + annotateEvalListCFG(functionLikeUnit.evals, nullptr); + for (auto &internalFunc : functionLikeUnit.funcs) + annotateFuncCFG(internalFunc); +} + +class PFTDumper { +public: + void dumpPFT(llvm::raw_ostream &outputStream, pft::Program &pft) { + for (auto &unit : pft.getUnits()) { + std::visit(common::visitors{ + [&](pft::BlockDataUnit &unit) { + outputStream << getNodeIndex(unit) << " "; + outputStream << "BlockData: "; + outputStream << "\nEndBlockData\n\n"; + }, + [&](pft::FunctionLikeUnit &func) { + dumpFunctionLikeUnit(outputStream, func); + }, + [&](pft::ModuleLikeUnit &unit) { + dumpModuleLikeUnit(outputStream, unit); + }, + }, + unit); + } + resetIndexes(); + } + + llvm::StringRef evalName(pft::Evaluation &eval) { + return eval.visit(common::visitors{ + [](const pft::CGJump) { return "CGJump"; }, + [](const auto &parseTreeNode) { + return parser::ParseTreeDumper::GetNodeName(parseTreeNode); + }, + }); + } + + void dumpEvalList(llvm::raw_ostream &outputStream, + pft::EvaluationCollection &evaluationCollection, + int indent = 1) { + static const std::string white{" ++"}; + std::string indentString{white.substr(0, indent * 2)}; + for (pft::Evaluation &eval : evaluationCollection) { + outputStream << indentString << getNodeIndex(eval) << " "; + llvm::StringRef name{evalName(eval)}; + if (auto *subs{eval.getConstructEvals()}) { + outputStream << "<<" << name << ">>"; + outputStream << "\n"; + dumpEvalList(outputStream, *subs, indent + 1); + outputStream << indentString << "<>\n"; + } else { + outputStream << name; + outputStream << ": " << eval.pos.ToString() + "\n"; + } + } + } + + void dumpFunctionLikeUnit(llvm::raw_ostream &outputStream, + pft::FunctionLikeUnit &functionLikeUnit) { + outputStream << getNodeIndex(functionLikeUnit) << " "; + llvm::StringRef unitKind{}; + std::string name{}; + std::string header{}; + if (functionLikeUnit.beginStmt) { + std::visit( + common::visitors{ + [&](const parser::Statement *statement) { + unitKind = "Program"; + name = statement->statement.v.ToString(); + }, + [&](const parser::Statement *statement) { + unitKind = "Function"; + name = + std::get(statement->statement.t).ToString(); + header = statement->source.ToString(); + }, + [&](const parser::Statement *statement) { + unitKind = "Subroutine"; + name = + std::get(statement->statement.t).ToString(); + header = statement->source.ToString(); + }, + [&](const parser::Statement + *statement) { + unitKind = "MpSubprogram"; + name = statement->statement.v.ToString(); + header = statement->source.ToString(); + }, + [&](auto *) {}, + }, + *functionLikeUnit.beginStmt); + } else { + unitKind = "Program"; + name = ""; + } + outputStream << unitKind << ' ' << name; + if (header.size()) + outputStream << ": " << header; + outputStream << '\n'; + dumpEvalList(outputStream, functionLikeUnit.evals); + if (!functionLikeUnit.funcs.empty()) { + outputStream << "\nContains\n"; + for (auto &func : functionLikeUnit.funcs) + dumpFunctionLikeUnit(outputStream, func); + outputStream << "EndContains\n"; + } + outputStream << "End" << unitKind << ' ' << name << "\n\n"; + } + + void dumpModuleLikeUnit(llvm::raw_ostream &outputStream, + pft::ModuleLikeUnit &moduleLikeUnit) { + outputStream << getNodeIndex(moduleLikeUnit) << " "; + outputStream << "ModuleLike: "; + outputStream << "\nContains\n"; + for (auto &func : moduleLikeUnit.funcs) + dumpFunctionLikeUnit(outputStream, func); + outputStream << "EndContains\nEndModuleLike\n\n"; + } + + template + std::size_t getNodeIndex(const T &node) { + auto addr{static_cast(&node)}; + auto it{nodeIndexes.find(addr)}; + if (it != nodeIndexes.end()) { + return it->second; + } + nodeIndexes.try_emplace(addr, nextIndex); + return nextIndex++; + } + std::size_t getNodeIndex(const pft::Program &) { return 0; } + + void resetIndexes() { + nodeIndexes.clear(); + nextIndex = 1; + } + +private: + llvm::DenseMap nodeIndexes; + std::size_t nextIndex{1}; // 0 is the root +}; + +template +pft::FunctionLikeUnit::FunctionStatement getFunctionStmt(const T &func) { + return pft::FunctionLikeUnit::FunctionStatement{ + &std::get>(func.t)}; +} +template +pft::ModuleLikeUnit::ModuleStatement getModuleStmt(const T &mod) { + return pft::ModuleLikeUnit::ModuleStatement{ + &std::get>(mod.t)}; +} + +} // namespace + +pft::FunctionLikeUnit::FunctionLikeUnit(const parser::MainProgram &func, + const pft::ParentType &parent) + : ProgramUnit{func, parent} { + auto &ps{ + std::get>>(func.t)}; + if (ps.has_value()) { + const parser::Statement &statement{ps.value()}; + beginStmt = &statement; + } + endStmt = getFunctionStmt(func); +} + +pft::FunctionLikeUnit::FunctionLikeUnit(const parser::FunctionSubprogram &func, + const pft::ParentType &parent) + : ProgramUnit{func, parent}, + beginStmt{getFunctionStmt(func)}, + endStmt{getFunctionStmt(func)} {} + +pft::FunctionLikeUnit::FunctionLikeUnit( + const parser::SubroutineSubprogram &func, const pft::ParentType &parent) + : ProgramUnit{func, parent}, + beginStmt{getFunctionStmt(func)}, + endStmt{getFunctionStmt(func)} {} + +pft::FunctionLikeUnit::FunctionLikeUnit( + const parser::SeparateModuleSubprogram &func, const pft::ParentType &parent) + : ProgramUnit{func, parent}, + beginStmt{getFunctionStmt(func)}, + endStmt{getFunctionStmt(func)} {} + +pft::ModuleLikeUnit::ModuleLikeUnit(const parser::Module &m, + const pft::ParentType &parent) + : ProgramUnit{m, parent}, beginStmt{getModuleStmt(m)}, + endStmt{getModuleStmt(m)} {} + +pft::ModuleLikeUnit::ModuleLikeUnit(const parser::Submodule &m, + const pft::ParentType &parent) + : ProgramUnit{m, parent}, beginStmt{getModuleStmt( + m)}, + endStmt{getModuleStmt(m)} {} + +pft::BlockDataUnit::BlockDataUnit(const parser::BlockData &bd, + const pft::ParentType &parent) + : ProgramUnit{bd, parent} {} + +std::unique_ptr createPFT(const parser::Program &root) { + PFTBuilder walker; + Walk(root, walker); + return walker.result(); +} + +void annotateControl(pft::Program &pft) { + for (auto &unit : pft.getUnits()) { + std::visit(common::visitors{ + [](pft::BlockDataUnit &) {}, + [](pft::FunctionLikeUnit &func) { annotateFuncCFG(func); }, + [](pft::ModuleLikeUnit &unit) { + for (auto &func : unit.funcs) + annotateFuncCFG(func); + }, + }, + unit); + } +} + +/// Dump a PFT. +void dumpPFT(llvm::raw_ostream &outputStream, pft::Program &pft) { + PFTDumper{}.dumpPFT(outputStream, pft); +} + +} // namespace Fortran::lower diff --git a/test-lit/CMakeLists.txt b/test-lit/CMakeLists.txt index 0819e57b81f3..111814303b0b 100644 --- a/test-lit/CMakeLists.txt +++ b/test-lit/CMakeLists.txt @@ -1,6 +1,8 @@ # Test runner infrastructure for Flang. This configures the Flang test trees # for use by Lit, and delegates to LLVM's lit test handlers. +set(FLANG_INTRINSIC_MODULES_DIR ${FLANG_BINARY_DIR}/tools/f18/include) + configure_lit_site_cfg( ${CMAKE_CURRENT_SOURCE_DIR}/lit.site.cfg.py.in ${CMAKE_CURRENT_BINARY_DIR}/lit.site.cfg.py diff --git a/test-lit/lit.cfg.py b/test-lit/lit.cfg.py index c27e6a616b85..3ca3c8ad23f7 100644 --- a/test-lit/lit.cfg.py +++ b/test-lit/lit.cfg.py @@ -61,9 +61,12 @@ # to search to ensure that we get the tools just built and not some random # tools that might happen to be in the user's PATH. tool_dirs = [config.llvm_tools_dir, config.flang_tools_dir] +flang_includes = "-I" + config.flang_intrinsic_modules_dir tools = [ToolSubst('%flang', command=FindTool('flang'), unresolved='fatal'), - ToolSubst('%f18', command=FindTool('f18'), unresolved='fatal')] + ToolSubst('%f18', command=FindTool('f18'), unresolved='fatal'), + ToolSubst('%f18_with_includes', command=FindTool('f18'), + extra_args=[flang_includes], unresolved='fatal')] llvm_config.add_tool_substitutions(tools, tool_dirs) diff --git a/test-lit/lit.site.cfg.py.in b/test-lit/lit.site.cfg.py.in index ad31bf1594f9..d00f3856fb41 100644 --- a/test-lit/lit.site.cfg.py.in +++ b/test-lit/lit.site.cfg.py.in @@ -6,6 +6,7 @@ config.llvm_tools_dir = "@LLVM_TOOLS_DIR@" config.flang_obj_root = "@FLANG_BINARY_DIR@" config.flang_src_dir = "@FLANG_SOURCE_DIR@" config.flang_tools_dir = "@FLANG_TOOLS_DIR@" +config.flang_intrinsic_modules_dir = "@FLANG_INTRINSIC_MODULES_DIR@" config.python_executable = "@PYTHON_EXECUTABLE@" # Support substitution of the tools_dir with user parameters. This is diff --git a/test-lit/lower/pre-fir-tree01.f90 b/test-lit/lower/pre-fir-tree01.f90 new file mode 100644 index 000000000000..97f15eea052e --- /dev/null +++ b/test-lit/lower/pre-fir-tree01.f90 @@ -0,0 +1,130 @@ +! RUN: %f18 -fdebug-pre-fir-tree -fparse-only %s | FileCheck %s + +! Test structure of the Pre-FIR tree + +! CHECK: Subroutine foo +subroutine foo() + ! CHECK: <> + ! CHECK: NonLabelDoStmt + do i=1,5 + ! CHECK: PrintStmt + print *, "hey" + ! CHECK: <> + ! CHECK: NonLabelDoStmt + do j=1,5 + ! CHECK: PrintStmt + print *, "hello", i, j + ! CHECK: EndDoStmt + end do + ! CHECK: <> + ! CHECK: EndDoStmt + end do + ! CHECK: <> +end subroutine +! CHECK: EndSubroutine foo + +! CHECK: BlockData +block data + integer, parameter :: n = 100 + integer, dimension(n) :: a, b, c + common /arrays/ a, b, c +end +! CHECK: EndBlockData + +! CHECK: ModuleLike +module test_mod +interface + ! check specification parts are not part of the PFT. + ! CHECK-NOT: node + module subroutine dump() + end subroutine +end interface + integer :: xdim + real, allocatable :: pressure(:) +contains + ! CHECK: Subroutine foo + subroutine foo() + contains + ! CHECK: Subroutine subfoo + subroutine subfoo() + end subroutine + ! CHECK: EndSubroutine subfoo + ! CHECK: Function subfoo2 + function subfoo2() + end function + ! CHECK: EndFunction subfoo2 + end subroutine + ! CHECK: EndSubroutine foo + + ! CHECK: Function foo2 + function foo2(i, j) + integer i, j, foo2 + ! CHECK: AssignmentStmt + foo2 = i + j + contains + ! CHECK: Subroutine subfoo + subroutine subfoo() + end subroutine + ! CHECK: EndSubroutine subfoo + end function + ! CHECK: EndFunction foo2 +end module +! CHECK: EndModuleLike + +! CHECK: ModuleLike +submodule (test_mod) test_mod_impl +contains + ! CHECK: Subroutine foo + subroutine foo() + contains + ! CHECK: Subroutine subfoo + subroutine subfoo() + end subroutine + ! CHECK: EndSubroutine subfoo + ! CHECK: Function subfoo2 + function subfoo2() + end function + ! CHECK: EndFunction subfoo2 + end subroutine + ! CHECK: EndSubroutine foo + ! CHECK: MpSubprogram dump + module procedure dump + ! CHECK: FormatStmt +11 format (2E16.4, I6) + ! CHECK: <> + ! CHECK: IfThenStmt + if (xdim > 100) then + ! CHECK: PrintStmt + print *, "test: ", xdim + ! CHECK: ElseStmt + else + ! CHECK: WriteStmt + write (*, 11) "test: ", xdim, pressure + ! CHECK: EndIfStmt + end if + ! CHECK: <> + end procedure +end submodule +! CHECK: EndModuleLike + +! CHECK: BlockData +block data named_block + integer i, j, k + common /indexes/ i, j, k +end +! CHECK: EndBlockData + +! CHECK: Function bar +function bar() +end function +! CHECK: EndFunction bar + +! CHECK: Program + ! check specification parts are not part of the PFT. + ! CHECK-NOT: node + use test_mod + real, allocatable :: x(:) + ! CHECK: AllocateStmt + allocate(x(foo2(10, 30))) +end +! CHECK: EndProgram diff --git a/test-lit/lower/pre-fir-tree02.f90 b/test-lit/lower/pre-fir-tree02.f90 new file mode 100644 index 000000000000..ec9077a550a2 --- /dev/null +++ b/test-lit/lower/pre-fir-tree02.f90 @@ -0,0 +1,334 @@ +! RUN: %f18 -fdebug-pre-fir-tree -fparse-only %s | FileCheck %s + +! Test Pre-FIR Tree captures all the intended nodes from the parse-tree +! Coarray and OpenMP related nodes are tested in other files. + +! CHECK: Program test_prog +program test_prog + ! Check specification part is not part of the tree. + interface + subroutine incr(i) + integer, intent(inout) :: i + end subroutine + end interface + integer :: i, j, k + real, allocatable, target :: x(:) + real :: y(100) + ! CHECK-NOT: node + ! CHECK: <> + ! CHECK: NonLabelDoStmt + do i=1,5 + ! CHECK: PrintStmt + print *, "hey" + ! CHECK: <> + ! CHECK: NonLabelDoStmt + do j=1,5 + ! CHECK: PrintStmt + print *, "hello", i, j + ! CHECK: EndDoStmt + end do + ! CHECK: <> + ! CHECK: EndDoStmt + end do + ! CHECK: <> + + ! CHECK: <> + ! CHECK: AssociateStmt + associate (k => i + j) + ! CHECK: AllocateStmt + allocate(x(k)) + ! CHECK: EndAssociateStmt + end associate + ! CHECK: <> + + ! CHECK: <> + ! CHECK: BlockStmt + block + integer :: k, l + real, pointer :: p(:) + ! CHECK: PointerAssignmentStmt + p => x + ! CHECK: AssignmentStmt + k = size(p) + ! CHECK: AssignmentStmt + l = 1 + ! CHECK: <> + ! CHECK: SelectCaseStmt + select case (k) + ! CHECK: CaseStmt + case (:0) + ! CHECK: NullifyStmt + nullify(p) + ! CHECK: CaseStmt + case (1) + ! CHECK: <> + ! CHECK: IfThenStmt + if (p(1)>0.) then + ! CHECK: PrintStmt + print *, "+" + ! CHECK: ElseIfStmt + else if (p(1)==0.) then + ! CHECK: PrintStmt + print *, "0." + ! CHECK: ElseStmt + else + ! CHECK: PrintStmt + print *, "-" + ! CHECK: EndIfStmt + end if + ! CHECK: <> + ! CHECK: CaseStmt + case (2:10) + ! CHECK: CaseStmt + case default + ! Note: label-do-loop are canonicalized into do constructs + ! CHECK: <> + ! CHECK: NonLabelDoStmt + do 22 while(l<=k) + ! CHECK: IfStmt + if (p(l)<0.) p(l)=cos(p(l)) + ! CHECK: CallStmt +22 call incr(l) + ! CHECK: EndDoStmt + ! CHECK: <> + ! CHECK: CaseStmt + case (100:) + ! CHECK: EndSelectStmt + end select + ! CHECK: <> + ! CHECK: EndBlockStmt + end block + ! CHECK: <> + + ! CHECK-NOT: WhereConstruct + ! CHECK: WhereStmt + where (x > 1.) x = x/2. + + ! CHECK: <> + ! CHECK: WhereConstructStmt + where (x == 0.) + ! CHECK: AssignmentStmt + x = 0.01 + ! CHECK: MaskedElsewhereStmt + elsewhere (x < 0.5) + ! CHECK: AssignmentStmt + x = x*2. + ! CHECK: <> + where (y > 0.4) + ! CHECK: AssignmentStmt + y = y/2. + end where + ! CHECK: <> + ! CHECK: ElsewhereStmt + elsewhere + ! CHECK: AssignmentStmt + x = x + 1. + ! CHECK: EndWhereStmt + end where + ! CHECK: <> + + ! CHECK-NOT: ForAllConstruct + ! CHECK: ForallStmt + forall (i = 1:5) x(i) = y(i) + + ! CHECK: <> + ! CHECK: ForallConstructStmt + forall (i = 1:5) + ! CHECK: AssignmentStmt + x(i) = x(i) + y(10*i) + ! CHECK: EndForallStmt + end forall + ! CHECK: <> + + ! CHECK: DeallocateStmt + deallocate(x) +end + +! CHECK: ModuleLike +module test + type :: a_type + integer :: x + end type + type, extends(a_type) :: b_type + integer :: y + end type +contains + ! CHECK: Function foo + function foo(x) + real x(..) + integer :: foo + ! CHECK: <> + ! CHECK: SelectRankStmt + select rank(x) + ! CHECK: SelectRankCaseStmt + rank (0) + ! CHECK: AssignmentStmt + foo = 0 + ! CHECK: SelectRankCaseStmt + rank (*) + ! CHECK: AssignmentStmt + foo = -1 + ! CHECK: SelectRankCaseStmt + rank (1) + ! CHECK: AssignmentStmt + foo = 1 + ! CHECK: SelectRankCaseStmt + rank default + ! CHECK: AssignmentStmt + foo = 2 + ! CHECK: EndSelectStmt + end select + ! CHECK: <> + end function + + ! CHECK: Function bar + function bar(x) + class(*) :: x + ! CHECK: <> + ! CHECK: SelectTypeStmt + select type(x) + ! CHECK: TypeGuardStmt + type is (integer) + ! CHECK: AssignmentStmt + bar = 0 + ! CHECK: TypeGuardStmt + class is (a_type) + ! CHECK: AssignmentStmt + bar = 1 + ! CHECK: ReturnStmt + return + ! CHECK: TypeGuardStmt + class default + ! CHECK: AssignmentStmt + bar = -1 + ! CHECK: EndSelectStmt + end select + ! CHECK: <> + end function + + ! CHECK: Subroutine sub + subroutine sub(a) + real(4):: a + ! CompilerDirective + ! CHECK: <> + !DIR$ IGNORE_TKR a + end subroutine + + +end module + +! CHECK: Subroutine altreturn +subroutine altreturn(i, j, *, *) + ! CHECK: <> + if (i>j) then + ! CHECK: ReturnStmt + return 1 + else + ! CHECK: ReturnStmt + return 2 + end if + ! CHECK: <> +end subroutine + + +! Remaining TODO + +! CHECK: Subroutine iostmts +subroutine iostmts(filename, a, b, c) + character(*) :: filename + integer :: length + logical :: file_is_opened + real, a, b ,c + ! CHECK: InquireStmt + inquire(file=filename, opened=file_is_opened) + ! CHECK: <> + if (file_is_opened) then + ! CHECK: OpenStmt + open(10, FILE=filename) + end if + ! CHECK: <> + ! CHECK: ReadStmt + read(10, *) length + ! CHECK: RewindStmt + rewind 10 + ! CHECK: NamelistStmt + namelist /nlist/ a, b, c + ! CHECK: WriteStmt + write(10, NML=nlist) + ! CHECK: BackspaceStmt + backspace(10) + ! CHECK: FormatStmt +1 format (1PE12.4) + ! CHECK: WriteStmt + write (10, 1) a + ! CHECK: EndfileStmt + endfile 10 + ! CHECK: FlushStmt + flush 10 + ! CHECK: WaitStmt + wait(10) + ! CHECK: CloseStmt + close(10) +end subroutine + + +! CHECK: Subroutine sub2 +subroutine sub2() + integer :: i, j, k, l + i = 0 +1 j = i + ! CHECK: ContinueStmt +2 continue + i = i+1 +3 j = j+1 +! CHECK: ArithmeticIfStmt + if (j-i) 3, 4, 5 + ! CHECK: GotoStmt +4 goto 6 + +! FIXME: is name resolution on assigned goto broken/todo ? +! WILLCHECK: AssignStmt +!55 assign 6 to label +! WILLCHECK: AssignedGotoStmt +!66 go to label (5, 6) + +! CHECK: ComputedGotoStmt + go to (5, 6), 1 + mod(i, 2) +5 j = j + 1 +6 i = i + j/2 + + ! CHECK: <> + do1: do k=1,10 + ! CHECK: <> + do2: do l=5,20 + ! CHECK: CycleStmt + cycle do1 + ! CHECK: ExitStmt + exit do2 + end do do2 + ! CHECK: <> + end do do1 + ! CHECK: <> + + ! CHECK: PauseStmt + pause 7 + ! CHECK: StopStmt + stop +end subroutine + + +! CHECK: Subroutine sub3 +subroutine sub3() + print *, "normal" + ! CHECK: EntryStmt + entry sub4entry() + print *, "test" +end subroutine + +! CHECK: Subroutine sub4 +subroutine sub4(i, j) + integer :: i + print*, "test" + ! CHECK: DataStmt + data i /1/ +end subroutine diff --git a/test-lit/lower/pre-fir-tree03.f90 b/test-lit/lower/pre-fir-tree03.f90 new file mode 100644 index 000000000000..2eedfe7610ce --- /dev/null +++ b/test-lit/lower/pre-fir-tree03.f90 @@ -0,0 +1,60 @@ +! RUN: %f18 -fdebug-pre-fir-tree -fparse-only -fopenmp %s | FileCheck %s + +! Test Pre-FIR Tree captures OpenMP related constructs + +! CHECK: Program test_omp +program test_omp + ! CHECK: PrintStmt + print *, "sequential" + + ! CHECK: <> + !$omp parallel + ! CHECK: PrintStmt + print *, "in omp //" + ! CHECK: <> + !$omp do + ! CHECK: <> + ! CHECK: LabelDoStmt + do i=1,100 + ! CHECK: PrintStmt + print *, "in omp do" + ! CHECK: EndDoStmt + end do + ! CHECK: <> + ! CHECK: OmpEndLoopDirective + !$omp end do + ! CHECK: <> + + ! CHECK: PrintStmt + print *, "not in omp do" + + ! CHECK: <> + !$omp do + ! CHECK: <> + ! CHECK: LabelDoStmt + do i=1,100 + ! CHECK: PrintStmt + print *, "in omp do" + ! CHECK: EndDoStmt + end do + ! CHECK: <> + ! CHECK: <> + ! CHECK-NOT: OmpEndLoopDirective + ! CHECK: PrintStmt + print *, "no in omp do" + !$omp end parallel + ! CHECK: <> + + ! CHECK: PrintStmt + print *, "sequential again" + + ! CHECK: <> + !$omp task + ! CHECK: PrintStmt + print *, "in task" + !$omp end task + ! CHECK: <> + + ! CHECK: PrintStmt + print *, "sequential again" +end program diff --git a/test-lit/lower/pre-fir-tree04.f90 b/test-lit/lower/pre-fir-tree04.f90 new file mode 100644 index 000000000000..3e8516e57bbb --- /dev/null +++ b/test-lit/lower/pre-fir-tree04.f90 @@ -0,0 +1,70 @@ +! RUN: %f18_with_includes -fdebug-pre-fir-tree -fparse-only %s | FileCheck %s + +! Test Pre-FIR Tree captures all the coarray related statements + +! CHECK: Subroutine test_coarray +Subroutine test_coarray + use iso_fortran_env, only: team_type, event_type, lock_type + type(team_type) :: t + type(event_type) :: done + type(lock_type) :: alock + real :: y[10,*] + integer :: counter[*] + logical :: is_master + ! CHECK: <> + change team(t, x[5,*] => y) + ! CHECK: AssignmentStmt + x = x[4, 1] + end team + ! CHECK: <> + ! CHECK: FormTeamStmt + form team(1, t) + + ! CHECK: <> + if (this_image() == 1) then + ! CHECK: EventPostStmt + event post (done) + else + ! CHECK: EventWaitStmt + event wait (done) + end if + ! CHECK: <> + + ! CHECK: <> + critical + ! CHECK: AssignmentStmt + counter[1] = counter[1] + 1 + end critical + ! CHECK: <> + + ! CHECK: LockStmt + lock(alock) + ! CHECK: PrintStmt + print *, "I have the lock" + ! CHECK: UnlockStmt + unlock(alock) + + ! CHECK: SyncAllStmt + sync all + ! CHECK: SyncMemoryStmt + sync memory + ! CHECK: SyncTeamStmt + sync team(t) + + ! CHECK: <> + if (this_image() == 1) then + ! CHECK: SyncImagesStmt + sync images(*) + else + ! CHECK: SyncImagesStmt + sync images(1) + end if + ! CHECK: <> + + ! CHECK: <> + if (y<0.) then + ! CHECK: FailImageStmt + fail image + end if + ! CHECK: <> +end diff --git a/tools/f18/CMakeLists.txt b/tools/f18/CMakeLists.txt index 676549c95cf4..79f5c52d6a6c 100644 --- a/tools/f18/CMakeLists.txt +++ b/tools/f18/CMakeLists.txt @@ -18,6 +18,8 @@ target_link_libraries(f18 FortranParser FortranEvaluate FortranSemantics + LLVMSupport + FortranLower ) add_executable(f18-parse-demo diff --git a/tools/f18/f18.cpp b/tools/f18/f18.cpp index 56f008ba6fe1..b54d1a9e2d11 100644 --- a/tools/f18/f18.cpp +++ b/tools/f18/f18.cpp @@ -11,6 +11,7 @@ #include "flang/common/Fortran-features.h" #include "flang/common/default-kinds.h" #include "flang/evaluate/expression.h" +#include "flang/lower/PFTBuilder.h" #include "flang/parser/characters.h" #include "flang/parser/dump-parse-tree.h" #include "flang/parser/message.h" @@ -22,6 +23,7 @@ #include "flang/semantics/expression.h" #include "flang/semantics/semantics.h" #include "flang/semantics/unparse-with-symbols.h" +#include "llvm/Support/raw_ostream.h" #include #include #include @@ -92,6 +94,7 @@ struct DriverOptions { bool dumpUnparse{false}; bool dumpUnparseWithSymbols{false}; bool dumpParseTree{false}; + bool dumpPreFirTree{false}; bool dumpSymbols{false}; bool debugResolveNames{false}; bool debugNoSemantics{false}; @@ -308,6 +311,15 @@ std::string CompileFortran(std::string path, Fortran::parser::Options options, nullptr /* action before each statement */, &asFortran); return {}; } + if (driver.dumpPreFirTree) { + if (auto ast{Fortran::lower::createPFT(parseTree)}) { + Fortran::lower::annotateControl(*ast); + Fortran::lower::dumpPFT(llvm::outs(), *ast); + } else { + std::cerr << "Pre FIR Tree is NULL.\n"; + exitStatus = EXIT_FAILURE; + } + } if (driver.parseOnly) { return {}; } @@ -475,6 +487,8 @@ int main(int argc, char *const argv[]) { options.needProvenanceRangeToCharBlockMappings = true; } else if (arg == "-fdebug-dump-parse-tree") { driver.dumpParseTree = true; + } else if (arg == "-fdebug-pre-fir-tree") { + driver.dumpPreFirTree = true; } else if (arg == "-fdebug-dump-symbols") { driver.dumpSymbols = true; } else if (arg == "-fdebug-resolve-names") {