[flang][intrinsic] add nonstandard intrinsic unlink

flang-rt/lib/runtime/command.cpp

@@ -12,13 +12,15 @@
 #include "flang-rt/runtime/stat.h"
 #include "flang-rt/runtime/terminator.h"
 #include "flang-rt/runtime/tools.h"
+#include <cerrno>
 #include <cstdlib>
 #include <limits>
 
 #ifdef _WIN32
 #include "flang/Common/windows-include.h"
 #include <direct.h>
 #define getcwd _getcwd
+#define unlink _unlink
 #define PATH_MAX MAX_PATH
 
 #ifdef _MSC_VER
@@ -27,7 +29,7 @@
 inline pid_t getpid() { return GetCurrentProcessId(); }
 #endif
 #else
-#include <unistd.h> //getpid()
+#include <unistd.h> //getpid() unlink()
 
 #ifndef PATH_MAX
 #define PATH_MAX 4096
@@ -307,4 +309,19 @@ std::int32_t RTNAME(Hostnm)(
   return status;
 }
 
+std::int32_t RTNAME(Unlink)(
+    const char *str, size_t strLength, const char *sourceFile, int line) {
+  Terminator terminator{sourceFile, line};
+
+  auto pathLength = TrimTrailingSpaces(str, strLength);
+  auto path = SaveDefaultCharacter(str, pathLength, terminator);
+
+  std::int32_t status{0};
+
+  if (unlink(path.get()) != 0) {
+    status = errno;
+  }
+
+  return status;
+}
 } // namespace Fortran::runtime

flang/docs/Intrinsics.md

@@ -1091,6 +1091,48 @@ end program rename_proc
 This intrinsic is an alias for `CPU_TIME`: supporting both a subroutine and a
 function form.
 
+### Non-Standard Intrinsics: UNLINK
+
+#### Description
+`UNLINK(PATH [, STATUS])` deletes a link to a file.
+
+This intrinsic is provided in both subroutine and function forms; however, only
+one form can be used in any given program unit.
+
+| ARGUMENT | INTENT | TYPE        |  KIND   | Description                     |
+|----------|--------|-------------|---------|---------------------------------|
+| `PATH`   | `IN`   | `CHARACTER` | default | The path of the file to unlink. |
+| `STATUS` | `OUT`  | `INTEGER`   | default | Optional. Returns 0 on success, C's `errno` on failure. |
+
+#### Usage and Info
+
+- **Standard:** GNU extension
+- **Class:** Subroutine, function
+- **Syntax:** `CALL UNLINK(PATH [, STATUS])`, `STATUS = UNLINK(PATH)`
+
+#### Example
+The following example just prints "hello.txt doesn't exist".
+```Fortran
+SUBROUTINE try_unlink_hello_again()
+  INTEGER :: status
+  CALL UNLINK("hello.txt", status)
+  IF (status .NE. 0) PRINT *, "hello.txt doesn't exist"
+END SUBROUTINE
+
+PROGRAM example_unlink
+  INTEGER :: hello
+  ! Create ./hello.txt
+  OPEN(newunit=hello, file="hello.txt")
+  WRITE (hello, *), "Hello!"
+  CLOSE(hello)
+
+  ! Delete ./hello.txt
+  IF (UNLINK("hello.txt") .NE. 0) PRINT *, "didn't create a file"
+
+  CALL try_unlink_hello_again()
+END PROGRAM
+```
+
 ### Non-standard Intrinsics: LNBLNK
 This intrinsic is an alias for `LEN_TRIM`, without the optional KIND argument.
 

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

@@ -439,6 +439,8 @@ struct IntrinsicLibrary {
   void genThreadFenceSystem(llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genTrim(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genUbound(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+  fir::ExtendedValue genUnlink(std::optional<mlir::Type> resultType,
+                               llvm::ArrayRef<fir::ExtendedValue> args);
   fir::ExtendedValue genUnpack(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genVerify(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genVoteAllSync(mlir::Type, llvm::ArrayRef<mlir::Value>);

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

@@ -68,5 +68,10 @@ mlir::Value genHostnm(fir::FirOpBuilder &builder, mlir::Location loc,
 void genPerror(fir::FirOpBuilder &builder, mlir::Location loc,
                mlir::Value string);
 
+/// Generate a call to the Unlink runtime function which implements
+/// the UNLINK intrinsic.
+mlir::Value genUnlink(fir::FirOpBuilder &builder, mlir::Location loc,
+                      mlir::Value path, mlir::Value pathLength);
+
 } // namespace fir::runtime
 #endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_COMMAND_H

flang/include/flang/Runtime/command.h

@@ -63,7 +63,12 @@ std::int32_t RTNAME(GetCwd)(
 // Calls hostnm()
 std::int32_t RTNAME(Hostnm)(
     const Descriptor &res, const char *sourceFile, int line);
-}
+
+// Calls unlink()
+std::int32_t RTNAME(Unlink)(
+    const char *path, size_t pathLength, const char *sourceFile, int line);
+
+} // extern "C"
 } // namespace Fortran::runtime
 
 #endif // FORTRAN_RUNTIME_COMMAND_H_

flang/lib/Evaluate/intrinsics.cpp

@@ -1010,6 +1010,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
         KINDUnsigned},
     {"umaskl", {{"i", AnyInt}, DefaultingKIND}, KINDUnsigned},
     {"umaskr", {{"i", AnyInt}, DefaultingKIND}, KINDUnsigned},
+    {"unlink", {{"path", DefaultChar, Rank::scalar}}, DefaultInt, Rank::scalar,
+        IntrinsicClass::transformationalFunction},
     {"unpack",
         {{"vector", SameType, Rank::vector}, {"mask", AnyLogical, Rank::array},
             {"field", SameType, Rank::conformable}},
@@ -1319,6 +1321,8 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
         "abs"},
 };
 
+// Must be sorted by name. The rank of the return value is ignored since
+// subroutines are do not have a return value.
 static const IntrinsicInterface intrinsicSubroutine[]{
     {"abort", {}, {}, Rank::elemental, IntrinsicClass::impureSubroutine},
     {"atomic_add",
@@ -1631,6 +1635,12 @@ static const IntrinsicInterface intrinsicSubroutine[]{
         {{"seconds", AnyInt, Rank::scalar, Optionality::required,
             common::Intent::In}},
         {}, Rank::elemental, IntrinsicClass::impureSubroutine},
+    {"unlink",
+        {{"path", DefaultChar, Rank::scalar, Optionality::required,
+             common::Intent::In},
+            {"status", DefaultInt, Rank::scalar, Optionality::optional,
+                common::Intent::Out}},
+        {}, Rank::elemental, IntrinsicClass::impureSubroutine},
 };
 
 // Finds a built-in derived type and returns it as a DynamicType.
@@ -2800,7 +2810,7 @@ bool IntrinsicProcTable::Implementation::IsDualIntrinsic(
   // 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}};
+      {"hostnm"s}, {"rename"s}, {"second"s}, {"system"s}, {"unlink"s}};
 
   return llvm::is_contained(dualIntrinsic, name);
 }

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

@@ -928,6 +928,10 @@ static constexpr IntrinsicHandler handlers[]{
      /*isElemental=*/false},
     {"umaskl", &I::genMask<mlir::arith::ShLIOp>},
     {"umaskr", &I::genMask<mlir::arith::ShRUIOp>},
+    {"unlink",
+     &I::genUnlink,
+     {{{"path", asAddr}, {"status", asAddr, handleDynamicOptional}}},
+     /*isElemental=*/false},
     {"unpack",
      &I::genUnpack,
      {{{"vector", asBox}, {"mask", asBox}, {"field", asBox}}},
@@ -8494,6 +8498,39 @@ static mlir::Value createExtremumCompare(mlir::Location loc,
   return result;
 }
 
+// UNLINK
+fir::ExtendedValue
+IntrinsicLibrary::genUnlink(std::optional<mlir::Type> resultType,
+                            llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert((resultType.has_value() && args.size() == 1) ||
+         (!resultType.has_value() && args.size() >= 1 && args.size() <= 2));
+
+  mlir::Value path = fir::getBase(args[0]);
+  mlir::Value pathLength = fir::getLen(args[0]);
+  mlir::Value statusValue =
+      fir::runtime::genUnlink(builder, loc, path, pathLength);
+
+  if (resultType.has_value()) {
+    // Function form, return status.
+    return builder.createConvert(loc, *resultType, statusValue);
+  }
+
+  // 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 {};
+}
+
 // UNPACK
 fir::ExtendedValue
 IntrinsicLibrary::genUnpack(mlir::Type resultType,

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

@@ -125,3 +125,17 @@ void fir::runtime::genPerror(fir::FirOpBuilder &builder, mlir::Location loc,
       fir::runtime::createArguments(builder, loc, runtimeFuncTy, string);
   builder.create<fir::CallOp>(loc, runtimeFunc, args);
 }
+
+mlir::Value fir::runtime::genUnlink(fir::FirOpBuilder &builder,
+                                    mlir::Location loc, mlir::Value path,
+                                    mlir::Value pathLength) {
+  mlir::func::FuncOp func =
+      fir::runtime::getRuntimeFunc<mkRTKey(Unlink)>(loc, builder);
+  auto runtimeFuncTy = func.getFunctionType();
+  mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
+  mlir::Value sourceLine =
+      fir::factory::locationToLineNo(builder, loc, runtimeFuncTy.getInput(1));
+  llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
+      builder, loc, runtimeFuncTy, path, pathLength, sourceFile, sourceLine);
+  return builder.create<fir::CallOp>(loc, func, args).getResult(0);
+}

flang/test/Lower/Intrinsics/unlink-func.f90

@@ -0,0 +1,24 @@
+!RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s
+
+!CHECK-LABEL: func.func @_QPunlink_test
+!CHECK-SAME:  %[[dummyPath:.*]]: !fir.boxchar<1> {fir.bindc_name = "path"}) -> i32 {
+integer function unlink_test(path)
+CHARACTER(len=255) :: path
+
+!CHECK-DAG:   %[[func_result:.*]] = fir.alloca i32 {bindc_name = "unlink_test", uniq_name = "_QFunlink_testEunlink_test"}
+!CHECK-DAG:   %[[func_result_decl:.*]]:{{.*}} = hlfir.declare %[[func_result]] {uniq_name = "_QFunlink_testEunlink_test"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+!CHECK-DAG:   %[[src_path_addr:.*]] = fir.address_of(@_{{.*}}) : !fir.ref<!fir.char<1,{{.*}}>
+!CHECK-DAG:   %[[line_value:.*]] = arith.constant {{.*}} : i64
+!CHECK-DAG:   %[[path:.*]] = fir.convert {{.*}} (!fir.ref<!fir.char<1,{{.*}}>>) -> !fir.ref<i8>
+!CHECK-DAG:   %[[path_len:.*]] = fir.convert {{.*}} : (index) -> i64
+!CHECK-DAG:   %[[src_path:.*]] = fir.convert %[[src_path_addr]] : (!fir.ref<!fir.char<1,{{.*}}>) -> !fir.ref<i8>
+!CHECK-DAG:   %[[line:.*]] = fir.convert %[[line_value]] : (i64) -> i32
+!CHECK:       %[[unlink_result:.*]] = fir.call @_FortranAUnlink(%[[path]], %[[path_len]], %[[src_path]], %[[line]])
+!CHECK-SAME:  -> i32
+
+! Check _FortranAUnlink result code handling
+!CHECK-DAG:   hlfir.assign %[[unlink_result]] to %[[func_result_decl]]#0 : i32, !fir.ref<i32>
+!CHECK-DAG:   %[[load_result:.*]] = fir.load %[[func_result_decl]]#0 : !fir.ref<i32>
+!CHECK:       return %[[load_result]] : i32
+unlink_test = unlink(path)
+end function unlink_test

flang/test/Lower/Intrinsics/unlink-sub.f90

@@ -0,0 +1,54 @@
+!RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s
+
+!CHECK-LABEL: func.func @_QPpath_only
+!CHECK-SAME:    %[[dummyPath:.*]]: !fir.boxchar<1> {fir.bindc_name = "path"}) {
+subroutine path_only(path)
+    CHARACTER(len=*) :: path
+    !CHECK-DAG:    %[[scope:.*]] = fir.dummy_scope : !fir.dscope
+    !CHECK-DAG:    %[[unbox_path:.*]]:2 = fir.unboxchar %[[dummyPath]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+    !CHECK-DAG:    %[[path_decl:.*]]:2 = hlfir.declare %[[unbox_path]]#0 typeparams %[[unbox_path]]#1 dummy_scope %[[scope]] {uniq_name = "_QFpath_onlyEpath"} : (!fir.ref<!fir.char<1,?>>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+    !CHECK-DAG:    %[[src_path_addr:.*]] = fir.address_of(@_{{.*}}) : !fir.ref<!fir.char<1,{{.*}}>>
+    !CHECK-DAG:    %[[line_value:.*]] = arith.constant {{.*}} : i64
+    !CHECK-DAG:    %[[path:.*]] = fir.convert %[[path_decl]]#1 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
+    !CHECK-DAG:    %[[path_len:.*]] = fir.convert %[[unbox_path]]#1 : (index) -> i64
+    !CHECK-DAG:    %[[src_path:.*]] = fir.convert %[[src_path_addr]] : (!fir.ref<!fir.char<1,{{.*}}>) -> !fir.ref<i8>
+    !CHECK-DAG:    %[[line:.*]] = fir.convert %[[line_value]] : (i64) -> i32
+    !CHECK:        fir.call @_FortranAUnlink(%[[path]], %[[path_len]], %[[src_path]], %[[line]])
+    !CHECK-SAME:   : (!fir.ref<i8>, i64, !fir.ref<i8>, i32)
+    !CHECK-SAME:   -> i32
+    call unlink(path)
+    !CHECK:        return
+end subroutine path_only
+    !CHECK:         }
+
+    !CHECK-LABEL: func.func @_QPall_arguments
+    !CHECK-SAME:    %[[dummyPath:.*]]: !fir.boxchar<1> {fir.bindc_name = "path"}
+    !CHECK-SAME:    %[[dummyStat:.*]]: !fir.ref<i32> {fir.bindc_name = "status"}
+    !CHECK-SAME:    ) {
+subroutine all_arguments(path, status)
+    CHARACTER(len=*) :: path
+    INTEGER :: status
+    !CHECK-DAG:    %[[scope:.*]] = fir.dummy_scope : !fir.dscope
+    !CHECK-DAG:    %[[unbox_path:.*]]:2 = fir.unboxchar %[[dummyPath]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+    !CHECK-DAG:    %[[path_decl:.*]]:2 = hlfir.declare %[[unbox_path]]#0 typeparams %[[unbox_path]]#1 dummy_scope %[[scope]] {uniq_name = "_QFall_argumentsEpath"} : (!fir.ref<!fir.char<1,?>>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+    !CHECK-DAG:    %[[status_decl:.*]]:2 = hlfir.declare %[[dummyStat]] dummy_scope %[[scope]] {uniq_name = "_QFall_argumentsEstatus"} : (!fir.ref<i32>, !fir.dscope) -> (!fir.ref<i32>, !fir.ref<i32>)
+    !CHECK-DAG:    %[[src_path_addr:.*]] = fir.address_of(@_{{.*}}) : !fir.ref<!fir.char<1,{{.*}}>>
+    !CHECK-DAG:    %[[line_value:.*]] = arith.constant {{.*}} : i64
+    !CHECK-DAG:    %[[path:.*]] = fir.convert %[[path_decl]]#1 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
+    !CHECK-DAG:    %[[path_len:.*]] = fir.convert %[[unbox_path]]#1 : (index) -> i64
+    !CHECK-DAG:    %[[src_path:.*]] = fir.convert %[[src_path_addr]] : (!fir.ref<!fir.char<1,{{.*}}>) -> !fir.ref<i8>
+    !CHECK-DAG:    %[[line:.*]] = fir.convert %[[line_value]] : (i64) -> i32
+    !CHECK:        %[[unlink_result:.*]] = fir.call @_FortranAUnlink(%[[path]], %[[path_len]], %[[src_path]], %[[line]])
+    !CHECK-SAME:   : (!fir.ref<i8>, i64, !fir.ref<i8>, i32)
+    !CHECK-SAME:   -> i32
+
+    !CHECK-DAG:    %[[status_i64:.*]] = fir.convert %[[status_decl]]#0 : (!fir.ref<i32>) -> i64
+    !CHECK-DAG:    %[[c_null:.*]] = arith.constant 0 : i64
+    !CHECK-DAG:    %[[cmp_result:.*]] = arith.cmpi ne, %[[status_i64]], %[[c_null]] : i64
+    !CHECK:        fir.if %[[cmp_result]] {
+    !CHECK-NEXT:   fir.store %[[unlink_result]] to %[[status_decl]]#0 : !fir.ref<i32>
+    !CHECK-NEXT:   }
+    call unlink(path, status)
+    !CHECK:        return
+end subroutine all_arguments
+    !CHECK:        }