diff --git a/.drone.star b/.drone.star index f08549f289d1..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", + "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", ], @@ -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", 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/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/documentation/ImplementingASemanticCheck.md b/documentation/ImplementingASemanticCheck.md new file mode 100644 index 000000000000..736202abaa1f --- /dev/null +++ b/documentation/ImplementingASemanticCheck.md @@ -0,0 +1,832 @@ + +# 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 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. + +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 +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. 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/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/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; } 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/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/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/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/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/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..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; } @@ -467,7 +463,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/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/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/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 fbc043eed374..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}; @@ -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}; } @@ -313,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()) { @@ -351,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, @@ -386,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/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/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/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/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/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/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/check-declarations.cpp b/lib/semantics/check-declarations.cpp index a96bc6fb056b..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: @@ -495,7 +503,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/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/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/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 e6a9b7f9bfeb..61e9ed02711d 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" @@ -342,6 +343,7 @@ class DeclTypeSpecVisitor : public AttrsVisitor { } KindExpr GetKindParamExpr( TypeCategory, const std::optional &); + void CheckForAbstractType(const Symbol &typeSymbol); private: State state_; @@ -444,12 +446,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 &) { @@ -724,7 +721,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 &); @@ -735,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 &); @@ -786,6 +785,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 +815,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 +1045,137 @@ 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(); + } +} + +// 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::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 &) { + 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 +1193,65 @@ 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}; + std::size_t associatedLoopLevel{0}; + }; + // 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(); + } + 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{ + 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 +1273,28 @@ class OmpVisitor : public virtual DeclarationVisitor { } bool HasDataSharingAttributeObject(const Symbol &); - // TODO: resolve variables referenced in the OpenMP region + 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); - 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, @@ -1598,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; @@ -1621,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()); } @@ -2897,6 +2896,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{}); @@ -3272,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; @@ -3530,7 +3570,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)); @@ -4084,7 +4124,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)) { @@ -4274,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; } @@ -4486,7 +4522,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); }, @@ -5730,6 +5766,7 @@ bool ResolveNamesVisitor::Pre(const parser::ProgramUnit &x) { ResolveSpecificationParts(root); FinishSpecificationParts(root); ResolveExecutionParts(root); + OmpAttributeVisitor{context(), *this}.Walk(x); return false; } @@ -5915,6 +5952,440 @@ 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)}; + 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; + 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::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; + 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)}; + 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; + } + 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/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/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/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 a9a71b9f17ce..571775ce8984 100644 --- a/runtime/CMakeLists.txt +++ b/runtime/CMakeLists.txt @@ -8,20 +8,26 @@ 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 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..a956a3bbae1d --- /dev/null +++ b/runtime/buffer.h @@ -0,0 +1,174 @@ +//===-- 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(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 + 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_, frame_ + bytes); + } + + void Flush(IoErrorHandler &handler) { + if (dirty_) { + while (length_ > 0) { + std::size_t chunk{std::min(length_, 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, 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_, 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, const 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/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 new file mode 100644 index 000000000000..735312b9f57c --- /dev/null +++ b/runtime/environment.cpp @@ -0,0 +1,39 @@ +//===-- 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 +#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 = + decimal::FortranRounding::RoundNearest; // 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..056a13829b2a --- /dev/null +++ b/runtime/environment.h @@ -0,0 +1,27 @@ +//===-- 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/decimal/decimal.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; + enum decimal::FortranRounding defaultOutputRoundingMode; +}; +extern ExecutionEnvironment executionEnvironment; +} + +#endif // FORTRAN_RUNTIME_ENVIRONMENT_H_ diff --git a/runtime/file.cpp b/runtime/file.cpp index 3936bcdfcfa6..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,37 +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); - 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; - 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(); @@ -62,26 +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); if (!path_.get()) { handler.Crash( "FILE= is required unless STATUS='OLD' and unit is connected"); @@ -92,27 +72,35 @@ 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) { + 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) { +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) { @@ -123,7 +111,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 +145,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 +175,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 +190,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 +198,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 +219,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 +228,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; @@ -294,11 +283,11 @@ void OpenFile::WaitAll(IoErrorHandler &handler) { } } -void OpenFile::CheckOpen(Terminator &terminator) { +void OpenFile::CheckOpen(const 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,15 +299,29 @@ 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; + 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 1c0a10d8f754..9ed1c250364a 100644 --- a/runtime/file.h +++ b/runtime/file.h @@ -14,41 +14,58 @@ #include "io-error.h" #include "lock.h" #include "memory.h" -#include "terminator.h" #include #include 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 Offset = std::uint64_t; + using FileOffset = std::int64_t; - Offset position() const { return position_; } + 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_; } + 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_; } - 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 Close(const char *action, std::size_t actionLength, IoErrorHandler &); + 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 // 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 &); @@ -60,16 +77,24 @@ class OpenFile { }; // lock_ must be held for these - void CheckOpen(Terminator &); - bool Seek(Offset, IoErrorHandler &); - bool RawSeek(Offset); - int PendingResult(Terminator &, int); + void CheckOpen(const Terminator &); + bool Seek(FileOffset, IoErrorHandler &); + bool RawSeek(FileOffset); + bool RawSeekToEnd(); + int PendingResult(const 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}; + 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 46ad2ea2b5d0..91a6b6749514 100644 --- a/runtime/format.cpp +++ b/runtime/format.cpp @@ -6,361 +6,48 @@ // //===----------------------------------------------------------------------===// -#include "format.h" -#include "io-stmt.h" -#include "flang/common/format.h" -#include "flang/decimal/decimal.h" -#include +#include "format-implementation.h" 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()) { - terminator.Crash("internal Fortran runtime error: maxHeight %d", maxHeight); - } - 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, std::uint16_t &scale, 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) { - scale = n; // kP - decimal scaling by 10**k (TODO) - 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; - 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') { - next = '\0'; - } - if (ch == 'E' || - (!next && - (ch == 'A' || ch == 'I' || ch == 'B' || ch == 'O' || ch == 'Z' || - ch == 'F' || ch == 'D' || ch == 'G'))) { - // 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, scale_, static_cast(ch), - static_cast(next), repeat && *repeat > 0 ? *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'; - } - - 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 ed164e8902d1..c072b3b9805d 100644 --- a/runtime/format.h +++ b/runtime/format.h @@ -11,8 +11,11 @@ #ifndef FORTRAN_RUNTIME_FORMAT_H_ #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 @@ -26,50 +29,64 @@ enum EditingFlags { struct MutableModes { std::uint8_t editingFlags{0}; // BN, DP, SS - common::RoundingMode roundingMode{common::RoundingMode::TiesToEven}; // RN + enum decimal::FortranRounding round{ + 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 + + // 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 - 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; int repeat{1}; }; -class FormatContext : virtual public Terminator { -public: - 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); - 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: - FormatControl(Terminator &, const CHAR *format, std::size_t formatLength, - int maxHeight = maxMaxHeight); + using Context = CONTEXT; + using CharType = typename Context::CharType; + + FormatControl() {} + 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) { @@ -79,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}; @@ -98,46 +115,41 @@ 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; } // 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 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 56e6dff932c5..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. @@ -6,26 +6,641 @@ // //===----------------------------------------------------------------------===// +// 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, + std::size_t formatLength, 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("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}; + 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}; + 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}; + if (!io.get_if()) { + io.GetIoErrorHandler().Crash( + "OutputAscii() called for a non-output I/O statement"); + return false; + } + 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}; + if (!io.get_if()) { + io.GetIoErrorHandler().Crash( + "OutputLogical() called for a non-output I/O statement"); + return false; + } + 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 io) { - return static_cast(io->EndIoStatement()); +enum Iostat IONAME(EndIoStatement)(Cookie cookie) { + IoStatementState &io{*cookie}; + return static_cast(io.EndIoStatement()); } } 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 617e3e697a14..adc9bae6c150 100644 --- a/runtime/io-stmt.cpp +++ b/runtime/io-stmt.cpp @@ -7,82 +7,356 @@ //===----------------------------------------------------------------------===// #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 { -int IoStatementState::EndIoStatement() { return GetIoStat(); } +int IoStatementBase::EndIoStatement() { return GetIoStat(); } -int InternalIoStatementState::EndIoStatement() { - auto result{GetIoStat()}; +DataEdit IoStatementBase::GetNextDataEdit(int) { + Crash("IoStatementBase::GetNextDataEdit() called for non-formatted I/O " + "statement"); +} + +template +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 InternalIoStatementState::Emit( + const CharType *data, std::size_t chars) { + if constexpr (isInput) { + Crash("InternalIoStatementState::Emit() called for input statement"); + return false; + } + return unit_.Emit(data, chars, *this); +} + +template +bool InternalIoStatementState::AdvanceRecord(int n) { + while (n-- > 0) { + if (!unit_.AdvanceRecord(*this)) { + return false; + } + } + return true; +} + +template +int InternalIoStatementState::EndIoStatement() { + if constexpr (!isInput) { + unit_.EndIoStatement(); // fill + } + auto result{IoStatementBase::EndIoStatement()}; if (free_) { FreeMemory(this); } return result; } -InternalIoStatementState::InternalIoStatementState( - const char *sourceFile, int sourceLine) - : IoStatementState(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}, + ioStatementState_{*this}, format_{*this, format, formatLength} {} 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(' ')); -} + CHAR>::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 -void InternalFormattedIoStatementState::Emit( - const CHAR *data, std::size_t chars) { - if constexpr (isInput) { - FormatContext::Emit(data, chars); // default Crash() - } else if (at_ + chars > internalLength_) { - SignalEor(); - } else { - std::memcpy(internal_ + at_, data, chars * sizeof(CHAR)); - at_ += chars; +int InternalFormattedIoStatementState::EndIoStatement() { + if constexpr (!isInput) { + format_.FinishOutput(*this); } + return InternalIoStatementState::EndIoStatement(); } 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 InternalFormattedIoStatementState::HandleAbsolutePosition( + std::int64_t n) { + return unit_.HandleAbsolutePosition(n, *this); } template -void InternalFormattedIoStatementState::HandleRelativePosition( - int n) { - if (n < 0) { - at_ -= std::min(at_, -static_cast(n)); +bool InternalFormattedIoStatementState::HandleRelativePosition( + std::int64_t n) { + return unit_.HandleRelativePosition(n, *this); +} + +template +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 { - at_ += n; - if (at_ > internalLength_) { - Crash("TR%d control edit descriptor is out of range", n); + 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 (!unit().AdvanceRecord(*this)) { + return false; } } + return true; +} + +template +bool ExternalIoStatementState::HandleAbsolutePosition(std::int64_t n) { + return unit().HandleAbsolutePosition(n, *this); +} + +template +bool ExternalIoStatementState::HandleRelativePosition(std::int64_t n) { + return unit().HandleRelativePosition(n, *this); } template -int InternalFormattedIoStatementState::EndIoStatement() { +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); - auto result{GetIoStat()}; - if (free_) { - FreeMemory(this); + 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); } - 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 2e70efa591be..17549388b060 100644 --- a/runtime/io-stmt.h +++ b/runtime/io-stmt.h @@ -6,59 +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 IoStatementState : public IoErrorHandler { +struct ConnectionState; +class ExternalFileUnit; + +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: - using IoErrorHandler::IoErrorHandler; - virtual int EndIoStatement(); + template explicit IoStatementState(A &x) : u_{x} {} -protected: + // 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(); + + // 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; + + bool EmitRepeated(char, std::size_t); + bool EmitField(const char *, std::size_t length, std::size_t width); + +private: + 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_; }; -class InternalIoStatementState : public IoStatementState { +// 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 IoStatementBase, + public IoDirectionState { public: - InternalIoStatementState(const char *sourceFile, int sourceLine); - virtual int EndIoStatement(); + using CharType = CHAR; + using Buffer = std::conditional_t; + InternalIoStatementState(Buffer, std::size_t, + const char *sourceFile = nullptr, int sourceLine = 0); + 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 -class InternalFormattedIoStatementState : public InternalIoStatementState, - private FormatContext { +template +class InternalFormattedIoStatementState + : public InternalIoStatementState, + public FormattedStatementState { +public: + using CharType = CHAR; + using typename InternalIoStatementState::Buffer; + InternalFormattedIoStatementState(Buffer internal, std::size_t internalLength, + const CharType *format, std::size_t formatLength, + const char *sourceFile = nullptr, int sourceLine = 0); + 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: - using Buffer = std::conditional_t; + 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: - InternalFormattedIoStatementState(Buffer internal, std::size_t internalLength, - const CHAR *format, std::size_t formatLength, + using CharType = CHAR; + using typename InternalIoStatementState::Buffer; + InternalListIoStatementState(Buffer internal, std::size_t internalLength, 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); + 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: + ExternalFileUnit &unit_; +}; + +template +class ExternalIoStatementState : public ExternalIoStatementBase, + public IoDirectionState { +public: + 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); + MutableModes &mutableModes() { return mutableModes_; } + int EndIoStatement(); + DataEdit GetNextDataEdit(int maxRepeat = 1) { + return format_.GetNextDataEdit(*this, maxRepeat); + } + +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: - Buffer internal_; - std::size_t internalLength_; - std::size_t at_{0}; - FormatControl format_; // must be last, may be partial + 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 25b3b02001bf..e7f4200b2777 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,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::io::ExternalFileUnit::InitializePredefinedUnits(); } } 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..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; } @@ -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..1bd5bca1b78a 100644 --- a/runtime/memory.h +++ b/runtime/memory.h @@ -18,15 +18,23 @@ namespace Fortran::runtime { class Terminator; -void *AllocateMemoryOrCrash(Terminator &, std::size_t bytes); -template 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 *); -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()(const Terminator &terminator, X &&... x) { return *new (AllocateMemoryOrCrash(terminator, sizeof(A))) A{std::forward(x)...}; } @@ -37,6 +45,22 @@ template struct OwningPtrDeleter { }; template using OwningPtr = std::unique_ptr>; + +template struct Allocator { + using value_type = A; + explicit Allocator(const 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); } + const Terminator &terminator; +}; } #endif // FORTRAN_RUNTIME_MEMORY_H_ 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 new file mode 100644 index 000000000000..f8c5437ca31b --- /dev/null +++ b/runtime/numeric-output.h @@ -0,0 +1,343 @@ +//===-- 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. +// 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 "io-stmt.h" +#include "flang/decimal/decimal.h" + +namespace Fortran::runtime::io { + +class IoStatementState; + +// 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); + +// Encapsulates the state of a REAL output conversion. +class RealOutputEditingBase { +protected: + explicit RealOutputEditingBase(IoStatementState &io) : io_{io} {} + + static bool IsDecimalNumber(const char *p) { + if (!p) { + return false; + } + if (*p == '-' || *p == '+') { + ++p; + } + return *p >= '0' && *p <= '9'; + } + + 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 &); + + IoStatementState &io_; + int trailingBlanks_{0}; // created when Gw editing maps to Fw + char exponent_[16]; +}; + +template +class RealOutputEditing : public RealOutputEditingBase { +public: + 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 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_.IsZero(); } + + decimal::ConversionToDecimalResult Convert( + int significantDigits, const DataEdit &, int flags = 0); + + BinaryFloatingPoint x_; + char buffer_[BinaryFloatingPoint::maxDecimalConversionDigits + + EXTRA_DECIMAL_CONVERSION_SPACE]; +}; + +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_, + sizeof buffer_, static_cast(flags), + significantDigits, edit.modes.round, x_)}; + if (!converted.str) { // overflow + 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) { + 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 = + sizeof buffer_ - 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 EmitPrefix(edit, converted.length, editWidth) && + io_.Emit(converted.str, converted.length) && EmitSuffix(edit); + } + 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 io_.EmitRepeated('*', width); + } + if (totalLength < width && digitsBeforePoint == 0 && + zeroesBeforePoint == 0) { + zeroesBeforePoint = 1; + ++totalLength; + } + return EmitPrefix(edit, totalLength, width) && + io_.Emit(converted.str, signLength + digitsBeforePoint) && + io_.EmitRepeated('0', zeroesBeforePoint) && + io_.Emit(edit.modes.editingFlags & decimalComma ? "," : ".", 1) && + io_.EmitRepeated('0', zeroesAfterPoint) && + io_.Emit( + converted.str + signLength + digitsBeforePoint, digitsAfterPoint) && + io_.EmitRepeated('0', trailingZeroes) && + io_.Emit(exponent, expoLength) && EmitSuffix(edit); + } +} + +// 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 = sizeof buffer_ - 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 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 = sizeof buffer_ - 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 io_.EmitRepeated('*', width); + } + if (totalLength < width && digitsBeforePoint + zeroesBeforePoint == 0) { + zeroesBeforePoint = 1; + ++totalLength; + } + return EmitPrefix(edit, totalLength, width) && + io_.Emit(converted.str, signLength + digitsBeforePoint) && + io_.EmitRepeated('0', zeroesBeforePoint) && + io_.Emit(edit.modes.editingFlags & decimalComma ? "," : ".", 1) && + io_.EmitRepeated('0', zeroesAfterPoint) && + io_.Emit( + converted.str + signLength + digitsBeforePoint, digitsAfterPoint) && + io_.EmitRepeated('0', trailingZeroes) && + io_.EmitRepeated(' ', trailingBlanks_) && EmitSuffix(edit); + } +} + +// 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(BinaryFloatingPoint::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.10.4 in F'2018 +template +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_.GetIoErrorHandler().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: + 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 8bf665f82512..46ad558dfe4c 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::ExternalFileUnit::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/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 184f6af63f8e..99571782dc07 100644 --- a/runtime/tools.h +++ b/runtime/tools.h @@ -8,12 +8,18 @@ #ifndef FORTRAN_RUNTIME_TOOLS_H_ #define FORTRAN_RUNTIME_TOOLS_H_ + #include "memory.h" +#include +#include +#include + 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 @@ -21,5 +27,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..277d36b39a08 --- /dev/null +++ b/runtime/unit.cpp @@ -0,0 +1,195 @@ +//===-- 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}}; +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); + } +} + +ExternalFileUnit *ExternalFileUnit::LookUp(int unit) { + CriticalSection criticalSection{mapLock}; + auto iter{unitMap.find(unit)}; + return iter == unitMap.end() ? nullptr : &iter->second; +} + +ExternalFileUnit &ExternalFileUnit::LookUpOrCrash( + int unit, const Terminator &terminator) { + CriticalSection criticalSection{mapLock}; + ExternalFileUnit *file{LookUp(unit)}; + if (!file) { + terminator.Crash("Not an open I/O unit number: %d", unit); + } + return *file; +} + +ExternalFileUnit &ExternalFileUnit::LookUpOrCreate(int unit, bool *wasExtant) { + CriticalSection criticalSection{mapLock}; + auto pair{unitMap.emplace(unit, unit)}; + if (wasExtant) { + *wasExtant = !pair.second; + } + return pair.first->second; +} + +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}; + auto iter{unitMap.find(unitNumber_)}; + if (iter != unitMap.end()) { + unitMap.erase(iter); + } +} + +void ExternalFileUnit::InitializePredefinedUnits() { + ExternalFileUnit &out{ExternalFileUnit::LookUpOrCreate(6)}; + out.Predefine(1); + out.set_mayRead(false); + out.set_mayWrite(true); + out.set_mayPosition(false); + defaultOutput = &out; + ExternalFileUnit &in{ExternalFileUnit::LookUpOrCreate(5)}; + in.Predefine(0); + in.set_mayRead(true); + in.set_mayWrite(false); + in.set_mayPosition(false); + // TODO: Set UTF-8 mode from the environment +} + +void ExternalFileUnit::CloseAll(IoErrorHandler &handler) { + CriticalSection criticalSection{mapLock}; + defaultOutput = nullptr; + while (!unitMap.empty()) { + auto &pair{*unitMap.begin()}; + pair.second.CloseUnit(CloseStatus::Keep, handler); + } +} + +bool ExternalFileUnit::SetPositionInRecord( + 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) { + if (!isReading_ && ok) { + WriteFrame(recordOffsetInFile, n, handler); + std::fill_n(Frame() + furthestPositionInRecord, + n - furthestPositionInRecord, ' '); + } + furthestPositionInRecord = n; + } + positionInRecord = n; + return ok; +} + +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; + furthestPositionInRecord = furthestAfter; + return true; +} + +void ExternalFileUnit::SetLeftTabLimit() { + leftTabLimit = furthestPositionInRecord; + positionInRecord = furthestPositionInRecord; +} + +bool ExternalFileUnit::AdvanceRecord(IoErrorHandler &handler) { + bool ok{true}; + if (recordLength.has_value()) { // fill fixed-size record + ok &= SetPositionInRecord(*recordLength, handler); + } else if (!isUnformatted && !isReading_) { + ok &= SetPositionInRecord(furthestPositionInRecord, handler) && + Emit("\n", 1, handler); + } + recordOffsetInFile += furthestPositionInRecord; + ++currentRecordNumber; + positionInRecord = 0; + furthestPositionInRecord = 0; + leftTabLimit.reset(); + return ok; +} + +bool ExternalFileUnit::HandleAbsolutePosition( + std::int64_t n, IoErrorHandler &handler) { + return SetPositionInRecord( + std::max(n, std::int64_t{0}) + leftTabLimit.value_or(0), handler); +} + +bool ExternalFileUnit::HandleRelativePosition( + std::int64_t n, IoErrorHandler &handler) { + return HandleAbsolutePosition(positionInRecord + n, handler); +} + +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 new file mode 100644 index 000000000000..62f664b8f32a --- /dev/null +++ b/runtime/unit.h @@ -0,0 +1,84 @@ +//===-- 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 external I/O units + +#ifndef FORTRAN_RUNTIME_IO_UNIT_H_ +#define FORTRAN_RUNTIME_IO_UNIT_H_ + +#include "buffer.h" +#include "connection.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 { + +class ExternalFileUnit : public ConnectionState, + public OpenFile, + public FileFrame { +public: + explicit ExternalFileUnit(int unitNumber) : unitNumber_{unitNumber} {} + int unitNumber() const { return unitNumber_; } + + 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 OpenUnit(OpenStatus, Position, OwningPtr &&path, + std::size_t pathLength, IoErrorHandler &); + void CloseUnit(CloseStatus, IoErrorHandler &); + + template + IoStatementState &BeginIoStatement(X &&... xs) { + // TODO: lock().Take() here, and keep it until EndIoStatement()? + // Nested I/O from derived types wouldn't work, though. + A &state{u_.emplace(std::forward(xs)...)}; + if constexpr (!std::is_same_v) { + state.mutableModes() = ConnectionState::modes; + } + io_.emplace(state); + return *io_; + } + + bool Emit(const char *, std::size_t bytes, IoErrorHandler &); + void SetLeftTabLimit(); + 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}; + bool isReading_{false}; + // 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_; +}; + +} +#endif // FORTRAN_RUNTIME_IO_UNIT_H_ 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/test/evaluate/folding05.f90 b/test/evaluate/folding05.f90 index d6d8a4567382..5e5e5c576976 100644 Binary files a/test/evaluate/folding05.f90 and b/test/evaluate/folding05.f90 differ 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/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..400d345e1b39 --- /dev/null +++ b/test/runtime/external-hello.cpp @@ -0,0 +1,26 @@ +#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[]) { + RTNAME(ProgramStart)(argc, argv, envp); + 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 937a4434b8d7..05ec9d3e280b 100644 --- a/test/runtime/format.cpp +++ b/test/runtime/format.cpp @@ -1,33 +1,43 @@ -// Test basic FORMAT string traversal -#include "../runtime/format.h" +// Tests basic FORMAT string traversal + +#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} {} - 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 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, ...) { +[[noreturn]] void Fortran::runtime::Terminator::Crash( + const char *message, ...) const { std::va_list ap; va_start(ap, message); char buffer[1000]; @@ -36,27 +46,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::AdvanceRecord(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 +89,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); } @@ -97,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 9c52a01b26a9..4bb65acd565e 100644 --- a/test/runtime/hello.cpp +++ b/test/runtime/hello.cpp @@ -1,28 +1,386 @@ -// Basic tests of I/O API +// 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}; -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 << "hello: '" << format << "' failed, status " + << static_cast(status) << '\n'; + ++failures; + } else { + test(format, "HELLO, WORLD 678 0xFEEDFACE T", + std::string{buffer, sizeof buffer}); + } +} + +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 << "format1 failed, status " << static_cast(status) << '\n'; + std::cerr << "multiline: '" << format << "' failed, status " + << static_cast(status) << '\n'; ++failures; + } else { + test(format, + ">HELLO, WORLD <" + " " + "789 done" + " ", + std::string{buffer[0], 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(); + multiline(); + + 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"; diff --git a/test/semantics/CMakeLists.txt b/test/semantics/CMakeLists.txt index 1765b4367ef0..c29282442cd9 100644 --- a/test/semantics/CMakeLists.txt +++ b/test/semantics/CMakeLists.txt @@ -99,6 +99,9 @@ set(ERROR_TESTS resolve66.f90 resolve67.f90 resolve68.f90 + resolve69.f90 + resolve70.f90 + resolve71.f90 stop01.f90 structconst01.f90 structconst02.f90 @@ -163,6 +166,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 +231,8 @@ set(SYMBOL_TESTS omp-symbol04.f90 omp-symbol05.f90 omp-symbol06.f90 + omp-symbol07.f90 + omp-symbol08.f90 kinds01.f90 kinds03.f90 procinterface01.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/allocate03.f90 b/test/semantics/allocate03.f90 index dcdb2d5d4312..f86b44ceca2e 100644 --- a/test/semantics/allocate03.f90 +++ b/test/semantics/allocate03.f90 @@ -34,7 +34,7 @@ subroutine C933_a(b1, ca3, ca4, cp3, cp3mold, cp4, cp7, cp8, bsrc) type(SomeType(1, l1=3)), pointer :: cp9, cp10(:) type(B(*)) b1 - type(B(:)) b2 + type(B(:)), allocatable :: b2 type(B(5)) b3 type(SomeType(4, *, 8)) bsrc 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/allocate09.f90 b/test/semantics/allocate09.f90 index ca83b685675f..e47cd8134b49 100644 --- a/test/semantics/allocate09.f90 +++ b/test/semantics/allocate09.f90 @@ -24,17 +24,19 @@ 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, :)) src_a_4_def - class(WithParam(8, :)) src_a_8_def + class(WithParam(4, :)), allocatable :: src_a_4_def + class(WithParam(8, :)), allocatable :: src_a_8_def type(WithParamExtent(4, 2, 8, 3)) src_b_4_2_8_3 - class(WithParamExtent(4, :, 8, 3)) src_b_4_def_8_3 + class(WithParamExtent(4, :, 8, 3)), allocatable :: src_b_4_def_8_3 type(WithParamExtent(8, 2, 8, 3)) src_b_8_2_8_3 - class(WithParamExtent(8, :, 8, 3)) src_b_8_def_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/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 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 diff --git a/test/semantics/modfile28.f90 b/test/semantics/modfile28.f90 index 12c17b1184f9..c53ab04dfc2d 100644 --- a/test/semantics/modfile28.f90 +++ b/test/semantics/modfile28.f90 @@ -3,20 +3,20 @@ ! Note: Module files are encoded in UTF-8. module m -character(kind=4,len=:), parameter :: c4 = 4_"Hi! 你好!" +character(kind=4,len=*), parameter :: c4 = 4_"Hi! 你好!" ! In CHARACTER(1) literals, codepoints > 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/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 ca9468707253..e87cb119dba4 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 @@ -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-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-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-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 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 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/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/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 new file mode 100644 index 000000000000..bf08c3a706b0 --- /dev/null +++ b/test/semantics/resolve69.f90 @@ -0,0 +1,54 @@ +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' + 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 + +!ERROR: Must have INTEGER type, but is REAL(4) + character(3.5) :: badParamValue + + 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 diff --git a/test/semantics/resolve70.f90 b/test/semantics/resolve70.f90 new file mode 100644 index 000000000000..8824ea4249af --- /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), allocatable :: y + + !ERROR: Non-extensible derived type 'inextensible' may not be used with CLASS keyword + 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/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)()) 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 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/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") { 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