[flang] Add GETCWD runtime and lowering intrinsics implementation

flang/docs/Intrinsics.md

@@ -967,4 +967,35 @@ program test_etime
     print *, tarray(1)
     print *, tarray(2)
 end program test_etime
+```
+
+### Non-Standard Intrinsics: GETCWD
+
+#### Description
+`GETCWD(C, STATUS)` returns current working directory.
+
+This intrinsic is provided in both subroutine and function forms; however, only one form can be used in any given program unit.
+
+*C* and *STATUS* are `INTENT(OUT)` and provide the following:
+
+|            |                                                                                                   |
+|------------|---------------------------------------------------------------------------------------------------|
+| `C`        | Current work directory. The type shall be `CHARACTER` and of default kind.       |
+| `STATUS`   | (Optional) Status flag. Returns 0 on success, a system specific and nonzero error code otherwise. The type shall be `INTEGER` and of a kind greater or equal to 4. |
+
+#### Usage and Info
+
+- **Standard:** GNU extension
+- **Class:** Subroutine, function
+- **Syntax:** `CALL GETCWD(C, STATUS)`, `STATUS = GETCWD(C)`
+
+#### Example
+```Fortran
+PROGRAM example_getcwd
+  CHARACTER(len=255) :: cwd
+  INTEGER :: status
+  CALL getcwd(cwd, status)
+  PRINT *, cwd
+  PRINT *, status
+END PROGRAM
 ```

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

@@ -232,6 +232,8 @@ struct IntrinsicLibrary {
   mlir::Value genFloor(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genFraction(mlir::Type resultType,
                           mlir::ArrayRef<mlir::Value> args);
+  fir::ExtendedValue genGetCwd(std::optional<mlir::Type> resultType,
+                               llvm::ArrayRef<fir::ExtendedValue> args);
   void genGetCommand(mlir::ArrayRef<fir::ExtendedValue> args);
   mlir::Value genGetPID(mlir::Type resultType,
                         llvm::ArrayRef<mlir::Value> args);

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

@@ -53,5 +53,10 @@ mlir::Value genGetEnvVariable(fir::FirOpBuilder &, mlir::Location,
                               mlir::Value length, mlir::Value trimName,
                               mlir::Value errmsg);
 
+/// Generate a call to the GetCwd runtime function which implements
+/// the GETCWD intrinsic.
+mlir::Value genGetCwd(fir::FirOpBuilder &builder, mlir::Location loc,
+                      mlir::Value c);
+
 } // namespace fir::runtime
 #endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_COMMAND_H

flang/include/flang/Runtime/command.h

@@ -55,6 +55,10 @@ std::int32_t RTNAME(GetEnvVariable)(const Descriptor &name,
     const Descriptor *value = nullptr, const Descriptor *length = nullptr,
     bool trim_name = true, const Descriptor *errmsg = nullptr,
     const char *sourceFile = nullptr, int line = 0);
+
+// Calls getcwd()
+std::int32_t RTNAME(GetCwd)(
+    const Descriptor &cwd, const char *sourceFile, int line);
 }
 } // namespace Fortran::runtime
 

flang/include/flang/Runtime/magic-numbers.h

@@ -68,6 +68,11 @@ Additional status code for a bad pointer DEALLOCATE.
 #endif
 #define FORTRAN_RUNTIME_STAT_BAD_POINTER_DEALLOCATION 110
 
+#if 0
+Status codes for GETCWD.
+#endif
+#define FORTRAN_RUNTIME_STAT_MISSING_CWD 111
+
 #if 0
 ieee_class_type values
 The sequence is that of F18 Clause 17.2p3, but nothing depends on that.

flang/lib/Evaluate/intrinsics.cpp

@@ -509,6 +509,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"gamma", {{"x", SameReal}}, SameReal},
     {"get_team", {{"level", DefaultInt, Rank::scalar, Optionality::optional}},
         TeamType, Rank::scalar, IntrinsicClass::transformationalFunction},
+    {"getcwd",
+        {{"c", DefaultChar, Rank::scalar, Optionality::required,
+            common::Intent::Out}},
+        TypePattern{IntType, KindCode::greaterOrEqualToKind, 4}},
     {"getpid", {}, DefaultInt},
     {"huge",
         {{"x", SameIntOrReal, Rank::anyOrAssumedRank, Optionality::required,
@@ -1398,6 +1402,12 @@ static const IntrinsicInterface intrinsicSubroutine[]{
             {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
                 common::Intent::InOut}},
         {}, Rank::elemental, IntrinsicClass::impureSubroutine},
+    {"getcwd",
+        {{"c", DefaultChar, Rank::scalar, Optionality::required,
+             common::Intent::Out},
+            {"status", TypePattern{IntType, KindCode::greaterOrEqualToKind, 4},
+                Rank::scalar, Optionality::optional, common::Intent::Out}},
+        {}, Rank::elemental, IntrinsicClass::impureSubroutine},
     {"move_alloc",
         {{"from", SameType, Rank::known, Optionality::required,
              common::Intent::InOut},
@@ -2560,7 +2570,7 @@ 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[]{{"etime"}};
+  static const std::string dualIntrinsic[]{{"etime"}, {"getcwd"}};
 
   return std::find_if(std::begin(dualIntrinsic), std::end(dualIntrinsic),
              [&name](const std::string &dualName) {

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

@@ -280,6 +280,10 @@ static constexpr IntrinsicHandler handlers[]{
        {"trim_name", asAddr, handleDynamicOptional},
        {"errmsg", asBox, handleDynamicOptional}}},
      /*isElemental=*/false},
+    {"getcwd",
+     &I::genGetCwd,
+     {{{"c", asBox}, {"status", asAddr, handleDynamicOptional}}},
+     /*isElemental=*/false},
     {"getpid", &I::genGetPID},
     {"iachar", &I::genIchar},
     {"iall",
@@ -3465,6 +3469,37 @@ mlir::Value IntrinsicLibrary::genFraction(mlir::Type resultType,
       fir::runtime::genFraction(builder, loc, fir::getBase(args[0])));
 }
 
+// GETCWD
+fir::ExtendedValue
+IntrinsicLibrary::genGetCwd(std::optional<mlir::Type> resultType,
+                            llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert((args.size() == 1 && resultType.has_value()) ||
+         (args.size() >= 1 && !resultType.has_value()));
+
+  mlir::Value cwd = fir::getBase(args[0]);
+  mlir::Value statusValue = fir::runtime::genGetCwd(builder, loc, cwd);
+
+  if (resultType.has_value()) {
+    // Function form, return status.
+    return statusValue;
+  } else {
+    // Subroutine form, store status and return none.
+    const fir::ExtendedValue &status = args[1];
+    if (!isStaticallyAbsent(status)) {
+      mlir::Value statusAddr = fir::getBase(status);
+      mlir::Value statusIsPresentAtRuntime =
+          builder.genIsNotNullAddr(loc, statusAddr);
+      builder.genIfThen(loc, statusIsPresentAtRuntime)
+          .genThen([&]() {
+            builder.createStoreWithConvert(loc, statusValue, statusAddr);
+          })
+          .end();
+    }
+  }
+
+  return {};
+}
+
 // GET_COMMAND
 void IntrinsicLibrary::genGetCommand(llvm::ArrayRef<fir::ExtendedValue> args) {
   assert(args.size() == 4);

flang/lib/Optimizer/Builder/Runtime/Command.cpp

@@ -88,3 +88,16 @@ mlir::Value fir::runtime::genGetEnvVariable(fir::FirOpBuilder &builder,
       sourceFile, sourceLine);
   return builder.create<fir::CallOp>(loc, runtimeFunc, args).getResult(0);
 }
+
+mlir::Value fir::runtime::genGetCwd(fir::FirOpBuilder &builder,
+                                    mlir::Location loc, mlir::Value cwd) {
+  mlir::func::FuncOp func =
+      fir::runtime::getRuntimeFunc<mkRTKey(GetCwd)>(loc, builder);
+  auto runtimeFuncTy = func.getFunctionType();
+  mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
+  mlir::Value sourceLine =
+      fir::factory::locationToLineNo(builder, loc, runtimeFuncTy.getInput(2));
+  llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
+      builder, loc, runtimeFuncTy, cwd, sourceFile, sourceLine);
+  return builder.create<fir::CallOp>(loc, func, args).getResult(0);
+}

flang/runtime/command.cpp

@@ -17,12 +17,19 @@
 
 #ifdef _WIN32
 #include "flang/Common/windows-include.h"
+#include <direct.h>
+#define getcwd _getcwd
+#define PATH_MAX MAX_PATH
 
 // On Windows GetCurrentProcessId returns a DWORD aka uint32_t
 #include <processthreadsapi.h>
 inline pid_t getpid() { return GetCurrentProcessId(); }
 #else
 #include <unistd.h> //getpid()
+
+#ifndef PATH_MAX
+#define PATH_MAX 4096
+#endif
 #endif
 
 namespace Fortran::runtime {
@@ -239,4 +246,23 @@ std::int32_t RTNAME(GetEnvVariable)(const Descriptor &name,
   return StatOk;
 }
 
+std::int32_t RTNAME(GetCwd)(
+    const Descriptor &cwd, const char *sourceFile, int line) {
+  Terminator terminator{sourceFile, line};
+
+  RUNTIME_CHECK(terminator, IsValidCharDescriptor(&cwd));
+
+  char *buf{(char *)AllocateMemoryOrCrash(terminator, PATH_MAX)};
+
+  if (!getcwd(buf, PATH_MAX)) {
+    return StatMissingCurrentWorkDirectory;
+  }
+
+  std::int64_t strLen{StringLength(buf)};
+  std::int32_t status{CopyCharsToDescriptor(cwd, buf, strLen)};
+
+  std::free(buf);
+  return status;
+}
+
 } // namespace Fortran::runtime

flang/runtime/stat.h

@@ -41,6 +41,7 @@ enum Stat {
   StatLocked = FORTRAN_RUNTIME_STAT_LOCKED,
   StatLockedOtherImage = FORTRAN_RUNTIME_STAT_LOCKED_OTHER_IMAGE,
   StatMissingEnvVariable = FORTRAN_RUNTIME_STAT_MISSING_ENV_VAR,
+  StatMissingCurrentWorkDirectory = FORTRAN_RUNTIME_STAT_MISSING_CWD,
   StatStoppedImage = FORTRAN_RUNTIME_STAT_STOPPED_IMAGE,
   StatUnlocked = FORTRAN_RUNTIME_STAT_UNLOCKED,
   StatUnlockedFailedImage = FORTRAN_RUNTIME_STAT_UNLOCKED_FAILED_IMAGE,

flang/test/Lower/Intrinsics/getcwd-function.f90

@@ -0,0 +1,23 @@
+! Test GETCWD with dynamically optional arguments.
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! CHECK-LABEL: func.func @_QPtest(
+! CHECK-SAME: %[[cwdArg:.*]]: !fir.boxchar<1> {fir.bindc_name = "cwd"}) -> i32 {
+integer function test(cwd)
+  CHARACTER(len=255) :: cwd
+  test = getcwd(cwd)
+  ! CHECK-NEXT:        %[[c8:.*]] = arith.constant 8 : i32
+  ! CHECK-NEXT:        %[[c255:.*]] = arith.constant 255 : index
+  ! CHECK-NEXT:        %[[DSCOPE:.*]] = fir.dummy_scope : !fir.dscope
+  ! CHECK-NEXT:        %[[cwdUnbox:.*]]:2 = fir.unboxchar %[[cwdArg]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+  ! CHECK-NEXT:        %[[cwdCast:.*]] = fir.convert %[[cwdUnbox]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,255>>
+  ! CHECK-NEXT:        %[[cwdDeclare:.*]] = fir.declare %[[cwdCast]] typeparams %[[c255]] dummy_scope %[[DSCOPE]] {uniq_name = "_QFtestEcwd"} : (!fir.ref<!fir.char<1,255>>, index, !fir.dscope) -> !fir.ref<!fir.char<1,255>>
+  ! CHECK-NEXT:        %[[test:.*]] = fir.alloca i32 {bindc_name = "test", uniq_name = "_QFtestEtest"}
+  ! CHECK-NEXT:        %[[testAddr:.*]] = fir.declare %[[test]] {uniq_name = "_QFtestEtest"} : (!fir.ref<i32>) -> !fir.ref<i32>
+  ! CHECK-NEXT:        %[[cwdBox:.*]] = fir.embox %[[cwdDeclare]] : (!fir.ref<!fir.char<1,255>>) -> !fir.box<!fir.char<1,255>>
+  ! CHECK:             %[[cwd:.*]] = fir.convert %[[cwdBox]] : (!fir.box<!fir.char<1,255>>) -> !fir.box<none>
+  ! CHECK:             %[[statusValue:.*]] = fir.call @_FortranAGetCwd(%[[cwd]], %[[VAL_9:.*]], %[[c8]]) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> i32
+  ! CHECK-NEXT:        fir.store %[[statusValue]] to %[[testAddr]] : !fir.ref<i32>
+  ! CHECK-NEXT:        %[[returnValue:.*]] = fir.load %[[testAddr]] : !fir.ref<i32>
+  ! CHECK-NEXT:        return %[[returnValue]] : i32
+end function

flang/test/Lower/Intrinsics/getcwd-optional.f90

@@ -0,0 +1,29 @@
+! Test GETCWD with dynamically optional arguments.
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+
+! CHECK-LABEL: func.func @_QPtest(
+! CHECK-SAME: %[[cwdArg:.*]]: !fir.boxchar<1> {fir.bindc_name = "cwd"},
+! CHECK-SAME: %[[statusArg:.*]]: !fir.ref<i32> {fir.bindc_name = "status", fir.optional}) {
+subroutine test(cwd, status)
+  CHARACTER(len=255) :: cwd
+  INTEGER, OPTIONAL :: status
+  call getcwd(cwd, status)
+  ! CHECK-NEXT:        %[[c0:.*]] = arith.constant 0 : i64
+  ! CHECK-NEXT:        %[[c11:.*]] = arith.constant 11 : i32
+  ! CHECK-NEXT:        %[[c255:.*]] = arith.constant 255 : index
+  ! CHECK-NEXT:        %[[DSCOPE:.*]] = fir.dummy_scope : !fir.dscope
+  ! CHECK-NEXT:        %[[cwdUnbox:.*]]:2 = fir.unboxchar %[[cwdArg]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+  ! CHECK-NEXT:        %[[cwdCast:.*]] = fir.convert %[[cwdUnbox]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,255>>
+  ! CHECK-NEXT:        %[[cwdDeclare:.*]] = fir.declare %[[cwdCast]] typeparams %[[c255]] dummy_scope %[[DSCOPE]] {uniq_name = "_QFtestEcwd"} : (!fir.ref<!fir.char<1,255>>, index, !fir.dscope) -> !fir.ref<!fir.char<1,255>>
+  ! CHECK-NEXT:        %[[statusAddr:.*]] = fir.declare %[[statusArg]] dummy_scope %[[DSCOPE]] {fortran_attrs = #fir.var_attrs<optional>, uniq_name = "_QFtestEstatus"} : (!fir.ref<i32>, !fir.dscope) -> !fir.ref<i32>
+  ! CHECK-NEXT:       %[[cwdBox:.*]] = fir.embox %[[cwdDeclare]] : (!fir.ref<!fir.char<1,255>>) -> !fir.box<!fir.char<1,255>>
+  ! CHECK:            %[[cwd:.*]] = fir.convert %[[cwdBox]] : (!fir.box<!fir.char<1,255>>) -> !fir.box<none>
+  ! CHECK:            %[[statusValue:.*]] = fir.call @_FortranAGetCwd(%[[cwd]], %[[VAL_8:.*]], %[[c11]]) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> i32
+  ! CHECK-NEXT:       %[[statusCast:.*]] = fir.convert %[[statusAddr]] : (!fir.ref<i32>) -> i64
+  ! CHECK-NEXT:       %[[isPresent:.*]] = arith.cmpi ne, %[[statusCast]], %[[c0]] : i64
+  ! CHECK-NEXT:       fir.if %[[isPresent]] {
+  ! CHECK-NEXT:         fir.store %[[statusValue]] to %[[statusAddr]] : !fir.ref<i32>
+  ! CHECK-NEXT:       }
+  ! CHECK-NEXT:       return
+end subroutine

flang/test/Lower/Intrinsics/getcwd.f90

@@ -0,0 +1,44 @@
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! CHECK-LABEL: func.func @_QPcwd_only(
+! CHECK-SAME: %[[cwdArg:.*]]: !fir.boxchar<1> {fir.bindc_name = "cwd"}) {
+subroutine cwd_only(cwd)
+  CHARACTER(len=255) :: cwd
+  call getcwd(cwd)
+  ! CHECK-NEXT:        %[[c7:.*]] = arith.constant 7 : i32
+  ! CHECK-NEXT:        %[[c255:.*]] = arith.constant 255 : index
+  ! CHECK-NEXT:        %[[DSCOPE:.*]] = fir.dummy_scope : !fir.dscope
+  ! CHECK-NEXT:        %[[cwdUnbox:.*]]:2 = fir.unboxchar %[[cwdArg]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+  ! CHECK-NEXT:        %[[cwdCast:.*]] = fir.convert %[[cwdUnbox]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,255>>
+  ! CHECK-NEXT:        %[[cwdDeclare:.*]] = fir.declare %[[cwdCast]] typeparams %[[c255]] dummy_scope %[[DSCOPE]] {uniq_name = "_QFcwd_onlyEcwd"} : (!fir.ref<!fir.char<1,255>>, index, !fir.dscope) -> !fir.ref<!fir.char<1,255>>
+  ! CHECK-NEXT:        %[[cwdBox:.*]] = fir.embox %[[cwdDeclare]] : (!fir.ref<!fir.char<1,255>>) -> !fir.box<!fir.char<1,255>>
+  ! CHECK:             %[[cwd:.*]] = fir.convert %[[cwdBox]] : (!fir.box<!fir.char<1,255>>) -> !fir.box<none>
+  ! CHECK:             %[[statusValue:.*]] = fir.call @_FortranAGetCwd(%[[cwd]], %[[VAL_7:.*]], %[[c7]]) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> i32
+  ! CHECK-NEXT:        return
+end subroutine cwd_only
+
+! CHECK-LABEL: func.func @_QPall_arguments(
+! CHECK-SAME: %[[cwdArg:.*]]: !fir.boxchar<1> {fir.bindc_name = "cwd"},
+! CHECK-SAME: %[[statusArg:.*]]: !fir.ref<i32> {fir.bindc_name = "status"}) {
+subroutine all_arguments(cwd, status)
+  CHARACTER(len=255) :: cwd
+  INTEGER :: status
+  call getcwd(cwd, status)
+  ! CHECK-NEXT:        %[[c0:.*]] = arith.constant 0 : i64
+  ! CHECK-NEXT:        %[[c26:.*]] = arith.constant 26 : i32
+  ! CHECK-NEXT:        %[[c255:.*]] = arith.constant 255 : index
+  ! CHECK-NEXT:        %[[DSCOPE:.*]] = fir.dummy_scope : !fir.dscope
+  ! CHECK-NEXT:        %[[cwdUnbox:.*]]:2 = fir.unboxchar %[[cwdArg]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+  ! CHECK-NEXT:        %[[cwdCast:.*]] = fir.convert %[[cwdUnbox]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,255>>
+  ! CHECK-NEXT:        %[[cwdDeclare:.*]] = fir.declare %[[cwdCast]] typeparams %[[c255]] dummy_scope %[[DSCOPE]] {uniq_name = "_QFall_argumentsEcwd"} : (!fir.ref<!fir.char<1,255>>, index, !fir.dscope) -> !fir.ref<!fir.char<1,255>>
+  ! CHECK-NEXT:        %[[statusAddr:.*]] = fir.declare %[[statusArg]] dummy_scope %0 {uniq_name = "_QFall_argumentsEstatus"} : (!fir.ref<i32>, !fir.dscope) -> !fir.ref<i32>
+  ! CHECK-NEXT:       %[[cwdBox:.*]] = fir.embox %[[cwdDeclare]] : (!fir.ref<!fir.char<1,255>>) -> !fir.box<!fir.char<1,255>>
+  ! CHECK:            %[[cwd:.*]] = fir.convert %[[cwdBox]] : (!fir.box<!fir.char<1,255>>) -> !fir.box<none>
+  ! CHECK:            %[[statusValue:.*]] = fir.call @_FortranAGetCwd(%[[cwd]], %[[VAL_8:.*]], %[[c26]]) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> i32
+  ! CHECK-NEXT:       %[[statusCast:.*]] = fir.convert %[[statusAddr]] : (!fir.ref<i32>) -> i64
+  ! CHECK-NEXT:       %[[isPresent:.*]] = arith.cmpi ne, %[[statusCast]], %[[c0]] : i64
+  ! CHECK-NEXT:       fir.if %[[isPresent]] {
+  ! CHECK-NEXT:         fir.store %[[statusValue]] to %[[statusAddr]] : !fir.ref<i32>
+  ! CHECK-NEXT:       }
+  ! CHECK-NEXT:       return
+end subroutine all_arguments

flang/test/Semantics/getcwd.f90

@@ -0,0 +1,35 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+! Tests for the GETCWD intrinsics
+
+subroutine bad_kind_error(cwd, status)
+  CHARACTER(len=255) :: cwd
+  INTEGER(2) :: status
+  !ERROR: Actual argument for 'status=' has bad type or kind 'INTEGER(2)'
+  call getcwd(cwd, status)
+end subroutine bad_kind_error
+
+subroutine bad_args_error()
+  !ERROR: missing mandatory 'c=' argument
+  call getcwd()
+end subroutine bad_args_error
+
+subroutine bad_apply_form(cwd)
+  CHARACTER(len=255) :: cwd
+  INTEGER :: status
+  !Declaration of 'getcwd'
+  call getcwd(cwd, status)
+  !ERROR: Cannot call subroutine 'getcwd' like a function
+  status = getcwd(cwd)
+end subroutine bad_apply_form
+
+subroutine good_subroutine(cwd, status)
+  CHARACTER(len=255) :: cwd
+  INTEGER :: status
+  call getcwd(cwd, status)
+end subroutine good_subroutine
+
+subroutine good_function(cwd, status)
+  CHARACTER(len=255) :: cwd
+  INTEGER :: status
+  status = getcwd(cwd)
+end subroutine good_function