[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.

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};

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

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<char> cStyleName{
+      SaveDefaultCharacter(name, name_length, terminator)};
+  RUNTIME_CHECK(terminator, cStyleName);
+
+  OwningPtr<char> 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<char> 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

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.

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

@@ -382,6 +382,8 @@ struct IntrinsicLibrary {
   mlir::Value genPoppar(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genPresent(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genProduct(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+  fir::ExtendedValue genPutenv(std::optional<mlir::Type>,
+                               llvm::ArrayRef<fir::ExtendedValue>);
   void genRandomInit(llvm::ArrayRef<fir::ExtendedValue>);
   void genRandomNumber(llvm::ArrayRef<fir::ExtendedValue>);
   void genRandomSeed(llvm::ArrayRef<fir::ExtendedValue>);

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,

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_

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);
 }
 

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<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 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<fir::ExtendedValue> args) {
   assert(args.size() == 2);

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

@@ -126,6 +126,20 @@ void fir::runtime::genPerror(fir::FirOpBuilder &builder, mlir::Location loc,
   builder.create<fir::CallOp>(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<mkRTKey(PutEnv)>(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, str, strLength, sourceFile, sourceLine);
+  return builder.create<fir::CallOp>(loc, func, args).getResult(0);
+}
+
 mlir::Value fir::runtime::genUnlink(fir::FirOpBuilder &builder,
                                     mlir::Location loc, mlir::Value path,
                                     mlir::Value pathLength) {

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<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+!CHECK-DAG:   %[[src_str_addr:.*]] = fir.address_of(@_{{.*}}) : !fir.ref<!fir.char<1,{{.*}}>
+!CHECK-DAG:   %[[line_value:.*]] = arith.constant {{.*}} : i64
+!CHECK-DAG:   %[[str:.*]] = fir.convert {{.*}} (!fir.ref<!fir.char<1,{{.*}}>>) -> !fir.ref<i8>
+!CHECK-DAG:   %[[str_len:.*]] = fir.convert {{.*}} : (index) -> i64
+!CHECK-DAG:   %[[src_str:.*]] = fir.convert %[[src_str_addr]] : (!fir.ref<!fir.char<1,{{.*}}>) -> !fir.ref<i8>
+!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<i32>
+!CHECK-DAG:   %[[load_result:.*]] = fir.load %[[func_result_decl]]#0 : !fir.ref<i32>
+!CHECK:       return %[[load_result]] : i32
+putenv_test = putenv(str)
+end function putenv_test

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<!fir.char<1,?>>, index)
+    !CHECK-DAG:    %[[str_decl:.*]]:2 = hlfir.declare %[[unbox_str]]#0 typeparams %[[unbox_str]]#1 dummy_scope %[[scope]] {uniq_name = "_QFstr_onlyEstr"} : (!fir.ref<!fir.char<1,?>>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+    !CHECK-DAG:    %[[src_str_addr:.*]] = fir.address_of(@_{{.*}}) : !fir.ref<!fir.char<1,{{.*}}>>
+    !CHECK-DAG:    %[[line_value:.*]] = arith.constant {{.*}} : i64
+    !CHECK-DAG:    %[[str:.*]] = fir.convert %[[str_decl]]#1 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
+    !CHECK-DAG:    %[[str_len:.*]] = fir.convert %[[unbox_str]]#1 : (index) -> i64
+    !CHECK-DAG:    %[[src_str:.*]] = fir.convert %[[src_str_addr]] : (!fir.ref<!fir.char<1,{{.*}}>) -> !fir.ref<i8>
+    !CHECK-DAG:    %[[line:.*]] = fir.convert %[[line_value]] : (i64) -> i32
+    !CHECK:        fir.call @_FortranAPutEnv(%[[str]], %[[str_len]], %[[src_str]], %[[line]])
+    !CHECK-SAME:   : (!fir.ref<i8>, i64, !fir.ref<i8>, 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<i32> {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<!fir.char<1,?>>, index)
+    !CHECK-DAG:    %[[str_decl:.*]]:2 = hlfir.declare %[[unbox_str]]#0 typeparams %[[unbox_str]]#1 dummy_scope %[[scope]] {uniq_name = "_QFall_argumentsEstr"} : (!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_str_addr:.*]] = fir.address_of(@_{{.*}}) : !fir.ref<!fir.char<1,{{.*}}>>
+    !CHECK-DAG:    %[[line_value:.*]] = arith.constant {{.*}} : i64
+    !CHECK-DAG:    %[[str:.*]] = fir.convert %[[str_decl]]#1 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
+    !CHECK-DAG:    %[[str_len:.*]] = fir.convert %[[unbox_str]]#1 : (index) -> i64
+    !CHECK-DAG:    %[[src_str:.*]] = fir.convert %[[src_str_addr]] : (!fir.ref<!fir.char<1,{{.*}}>) -> !fir.ref<i8>
+    !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<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 %[[putenv_result]] to %[[status_decl]]#0 : !fir.ref<i32>
+    !CHECK-NEXT:   }
+    call putenv(str, status)
+    !CHECK:        return
+end subroutine all_arguments
+    !CHECK:        }

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