diff --git a/flang-rt/lib/runtime/command.cpp b/flang-rt/lib/runtime/command.cpp index d2e09639fdb59..b69143bf458ba 100644 --- a/flang-rt/lib/runtime/command.cpp +++ b/flang-rt/lib/runtime/command.cpp @@ -12,6 +12,7 @@ #include "flang-rt/runtime/stat.h" #include "flang-rt/runtime/terminator.h" #include "flang-rt/runtime/tools.h" +#include #include #include @@ -19,6 +20,7 @@ #include "flang/Common/windows-include.h" #include #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 //getpid() +#include //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 diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md index ddb053d7a3d0b..e885ceca25aad 100644 --- a/flang/docs/Intrinsics.md +++ b/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. diff --git a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h index a31bbd0a1bd88..335d318e164c2 100644 --- a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h +++ b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h @@ -439,6 +439,8 @@ struct IntrinsicLibrary { void genThreadFenceSystem(llvm::ArrayRef); fir::ExtendedValue genTrim(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genUbound(mlir::Type, llvm::ArrayRef); + fir::ExtendedValue genUnlink(std::optional resultType, + llvm::ArrayRef args); fir::ExtendedValue genUnpack(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genVerify(mlir::Type, llvm::ArrayRef); mlir::Value genVoteAllSync(mlir::Type, llvm::ArrayRef); diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Command.h b/flang/include/flang/Optimizer/Builder/Runtime/Command.h index ba0d3b094f40c..5880a703ed92e 100644 --- a/flang/include/flang/Optimizer/Builder/Runtime/Command.h +++ b/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 diff --git a/flang/include/flang/Runtime/command.h b/flang/include/flang/Runtime/command.h index e0069a9bc0321..16854c981ca23 100644 --- a/flang/include/flang/Runtime/command.h +++ b/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_ diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index 0c15ec5473965..0eb8419491a61 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/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); } diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp index 9029ea69dd5c4..87bab1ffde2cd 100644 --- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp +++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp @@ -928,6 +928,10 @@ static constexpr IntrinsicHandler handlers[]{ /*isElemental=*/false}, {"umaskl", &I::genMask}, {"umaskr", &I::genMask}, + {"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 resultType, + llvm::ArrayRef 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, diff --git a/flang/lib/Optimizer/Builder/Runtime/Command.cpp b/flang/lib/Optimizer/Builder/Runtime/Command.cpp index 9b814c3395aa1..27ea5961837e6 100644 --- a/flang/lib/Optimizer/Builder/Runtime/Command.cpp +++ b/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(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(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 args = fir::runtime::createArguments( + builder, loc, runtimeFuncTy, path, pathLength, sourceFile, sourceLine); + return builder.create(loc, func, args).getResult(0); +} diff --git a/flang/test/Lower/Intrinsics/unlink-func.f90 b/flang/test/Lower/Intrinsics/unlink-func.f90 new file mode 100644 index 0000000000000..15025a7c2f151 --- /dev/null +++ b/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) -> (!fir.ref, !fir.ref) +!CHECK-DAG: %[[src_path_addr:.*]] = fir.address_of(@_{{.*}}) : !fir.ref +!CHECK-DAG: %[[line_value:.*]] = arith.constant {{.*}} : i64 +!CHECK-DAG: %[[path:.*]] = fir.convert {{.*}} (!fir.ref>) -> !fir.ref +!CHECK-DAG: %[[path_len:.*]] = fir.convert {{.*}} : (index) -> i64 +!CHECK-DAG: %[[src_path:.*]] = fir.convert %[[src_path_addr]] : (!fir.ref) -> !fir.ref +!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 +!CHECK-DAG: %[[load_result:.*]] = fir.load %[[func_result_decl]]#0 : !fir.ref +!CHECK: return %[[load_result]] : i32 +unlink_test = unlink(path) +end function unlink_test diff --git a/flang/test/Lower/Intrinsics/unlink-sub.f90 b/flang/test/Lower/Intrinsics/unlink-sub.f90 new file mode 100644 index 0000000000000..78d2b1096ae82 --- /dev/null +++ b/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>, index) + !CHECK-DAG: %[[path_decl:.*]]:2 = hlfir.declare %[[unbox_path]]#0 typeparams %[[unbox_path]]#1 dummy_scope %[[scope]] {uniq_name = "_QFpath_onlyEpath"} : (!fir.ref>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref>) + !CHECK-DAG: %[[src_path_addr:.*]] = fir.address_of(@_{{.*}}) : !fir.ref> + !CHECK-DAG: %[[line_value:.*]] = arith.constant {{.*}} : i64 + !CHECK-DAG: %[[path:.*]] = fir.convert %[[path_decl]]#1 : (!fir.ref>) -> !fir.ref + !CHECK-DAG: %[[path_len:.*]] = fir.convert %[[unbox_path]]#1 : (index) -> i64 + !CHECK-DAG: %[[src_path:.*]] = fir.convert %[[src_path_addr]] : (!fir.ref) -> !fir.ref + !CHECK-DAG: %[[line:.*]] = fir.convert %[[line_value]] : (i64) -> i32 + !CHECK: fir.call @_FortranAUnlink(%[[path]], %[[path_len]], %[[src_path]], %[[line]]) + !CHECK-SAME: : (!fir.ref, i64, !fir.ref, 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 {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>, index) + !CHECK-DAG: %[[path_decl:.*]]:2 = hlfir.declare %[[unbox_path]]#0 typeparams %[[unbox_path]]#1 dummy_scope %[[scope]] {uniq_name = "_QFall_argumentsEpath"} : (!fir.ref>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref>) + !CHECK-DAG: %[[status_decl:.*]]:2 = hlfir.declare %[[dummyStat]] dummy_scope %[[scope]] {uniq_name = "_QFall_argumentsEstatus"} : (!fir.ref, !fir.dscope) -> (!fir.ref, !fir.ref) + !CHECK-DAG: %[[src_path_addr:.*]] = fir.address_of(@_{{.*}}) : !fir.ref> + !CHECK-DAG: %[[line_value:.*]] = arith.constant {{.*}} : i64 + !CHECK-DAG: %[[path:.*]] = fir.convert %[[path_decl]]#1 : (!fir.ref>) -> !fir.ref + !CHECK-DAG: %[[path_len:.*]] = fir.convert %[[unbox_path]]#1 : (index) -> i64 + !CHECK-DAG: %[[src_path:.*]] = fir.convert %[[src_path_addr]] : (!fir.ref) -> !fir.ref + !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, i64, !fir.ref, i32) + !CHECK-SAME: -> i32 + + !CHECK-DAG: %[[status_i64:.*]] = fir.convert %[[status_decl]]#0 : (!fir.ref) -> 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 + !CHECK-NEXT: } + call unlink(path, status) + !CHECK: return +end subroutine all_arguments + !CHECK: }