From 61af05fe82c6989351c08de8d9eac4dc51f4ef79 Mon Sep 17 00:00:00 2001 From: Eugene Epshteyn Date: Fri, 4 Apr 2025 16:26:08 -0400 Subject: [PATCH] [flang] Add runtime and lowering implementation for extended intrinsic PUTENV (#134412) Implement extended intrinsic PUTENV, both function and subroutine forms. Add PUTENV documentation to flang/docs/Intrinsics.md. Add functional and semantic unit tests. --- .../include/flang-rt/runtime/environment.h | 7 ++ flang-rt/lib/runtime/command.cpp | 50 +++++++++++++++ flang-rt/lib/runtime/environment.cpp | 64 +++++++++++++++++++ flang/docs/Intrinsics.md | 39 ++++++++++- .../flang/Optimizer/Builder/IntrinsicCall.h | 2 + .../flang/Optimizer/Builder/Runtime/Command.h | 5 ++ flang/include/flang/Runtime/command.h | 4 ++ flang/lib/Evaluate/intrinsics.cpp | 12 +++- flang/lib/Optimizer/Builder/IntrinsicCall.cpp | 37 +++++++++++ .../lib/Optimizer/Builder/Runtime/Command.cpp | 14 ++++ flang/test/Lower/Intrinsics/putenv-func.f90 | 24 +++++++ flang/test/Lower/Intrinsics/putenv-sub.f90 | 54 ++++++++++++++++ flang/test/Semantics/putenv.f90 | 42 ++++++++++++ 13 files changed, 350 insertions(+), 4 deletions(-) create mode 100644 flang/test/Lower/Intrinsics/putenv-func.f90 create mode 100644 flang/test/Lower/Intrinsics/putenv-sub.f90 create mode 100644 flang/test/Semantics/putenv.f90 diff --git a/flang-rt/include/flang-rt/runtime/environment.h b/flang-rt/include/flang-rt/runtime/environment.h index ca6c2a7d4448..16258b3bbba9 100644 --- a/flang-rt/include/flang-rt/runtime/environment.h +++ b/flang-rt/include/flang-rt/runtime/environment.h @@ -45,6 +45,13 @@ struct ExecutionEnvironment { const char *GetEnv( const char *name, std::size_t name_length, const Terminator &terminator); + std::int32_t SetEnv(const char *name, std::size_t name_length, + const char *value, std::size_t value_length, + const Terminator &terminator); + + std::int32_t UnsetEnv( + const char *name, std::size_t name_length, const Terminator &terminator); + int argc{0}; const char **argv{nullptr}; char **envp{nullptr}; diff --git a/flang-rt/lib/runtime/command.cpp b/flang-rt/lib/runtime/command.cpp index b69143bf458b..a4e8e31ad027 100644 --- a/flang-rt/lib/runtime/command.cpp +++ b/flang-rt/lib/runtime/command.cpp @@ -309,6 +309,55 @@ std::int32_t RTNAME(Hostnm)( return status; } +std::int32_t RTNAME(PutEnv)( + const char *str, size_t str_length, const char *sourceFile, int line) { + Terminator terminator{sourceFile, line}; + + RUNTIME_CHECK(terminator, str && str_length); + + // Note: don't trim the input string, because the user should be able + // to set the value to all spaces if necessary. + + // While Fortran's putenv() extended intrinsic sementics loosly follow + // Linux C library putenv(), don't actually use putenv() on Linux, because + // it takes the passed string pointer and incorporates it into the + // environment without copy. To make this safe, one would have to copy + // the passed string into some allocated memory, but then there's no good + // way to deallocate it. Instead, use the implementation from + // ExecutionEnvironment, which does the right thing for both Windows and + // Linux. + + std::int32_t status{0}; + + // Split the input string into name and value substrings. Note: + // if input string is in "name=value" form, then we set variable "name" with + // value "value". If the input string is in "name=" form, then we delete + // the variable "name". + + const char *str_end = str + str_length; + const char *str_sep = std::find(str, str_end, '='); + if (str_sep == str_end) { + // No separator, invalid input string + status = EINVAL; + } else if ((str_sep + 1) == str_end) { + // "name=" form, which means we need to delete this variable + status = executionEnvironment.UnsetEnv(str, str_sep - str, terminator); + } else { + // Example: consider str "abc=defg", str_length = 8 + // + // addr: 05 06 07 08 09 10 11 12 13 + // str@addr: a b c = d e f g ?? + // + // str = 5, str_end = 13, str_sep = 8, name length: str_sep - str = 3 + // value ptr: str_sep + 1 = 9, value length: 4 + // + status = executionEnvironment.SetEnv( + str, str_sep - str, str_sep + 1, str_end - str_sep - 1, terminator); + } + + return status; +} + std::int32_t RTNAME(Unlink)( const char *str, size_t strLength, const char *sourceFile, int line) { Terminator terminator{sourceFile, line}; @@ -324,4 +373,5 @@ std::int32_t RTNAME(Unlink)( return status; } + } // namespace Fortran::runtime diff --git a/flang-rt/lib/runtime/environment.cpp b/flang-rt/lib/runtime/environment.cpp index cf2c65dd4fac..1d5304254ed0 100644 --- a/flang-rt/lib/runtime/environment.cpp +++ b/flang-rt/lib/runtime/environment.cpp @@ -181,4 +181,68 @@ const char *ExecutionEnvironment::GetEnv( return std::getenv(cStyleName.get()); } + +std::int32_t ExecutionEnvironment::SetEnv(const char *name, + std::size_t name_length, const char *value, std::size_t value_length, + const Terminator &terminator) { + + RUNTIME_CHECK(terminator, name && name_length && value && value_length); + + OwningPtr cStyleName{ + SaveDefaultCharacter(name, name_length, terminator)}; + RUNTIME_CHECK(terminator, cStyleName); + + OwningPtr cStyleValue{ + SaveDefaultCharacter(value, value_length, terminator)}; + RUNTIME_CHECK(terminator, cStyleValue); + + std::int32_t status{0}; + +#ifdef _WIN32 + + status = _putenv_s(cStyleName.get(), cStyleValue.get()); + +#else + + constexpr int overwrite = 1; + status = setenv(cStyleName.get(), cStyleValue.get(), overwrite); + +#endif + + if (status != 0) { + status = errno; + } + + return status; +} + +std::int32_t ExecutionEnvironment::UnsetEnv( + const char *name, std::size_t name_length, const Terminator &terminator) { + + RUNTIME_CHECK(terminator, name && name_length); + + OwningPtr cStyleName{ + SaveDefaultCharacter(name, name_length, terminator)}; + RUNTIME_CHECK(terminator, cStyleName); + + std::int32_t status{0}; + +#ifdef _WIN32 + + // Passing empty string as value will unset the variable + status = _putenv_s(cStyleName.get(), ""); + +#else + + status = unsetenv(cStyleName.get()); + +#endif + + if (status != 0) { + status = errno; + } + + return status; +} + } // namespace Fortran::runtime diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md index ecf6fbeabd65..0118f8eb7d91 100644 --- a/flang/docs/Intrinsics.md +++ b/flang/docs/Intrinsics.md @@ -1040,6 +1040,41 @@ PROGRAM example_hostnm END PROGRAM ``` +### Non-Standard Intrinsics: PUTENV + +#### Description +`PUTENV(STR [, STATUS])` sets or deletes environment variable. + +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 | +|----------|--------|-------------|---------|---------------------------------| +| `STR` | `IN` | `CHARACTER` | default | String in the form "name=value" (see below) | +| `STATUS` | `OUT` | `INTEGER` | default | Optional. Returns 0 on success, C's `errno` on failure. | + +#### Usage and Info + +- **Standard:** extension +- **Class:** Subroutine, function +- **Syntax:** `CALL PUTENV(STR [, STATUS])`, `STATUS = PUTENV(STR)` + +The passed string can be in the form "name=value" to set environment variable "name" to value "value". It can also be of the form "name=" to delete environment variable "name". + +The environment variables set by PUTENV can be read by GET_ENVIRONMENT_VARIABLE. + +#### Example +```Fortran + integer :: status + + ! Set variable my_var to value my_value + putenv("my_var=my_value", status) + + ! Delete variable my_var + putenv("my_var=") + end +``` + ### Non-standard Intrinsics: RENAME `RENAME(OLD, NEW[, STATUS])` renames/moves a file on the filesystem. @@ -1094,7 +1129,7 @@ function form. ### Non-Standard Intrinsics: TIME #### Description -`TIME()` returns the current time of the system as a INTEGER(8). +`TIME()` returns the current time of the system as a INTEGER(8). #### Usage and Info @@ -1269,7 +1304,7 @@ by `ISIZE`. `COMPAR` function takes the addresses of element `A` and `B` and must return: - a negative value if `A` < `B` - zero if `A` == `B` -- a positive value otherwise. +- a positive value otherwise. #### Usage and Info diff --git a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h index 00b7b696eb4f..68617d6e37d7 100644 --- a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h +++ b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h @@ -382,6 +382,8 @@ struct IntrinsicLibrary { mlir::Value genPoppar(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genPresent(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genProduct(mlir::Type, llvm::ArrayRef); + fir::ExtendedValue genPutenv(std::optional, + llvm::ArrayRef); void genRandomInit(llvm::ArrayRef); void genRandomNumber(llvm::ArrayRef); void genRandomSeed(llvm::ArrayRef); diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Command.h b/flang/include/flang/Optimizer/Builder/Runtime/Command.h index 5880a703ed92..fe19f24d951f 100644 --- a/flang/include/flang/Optimizer/Builder/Runtime/Command.h +++ b/flang/include/flang/Optimizer/Builder/Runtime/Command.h @@ -68,6 +68,11 @@ 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 runtime function which implements the PUTENV +/// intrinsic. +mlir::Value genPutEnv(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value str, mlir::Value strLength); + /// Generate a call to the Unlink runtime function which implements /// the UNLINK intrinsic. mlir::Value genUnlink(fir::FirOpBuilder &builder, mlir::Location loc, diff --git a/flang/include/flang/Runtime/command.h b/flang/include/flang/Runtime/command.h index 16854c981ca2..19b486094da1 100644 --- a/flang/include/flang/Runtime/command.h +++ b/flang/include/flang/Runtime/command.h @@ -64,11 +64,15 @@ std::int32_t RTNAME(GetCwd)( std::int32_t RTNAME(Hostnm)( const Descriptor &res, const char *sourceFile, int line); +std::int32_t RTNAME(PutEnv)( + const char *str, size_t str_length, 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 997a745466de..709f2e6c85bb 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -856,6 +856,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction}, {"present", {{"a", Addressable, Rank::anyOrAssumedRank}}, DefaultLogical, Rank::scalar, IntrinsicClass::inquiryFunction}, + {"putenv", {{"str", DefaultChar, Rank::scalar}}, DefaultInt, Rank::scalar, + IntrinsicClass::transformationalFunction}, {"radix", {{"x", AnyIntOrReal, Rank::anyOrAssumedRank, Optionality::required, common::Intent::In, @@ -1639,6 +1641,12 @@ static const IntrinsicInterface intrinsicSubroutine[]{ {}, Rank::elemental, IntrinsicClass::pureSubroutine}, {"perror", {{"string", DefaultChar, Rank::scalar}}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, + {"putenv", + {{"str", DefaultChar, Rank::scalar, Optionality::required, + common::Intent::In}, + {"status", DefaultInt, Rank::scalar, Optionality::optional, + common::Intent::Out}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"mvbits", {{"from", SameIntOrUnsigned}, {"frompos", AnyInt}, {"len", AnyInt}, {"to", SameIntOrUnsigned, Rank::elemental, Optionality::required, @@ -2874,8 +2882,8 @@ 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"}, {"etime"}, {"fseek"}, - {"ftell"}, {"getcwd"}, {"hostnm"}, {"rename"}, {"second"}, {"system"}, - {"unlink"}}; + {"ftell"}, {"getcwd"}, {"hostnm"}, {"putenv"s}, {"rename"}, {"second"}, + {"system"}, {"unlink"}}; return llvm::is_contained(dualIntrinsic, name); } diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp index 702a55a49c95..93c00b6b2814 100644 --- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp +++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp @@ -793,6 +793,10 @@ static constexpr IntrinsicHandler handlers[]{ {"dim", asValue}, {"mask", asBox, handleDynamicOptional}}}, /*isElemental=*/false}, + {"putenv", + &I::genPutenv, + {{{"str", asAddr}, {"status", asAddr, handleDynamicOptional}}}, + /*isElemental=*/false}, {"random_init", &I::genRandomInit, {{{"repeatable", asValue}, {"image_distinct", asValue}}}, @@ -7329,6 +7333,39 @@ IntrinsicLibrary::genProduct(mlir::Type resultType, "PRODUCT", resultType, args); } +// PUTENV +fir::ExtendedValue +IntrinsicLibrary::genPutenv(std::optional resultType, + llvm::ArrayRef args) { + assert((resultType.has_value() && args.size() == 1) || + (!resultType.has_value() && args.size() >= 1 && args.size() <= 2)); + + mlir::Value str = fir::getBase(args[0]); + mlir::Value strLength = fir::getLen(args[0]); + mlir::Value statusValue = + fir::runtime::genPutEnv(builder, loc, str, strLength); + + 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 {}; +} + // RANDOM_INIT void IntrinsicLibrary::genRandomInit(llvm::ArrayRef args) { assert(args.size() == 2); diff --git a/flang/lib/Optimizer/Builder/Runtime/Command.cpp b/flang/lib/Optimizer/Builder/Runtime/Command.cpp index 27ea5961837e..35aa529a9a72 100644 --- a/flang/lib/Optimizer/Builder/Runtime/Command.cpp +++ b/flang/lib/Optimizer/Builder/Runtime/Command.cpp @@ -126,6 +126,20 @@ void fir::runtime::genPerror(fir::FirOpBuilder &builder, mlir::Location loc, builder.create(loc, runtimeFunc, args); } +mlir::Value fir::runtime::genPutEnv(fir::FirOpBuilder &builder, + mlir::Location loc, mlir::Value str, + mlir::Value strLength) { + 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, str, strLength, sourceFile, sourceLine); + return builder.create(loc, func, args).getResult(0); +} + mlir::Value fir::runtime::genUnlink(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value path, mlir::Value pathLength) { diff --git a/flang/test/Lower/Intrinsics/putenv-func.f90 b/flang/test/Lower/Intrinsics/putenv-func.f90 new file mode 100644 index 000000000000..9b28282a0b78 --- /dev/null +++ b/flang/test/Lower/Intrinsics/putenv-func.f90 @@ -0,0 +1,24 @@ +!RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s + +!CHECK-LABEL: func.func @_QPputenv_test +!CHECK-SAME: %[[dummyStr:.*]]: !fir.boxchar<1> {fir.bindc_name = "str"}) -> i32 { +integer function putenv_test(str) +CHARACTER(len=255) :: str + +!CHECK-DAG: %[[func_result:.*]] = fir.alloca i32 {bindc_name = "putenv_test", uniq_name = "_QFputenv_testEputenv_test"} +!CHECK-DAG: %[[func_result_decl:.*]]:{{.*}} = hlfir.declare %[[func_result]] {uniq_name = "_QFputenv_testEputenv_test"} : (!fir.ref) -> (!fir.ref, !fir.ref) +!CHECK-DAG: %[[src_str_addr:.*]] = fir.address_of(@_{{.*}}) : !fir.ref +!CHECK-DAG: %[[line_value:.*]] = arith.constant {{.*}} : i64 +!CHECK-DAG: %[[str:.*]] = fir.convert {{.*}} (!fir.ref>) -> !fir.ref +!CHECK-DAG: %[[str_len:.*]] = fir.convert {{.*}} : (index) -> i64 +!CHECK-DAG: %[[src_str:.*]] = fir.convert %[[src_str_addr]] : (!fir.ref) -> !fir.ref +!CHECK-DAG: %[[line:.*]] = fir.convert %[[line_value]] : (i64) -> i32 +!CHECK: %[[putenv_result:.*]] = fir.call @_FortranAPutEnv(%[[str]], %[[str_len]], %[[src_str]], %[[line]]) +!CHECK-SAME: -> i32 + +! Check _FortranAPutEnv result code handling +!CHECK-DAG: hlfir.assign %[[putenv_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 +putenv_test = putenv(str) +end function putenv_test diff --git a/flang/test/Lower/Intrinsics/putenv-sub.f90 b/flang/test/Lower/Intrinsics/putenv-sub.f90 new file mode 100644 index 000000000000..285dbc6fddb1 --- /dev/null +++ b/flang/test/Lower/Intrinsics/putenv-sub.f90 @@ -0,0 +1,54 @@ +!RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s + +!CHECK-LABEL: func.func @_QPstr_only +!CHECK-SAME: %[[dummyStr:.*]]: !fir.boxchar<1> {fir.bindc_name = "str"}) { +subroutine str_only(str) + CHARACTER(len=*) :: str + !CHECK-DAG: %[[scope:.*]] = fir.dummy_scope : !fir.dscope + !CHECK-DAG: %[[unbox_str:.*]]:2 = fir.unboxchar %[[dummyStr]] : (!fir.boxchar<1>) -> (!fir.ref>, index) + !CHECK-DAG: %[[str_decl:.*]]:2 = hlfir.declare %[[unbox_str]]#0 typeparams %[[unbox_str]]#1 dummy_scope %[[scope]] {uniq_name = "_QFstr_onlyEstr"} : (!fir.ref>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref>) + !CHECK-DAG: %[[src_str_addr:.*]] = fir.address_of(@_{{.*}}) : !fir.ref> + !CHECK-DAG: %[[line_value:.*]] = arith.constant {{.*}} : i64 + !CHECK-DAG: %[[str:.*]] = fir.convert %[[str_decl]]#1 : (!fir.ref>) -> !fir.ref + !CHECK-DAG: %[[str_len:.*]] = fir.convert %[[unbox_str]]#1 : (index) -> i64 + !CHECK-DAG: %[[src_str:.*]] = fir.convert %[[src_str_addr]] : (!fir.ref) -> !fir.ref + !CHECK-DAG: %[[line:.*]] = fir.convert %[[line_value]] : (i64) -> i32 + !CHECK: fir.call @_FortranAPutEnv(%[[str]], %[[str_len]], %[[src_str]], %[[line]]) + !CHECK-SAME: : (!fir.ref, i64, !fir.ref, i32) + !CHECK-SAME: -> i32 + call putenv(str) + !CHECK: return +end subroutine str_only + !CHECK: } + + !CHECK-LABEL: func.func @_QPall_arguments + !CHECK-SAME: %[[dummyStr:.*]]: !fir.boxchar<1> {fir.bindc_name = "str"} + !CHECK-SAME: %[[dummyStat:.*]]: !fir.ref {fir.bindc_name = "status"} + !CHECK-SAME: ) { +subroutine all_arguments(str, status) + CHARACTER(len=*) :: str + INTEGER :: status + !CHECK-DAG: %[[scope:.*]] = fir.dummy_scope : !fir.dscope + !CHECK-DAG: %[[unbox_str:.*]]:2 = fir.unboxchar %[[dummyStr]] : (!fir.boxchar<1>) -> (!fir.ref>, index) + !CHECK-DAG: %[[str_decl:.*]]:2 = hlfir.declare %[[unbox_str]]#0 typeparams %[[unbox_str]]#1 dummy_scope %[[scope]] {uniq_name = "_QFall_argumentsEstr"} : (!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_str_addr:.*]] = fir.address_of(@_{{.*}}) : !fir.ref> + !CHECK-DAG: %[[line_value:.*]] = arith.constant {{.*}} : i64 + !CHECK-DAG: %[[str:.*]] = fir.convert %[[str_decl]]#1 : (!fir.ref>) -> !fir.ref + !CHECK-DAG: %[[str_len:.*]] = fir.convert %[[unbox_str]]#1 : (index) -> i64 + !CHECK-DAG: %[[src_str:.*]] = fir.convert %[[src_str_addr]] : (!fir.ref) -> !fir.ref + !CHECK-DAG: %[[line:.*]] = fir.convert %[[line_value]] : (i64) -> i32 + !CHECK: %[[putenv_result:.*]] = fir.call @_FortranAPutEnv(%[[str]], %[[str_len]], %[[src_str]], %[[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 %[[putenv_result]] to %[[status_decl]]#0 : !fir.ref + !CHECK-NEXT: } + call putenv(str, status) + !CHECK: return +end subroutine all_arguments + !CHECK: } diff --git a/flang/test/Semantics/putenv.f90 b/flang/test/Semantics/putenv.f90 new file mode 100644 index 000000000000..8ec98f01ec7a --- /dev/null +++ b/flang/test/Semantics/putenv.f90 @@ -0,0 +1,42 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic +! Tests for the putenv intrinsics. + +subroutine bad_kind_error(str, status) + CHARACTER(len=255) :: str + INTEGER(2) :: status + !ERROR: Actual argument for 'status=' has bad type or kind 'INTEGER(2)' + call putenv(str, status) +end subroutine bad_kind_error + +subroutine bad_args_error() + !ERROR: missing mandatory 'str=' argument + call putenv() +end subroutine bad_args_error + +subroutine bad_function(str) + CHARACTER(len=255) :: str + INTEGER :: status + call putenv(str, status) + !ERROR: Cannot call subroutine 'putenv' like a function + status = putenv(str) +end subroutine bad_function + +subroutine bad_sub(str) + CHARACTER(len=255) :: str + INTEGER :: status + status = putenv(str) + !ERROR: Cannot call function 'putenv' like a subroutine + call putenv(str, status) +end subroutine bad_sub + +subroutine good_subroutine(str, status) + CHARACTER(len=255) :: str + INTEGER :: status + call putenv(str, status) +end subroutine good_subroutine + +subroutine good_function(str, status) + CHARACTER(len=255) :: str + INTEGER :: status + status = putenv(str) +end subroutine good_function