[flang] Implement FSEEK and FTELL

flang-rt/lib/runtime/extensions.cpp

@@ -10,12 +10,14 @@
 // extensions that will eventually be implemented in Fortran.
 
 #include "flang/Runtime/extensions.h"
+#include "unit.h"
 #include "flang-rt/runtime/descriptor.h"
 #include "flang-rt/runtime/terminator.h"
 #include "flang-rt/runtime/tools.h"
 #include "flang/Runtime/command.h"
 #include "flang/Runtime/entry-names.h"
 #include "flang/Runtime/io-api.h"
+#include "flang/Runtime/iostat-consts.h"
 #include <chrono>
 #include <cstdio>
 #include <cstring>
@@ -275,5 +277,33 @@ void RTNAME(Perror)(const char *str) { perror(str); }
 // GNU extension function TIME()
 std::int64_t RTNAME(time)() { return time(nullptr); }
 
+// Extension procedures related to I/O
+
+namespace io {
+std::int32_t RTNAME(Fseek)(int unitNumber, std::int64_t zeroBasedPos,
+    int whence, const char *sourceFileName, int lineNumber) {
+  if (ExternalFileUnit * unit{ExternalFileUnit::LookUp(unitNumber)}) {
+    Terminator terminator{sourceFileName, lineNumber};
+    IoErrorHandler handler{terminator};
+    if (unit->Fseek(
+            zeroBasedPos, static_cast<enum FseekWhence>(whence), handler)) {
+      return IostatOk;
+    } else {
+      return IostatCannotReposition;
+    }
+  } else {
+    return IostatBadUnitNumber;
+  }
+}
+
+std::int64_t RTNAME(Ftell)(int unitNumber) {
+  if (ExternalFileUnit * unit{ExternalFileUnit::LookUp(unitNumber)}) {
+    return unit->InquirePos() - 1; // zero-based result
+  } else {
+    return -1;
+  }
+}
+} // namespace io
+
 } // namespace Fortran::runtime
 } // extern "C"

flang-rt/lib/runtime/unit.cpp

@@ -441,14 +441,14 @@ void ExternalFileUnit::Rewind(IoErrorHandler &handler) {
         "REWIND(UNIT=%d) on non-sequential file", unitNumber());
   } else {
     DoImpliedEndfile(handler);
-    SetPosition(0, handler);
+    SetPosition(0);
     currentRecordNumber = 1;
     leftTabLimit.reset();
     anyWriteSinceLastPositioning_ = false;
   }
 }
 
-void ExternalFileUnit::SetPosition(std::int64_t pos, IoErrorHandler &handler) {
+void ExternalFileUnit::SetPosition(std::int64_t pos) {
   frameOffsetInFile_ = pos;
   recordOffsetInFrame_ = 0;
   if (access == Access::Direct) {
@@ -457,6 +457,18 @@ void ExternalFileUnit::SetPosition(std::int64_t pos, IoErrorHandler &handler) {
   BeginRecord();
 }
 
+void ExternalFileUnit::Sought(std::int64_t zeroBasedPos) {
+  SetPosition(zeroBasedPos);
+  if (zeroBasedPos == 0) {
+    currentRecordNumber = 1;
+  } else {
+    // We no longer know which record we're in.  Set currentRecordNumber to
+    // a large value from whence we can both advance and backspace.
+    currentRecordNumber = std::numeric_limits<std::int64_t>::max() / 2;
+    endfileRecordNumber.reset();
+  }
+}
+
 bool ExternalFileUnit::SetStreamPos(
     std::int64_t oneBasedPos, IoErrorHandler &handler) {
   if (access != Access::Stream) {
@@ -474,14 +486,31 @@ bool ExternalFileUnit::SetStreamPos(
       frameOffsetInFile_ + recordOffsetInFrame_) {
     DoImpliedEndfile(handler);
   }
-  SetPosition(oneBasedPos - 1, handler);
-  // We no longer know which record we're in.  Set currentRecordNumber to
-  // a large value from whence we can both advance and backspace.
-  currentRecordNumber = std::numeric_limits<std::int64_t>::max() / 2;
-  endfileRecordNumber.reset();
+  Sought(oneBasedPos - 1);
   return true;
 }
 
+// GNU FSEEK extension
+RT_API_ATTRS bool ExternalFileUnit::Fseek(std::int64_t zeroBasedPos,
+    enum FseekWhence whence, IoErrorHandler &handler) {
+  if (whence == FseekEnd) {
+    Flush(handler); // updates knownSize_
+    if (auto size{knownSize()}) {
+      zeroBasedPos += *size;
+    } else {
+      return false;
+    }
+  } else if (whence == FseekCurrent) {
+    zeroBasedPos += InquirePos() - 1;
+  }
+  if (zeroBasedPos >= 0) {
+    Sought(zeroBasedPos);
+    return true;
+  } else {
+    return false;
+  }
+}
+
 bool ExternalFileUnit::SetDirectRec(
     std::int64_t oneBasedRec, IoErrorHandler &handler) {
   if (access != Access::Direct) {
@@ -498,7 +527,7 @@ bool ExternalFileUnit::SetDirectRec(
     return false;
   }
   currentRecordNumber = oneBasedRec;
-  SetPosition((oneBasedRec - 1) * *openRecl, handler);
+  SetPosition((oneBasedRec - 1) * *openRecl);
   return true;
 }
 

flang-rt/lib/runtime/unit.h

@@ -33,6 +33,12 @@ class UnitMap;
 class ChildIo;
 class ExternalFileUnit;
 
+enum FseekWhence {
+  FseekSet = 0,
+  FseekCurrent = 1,
+  FseekEnd = 2,
+};
+
 RT_OFFLOAD_VAR_GROUP_BEGIN
 // Predefined file units.
 extern RT_VAR_ATTRS ExternalFileUnit *defaultInput; // unit 5
@@ -176,8 +182,9 @@ class ExternalFileUnit : public ConnectionState,
   RT_API_ATTRS void Endfile(IoErrorHandler &);
   RT_API_ATTRS void Rewind(IoErrorHandler &);
   RT_API_ATTRS void EndIoStatement();
-  RT_API_ATTRS bool SetStreamPos(
-      std::int64_t, IoErrorHandler &); // one-based, for POS=
+  RT_API_ATTRS bool SetStreamPos(std::int64_t oneBasedPos, IoErrorHandler &);
+  RT_API_ATTRS bool Fseek(
+      std::int64_t zeroBasedPos, enum FseekWhence, IoErrorHandler &);
   RT_API_ATTRS bool SetDirectRec(
       std::int64_t, IoErrorHandler &); // one-based, for REC=
   RT_API_ATTRS std::int64_t InquirePos() const {
@@ -196,7 +203,8 @@ class ExternalFileUnit : public ConnectionState,
   static RT_API_ATTRS UnitMap &CreateUnitMap();
   static RT_API_ATTRS UnitMap &GetUnitMap();
   RT_API_ATTRS const char *FrameNextInput(IoErrorHandler &, std::size_t);
-  RT_API_ATTRS void SetPosition(std::int64_t, IoErrorHandler &); // zero-based
+  RT_API_ATTRS void SetPosition(std::int64_t zeroBasedPos);
+  RT_API_ATTRS void Sought(std::int64_t zeroBasedPos);
   RT_API_ATTRS void BeginSequentialVariableUnformattedInputRecord(
       IoErrorHandler &);
   RT_API_ATTRS void BeginVariableFormattedInputRecord(IoErrorHandler &);

flang/docs/Intrinsics.md

@@ -1197,6 +1197,44 @@ program chdir_func
 end program chdir_func
 ```
 
+### Non-Standard Intrinsics: FSEEK and FTELL
+
+#### Description
+`FSEEK(UNIT, OFFSET, WHENCE)` Sets position in file opened as `UNIT`, returns status.
+
+`CALL FSEEK(UNIT, OFFSET, WHENCE[, STATUS])` Sets position, returns any error in `STATUS` if present.
+
+`FTELL(UNIT)` Returns current absolute byte offset.
+
+`CALL FTELL(UNIT, OFFSET)` Set `OFFSET` to current byte offset in file.
+
+These intrinsic procedures are available as both functions and subroutines,
+but both forms cannot be used in the same scope.
+
+These arguments must all be integers.
+The value returned from the function form of `FTELL` is `INTEGER(8)`.
+
+|            |                                                 |
+|------------|-------------------------------------------------|
+| `UNIT`     | An open unit number                             |
+| `OFFSET`   | A byte offset; set to -1 by `FTELL` on error    |
+| `WHENCE`   | 0: `OFFSET` is an absolute position             |
+|            | 1: `OFFSET` is relative to the current position |
+|            | 2: `OFFSET` is relative to the end of the file  |
+| `STATUS`   | Set to a nonzero value if an error occurs       |
+|------------|-------------------------------------------------|
+
+The aliases `FSEEK64`, `FSEEKO64`, `FSEEKI8`, `FTELL64`, `FTELLO64`, and
+`FTELLI8` are also accepted for further compatibility.
+
+Avoid using these intrinsics in new code when the standard `ACCESS="STREAM"`
+feature meets your needs.
+
+#### Usage and Info
+
+- **Standard:** Extensions to GNU, Intel, and SUN (at least)
+- **Class:** Subroutine, function
+
 ### Non-Standard Intrinsics: IERRNO
 
 #### Description

flang/include/flang/Optimizer/Builder/IntrinsicCall.h

@@ -266,6 +266,10 @@ struct IntrinsicLibrary {
   mlir::Value genFraction(mlir::Type resultType,
                           mlir::ArrayRef<mlir::Value> args);
   void genFree(mlir::ArrayRef<fir::ExtendedValue> args);
+  fir::ExtendedValue genFseek(std::optional<mlir::Type>,
+                              mlir::ArrayRef<fir::ExtendedValue> args);
+  fir::ExtendedValue genFtell(std::optional<mlir::Type>,
+                              mlir::ArrayRef<fir::ExtendedValue> args);
   fir::ExtendedValue genGetCwd(std::optional<mlir::Type> resultType,
                                llvm::ArrayRef<fir::ExtendedValue> args);
   void genGetCommand(mlir::ArrayRef<fir::ExtendedValue> args);

flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h

@@ -49,6 +49,11 @@ void genEtime(fir::FirOpBuilder &builder, mlir::Location loc,
 
 void genFree(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value ptr);
 
+mlir::Value genFseek(fir::FirOpBuilder &builder, mlir::Location loc,
+                     mlir::Value unit, mlir::Value offset, mlir::Value whence);
+mlir::Value genFtell(fir::FirOpBuilder &builder, mlir::Location loc,
+                     mlir::Value unit);
+
 mlir::Value genGetUID(fir::FirOpBuilder &, mlir::Location);
 mlir::Value genGetGID(fir::FirOpBuilder &, mlir::Location);
 

flang/include/flang/Runtime/extensions.h

@@ -38,6 +38,11 @@ void FORTRAN_PROCEDURE_NAME(fdate)(char *string, std::int64_t length);
 
 void RTNAME(Free)(std::intptr_t ptr);
 
+// Common extensions FSEEK & FTELL, variously named
+std::int32_t RTNAME(Fseek)(int unit, std::int64_t zeroBasedPos, int whence,
+    const char *sourceFileName, int lineNumber);
+std::int64_t RTNAME(Ftell)(int unit);
+
 // GNU Fortran 77 compatibility function IARGC.
 std::int32_t FORTRAN_PROCEDURE_NAME(iargc)();
 

flang/lib/Evaluate/intrinsics.cpp

@@ -545,6 +545,12 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
         KINDInt, Rank::vector, IntrinsicClass::transformationalFunction},
     {"floor", {{"a", AnyReal}, DefaultingKIND}, KINDInt},
     {"fraction", {{"x", SameReal}}, SameReal},
+    {"fseek",
+        {{"unit", AnyInt, Rank::scalar}, {"offset", AnyInt, Rank::scalar},
+            {"whence", AnyInt, Rank::scalar}},
+        DefaultInt, Rank::scalar},
+    {"ftell", {{"unit", AnyInt, Rank::scalar}},
+        TypePattern{IntType, KindCode::exactKind, 8}, Rank::scalar},
     {"gamma", {{"x", SameReal}}, SameReal},
     {"get_team", {{"level", DefaultInt, Rank::scalar, Optionality::optional}},
         TeamType, Rank::scalar, IntrinsicClass::transformationalFunction},
@@ -1083,11 +1089,16 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
 //  LOC, probably others
 // TODO: Optionally warn on operand promotion extension
 
-// Aliases for a few generic intrinsic functions for legacy
-// compatibility and builtins.
+// Aliases for a few generic procedures for legacy compatibility and builtins.
 static const std::pair<const char *, const char *> genericAlias[]{
     {"and", "iand"},
     {"getenv", "get_environment_variable"},
+    {"fseek64", "fseek"},
+    {"fseeko64", "fseek"}, // SUN
+    {"fseeki8", "fseek"}, // Intel
+    {"ftell64", "ftell"},
+    {"ftello64", "ftell"}, // SUN
+    {"ftelli8", "ftell"}, // Intel
     {"imag", "aimag"},
     {"lshift", "shiftl"},
     {"or", "ior"},
@@ -1524,6 +1535,17 @@ static const IntrinsicInterface intrinsicSubroutine[]{
     {"exit", {{"status", DefaultInt, Rank::scalar, Optionality::optional}}, {},
         Rank::elemental, IntrinsicClass::impureSubroutine},
     {"free", {{"ptr", Addressable}}, {}},
+    {"fseek",
+        {{"unit", AnyInt, Rank::scalar}, {"offset", AnyInt, Rank::scalar},
+            {"whence", AnyInt, Rank::scalar},
+            {"status", AnyInt, Rank::scalar, Optionality::optional,
+                common::Intent::InOut}},
+        {}, Rank::elemental, IntrinsicClass::impureSubroutine},
+    {"ftell",
+        {{"unit", AnyInt, Rank::scalar},
+            {"offset", AnyInt, Rank::scalar, Optionality::required,
+                common::Intent::Out}},
+        {}, Rank::elemental, IntrinsicClass::impureSubroutine},
     {"get_command",
         {{"command", DefaultChar, Rank::scalar, Optionality::optional,
              common::Intent::Out},
@@ -2811,9 +2833,9 @@ bool IntrinsicProcTable::Implementation::IsDualIntrinsic(
     const std::string &name) const {
   // Collection for some intrinsics with function and subroutine form,
   // in order to pass the semantic check.
-  static const std::string dualIntrinsic[]{{"chdir"s}, {"etime"s}, {"getcwd"s},
-      {"hostnm"s}, {"rename"s}, {"second"s}, {"system"s}, {"unlink"s}};
-
+  static const std::string dualIntrinsic[]{{"chdir"}, {"etime"}, {"fseek"},
+      {"ftell"}, {"getcwd"}, {"hostnm"}, {"rename"}, {"second"}, {"system"},
+      {"unlink"}};
   return llvm::is_contained(dualIntrinsic, name);
 }
 

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

@@ -462,6 +462,17 @@ static constexpr IntrinsicHandler handlers[]{
     {"floor", &I::genFloor},
     {"fraction", &I::genFraction},
     {"free", &I::genFree},
+    {"fseek",
+     &I::genFseek,
+     {{{"unit", asValue},
+       {"offset", asValue},
+       {"whence", asValue},
+       {"status", asAddr, handleDynamicOptional}}},
+     /*isElemental=*/false},
+    {"ftell",
+     &I::genFtell,
+     {{{"unit", asValue}, {"offset", asAddr}}},
+     /*isElemental=*/false},
     {"get_command",
      &I::genGetCommand,
      {{{"command", asBox, handleDynamicOptional},
@@ -4139,6 +4150,69 @@ void IntrinsicLibrary::genFree(llvm::ArrayRef<fir::ExtendedValue> args) {
   fir::runtime::genFree(builder, loc, fir::getBase(args[0]));
 }
 
+// FSEEK
+fir::ExtendedValue
+IntrinsicLibrary::genFseek(std::optional<mlir::Type> resultType,
+                           llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert((args.size() == 4 && !resultType.has_value()) ||
+         (args.size() == 3 && resultType.has_value()));
+  mlir::Value unit = fir::getBase(args[0]);
+  mlir::Value offset = fir::getBase(args[1]);
+  mlir::Value whence = fir::getBase(args[2]);
+  if (!unit)
+    fir::emitFatalError(loc, "expected UNIT argument");
+  if (!offset)
+    fir::emitFatalError(loc, "expected OFFSET argument");
+  if (!whence)
+    fir::emitFatalError(loc, "expected WHENCE argument");
+  mlir::Value statusValue =
+      fir::runtime::genFseek(builder, loc, unit, offset, whence);
+  if (resultType.has_value()) { // function
+    return builder.createConvert(loc, *resultType, statusValue);
+  } else { // subroutine
+    const fir::ExtendedValue &statusVar = args[3];
+    if (!isStaticallyAbsent(statusVar)) {
+      mlir::Value statusAddr = fir::getBase(statusVar);
+      mlir::Value statusIsPresentAtRuntime =
+          builder.genIsNotNullAddr(loc, statusAddr);
+      builder.genIfThen(loc, statusIsPresentAtRuntime)
+          .genThen([&]() {
+            builder.createStoreWithConvert(loc, statusValue, statusAddr);
+          })
+          .end();
+    }
+    return {};
+  }
+}
+
+// FTELL
+fir::ExtendedValue
+IntrinsicLibrary::genFtell(std::optional<mlir::Type> resultType,
+                           llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert((args.size() == 2 && !resultType.has_value()) ||
+         (args.size() == 1 && resultType.has_value()));
+  mlir::Value unit = fir::getBase(args[0]);
+  if (!unit)
+    fir::emitFatalError(loc, "expected UNIT argument");
+  mlir::Value offsetValue = fir::runtime::genFtell(builder, loc, unit);
+  if (resultType.has_value()) { // function
+    return offsetValue;
+  } else { // subroutine
+    const fir::ExtendedValue &offsetVar = args[1];
+    if (!isStaticallyAbsent(offsetVar)) {
+      mlir::Value offsetAddr = fir::getBase(offsetVar);
+      mlir::Value offsetIsPresentAtRuntime =
+          builder.genIsNotNullAddr(loc, offsetAddr);
+      builder.genIfThen(loc, offsetIsPresentAtRuntime)
+          .genThen([&]() {
+            builder.createStoreWithConvert(loc, offsetValue, offsetAddr);
+          })
+          .end();
+    }
+    return {};
+  }
+}
+
 // GETCWD
 fir::ExtendedValue
 IntrinsicLibrary::genGetCwd(std::optional<mlir::Type> resultType,