[flang/flang-rt] Implement PERROR intrinsic form GNU Extension (#132406)

JDPailleux · web-flow · commit 513a91a5f155 · 2025-04-01T15:47:54.000+02:00
Add the implementation of the `PERROR(STRING) ` intrinsic from the GNU Extension to prints on the stderr a newline-terminated error message corresponding to the last system error prefixed by `STRING`. (https://gcc.gnu.org/onlinedocs/gfortran/PERROR.html)
diff --git a/flang-rt/lib/runtime/extensions.cpp b/flang-rt/lib/runtime/extensions.cpp
@@ -17,6 +17,7 @@
 #include "flang/Runtime/entry-names.h"
 #include "flang/Runtime/io-api.h"
 #include <chrono>
+#include <cstdio>
 #include <cstring>
 #include <ctime>
 #include <signal.h>
@@ -268,5 +269,8 @@ void FORTRAN_PROCEDURE_NAME(qsort)(int *array, int *len, int *isize,
   qsort(array, *len, *isize, compar);
 }
 
+// PERROR(STRING)
+void RTNAME(Perror)(const char *str) { perror(str); }
+
 } // namespace Fortran::runtime
 } // extern "C"
diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md
@@ -1175,3 +1175,15 @@ by `ISIZE`.
 - **Standard:** lib3f (section 3f of old man pages).
 - **Class:** subroutine
 - **Syntax:** `CALL QSORT(ARRAY, LEN, ISIZE, COMPAR)`
+
+### Non-Standard Intrinsics: PERROR
+
+#### Description
+`PERROR(STRING)` prints (on the C stderr stream) a newline-terminated error message corresponding to the last system error.
+This is prefixed by `STRING`, a colon and a space.
+
+#### Usage and Info
+
+- **Standard:** GNU extension
+- **Class:** subroutine
+- **Syntax:** `CALL PERROR(STRING)`
diff --git a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
@@ -373,6 +373,7 @@ struct IntrinsicLibrary {
   fir::ExtendedValue genNull(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genPack(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genParity(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+  void genPerror(llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genPopcnt(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genPoppar(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genPresent(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Command.h b/flang/include/flang/Optimizer/Builder/Runtime/Command.h
@@ -63,5 +63,10 @@ mlir::Value genGetCwd(fir::FirOpBuilder &builder, mlir::Location loc,
 mlir::Value genHostnm(fir::FirOpBuilder &builder, mlir::Location loc,
                       mlir::Value res);
 
+/// Generate a call to the Perror runtime function which implements
+/// the PERROR GNU intrinsic.
+void genPerror(fir::FirOpBuilder &builder, mlir::Location loc,
+               mlir::Value string);
+
 } // namespace fir::runtime
 #endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_COMMAND_H
diff --git a/flang/include/flang/Runtime/extensions.h b/flang/include/flang/Runtime/extensions.h
@@ -78,5 +78,8 @@ int RTNAME(Chdir)(const char *name);
 // GNU extension function IERRNO()
 int FORTRAN_PROCEDURE_NAME(ierrno)();
 
+// GNU extension subroutine PERROR(STRING)
+void RTNAME(Perror)(const char *str);
+
 } // extern "C"
 #endif // FORTRAN_RUNTIME_EXTENSIONS_H_
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
@@ -1573,6 +1573,8 @@ static const IntrinsicInterface intrinsicSubroutine[]{
             {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
                 common::Intent::InOut}},
         {}, Rank::elemental, IntrinsicClass::pureSubroutine},
+    {"perror", {{"string", DefaultChar, Rank::scalar}}, {}, Rank::elemental,
+        IntrinsicClass::impureSubroutine},
     {"mvbits",
         {{"from", SameIntOrUnsigned}, {"frompos", AnyInt}, {"len", AnyInt},
             {"to", SameIntOrUnsigned, Rank::elemental, Optionality::required,
diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
@@ -753,6 +753,10 @@ static constexpr IntrinsicHandler handlers[]{
      &I::genParity,
      {{{"mask", asBox}, {"dim", asValue}}},
      /*isElemental=*/false},
+    {"perror",
+     &I::genPerror,
+     {{{"string", asBox}}},
+     /*isElemental*/ false},
     {"popcnt", &I::genPopcnt},
     {"poppar", &I::genPoppar},
     {"present",
@@ -7158,6 +7162,17 @@ IntrinsicLibrary::genParity(mlir::Type resultType,
   return readAndAddCleanUp(resultMutableBox, resultType, "PARITY");
 }
 
+// PERROR
+void IntrinsicLibrary::genPerror(llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 1);
+
+  fir::ExtendedValue str = args[0];
+  const auto *box = str.getBoxOf<fir::BoxValue>();
+  mlir::Value addr =
+      builder.create<fir::BoxAddrOp>(loc, box->getMemTy(), fir::getBase(*box));
+  fir::runtime::genPerror(builder, loc, addr);
+}
+
 // POPCNT
 mlir::Value IntrinsicLibrary::genPopcnt(mlir::Type resultType,
                                         llvm::ArrayRef<mlir::Value> args) {
diff --git a/flang/lib/Optimizer/Builder/Runtime/Command.cpp b/flang/lib/Optimizer/Builder/Runtime/Command.cpp
@@ -10,6 +10,7 @@
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
 #include "flang/Runtime/command.h"
+#include "flang/Runtime/extensions.h"
 
 using namespace Fortran::runtime;
 
@@ -114,3 +115,13 @@ mlir::Value fir::runtime::genHostnm(fir::FirOpBuilder &builder,
       builder, loc, runtimeFuncTy, res, sourceFile, sourceLine);
   return builder.create<fir::CallOp>(loc, func, args).getResult(0);
 }
+
+void fir::runtime::genPerror(fir::FirOpBuilder &builder, mlir::Location loc,
+                             mlir::Value string) {
+  auto runtimeFunc =
+      fir::runtime::getRuntimeFunc<mkRTKey(Perror)>(loc, builder);
+  mlir::FunctionType runtimeFuncTy = runtimeFunc.getFunctionType();
+  llvm::SmallVector<mlir::Value> args =
+      fir::runtime::createArguments(builder, loc, runtimeFuncTy, string);
+  builder.create<fir::CallOp>(loc, runtimeFunc, args);
+}
diff --git a/flang/test/Lower/Intrinsics/perror.f90 b/flang/test/Lower/Intrinsics/perror.f90
@@ -0,0 +1,52 @@
+! RUN: bbc -emit-hlfir %s -o - | FileCheck --check-prefixes=CHECK %s
+! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck --check-prefixes=CHECK %s
+
+! CHECK-LABEL: func @_QPtest_perror(
+subroutine test_perror()
+  character(len=10) :: string
+  character(len=1) :: one
+  ! CHECK: %[[C1:.*]] = arith.constant 1 : index
+  ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.char<1> {bindc_name = "one", uniq_name = "_QFtest_perrorEone"}
+  ! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] typeparams %[[C1]] {uniq_name = "_QFtest_perrorEone"} : (!fir.ref<!fir.char<1>>, index) -> (!fir.ref<!fir.char<1>>, !fir.ref<!fir.char<1>>)
+  ! CHECK: %[[C10:.*]] = arith.constant 10 : index
+  ! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.char<1,10> {bindc_name = "string", uniq_name = "_QFtest_perrorEstring"}
+  ! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_2]] typeparams %[[C10]] {uniq_name = "_QFtest_perrorEstring"} : (!fir.ref<!fir.char<1,10>>, index) -> (!fir.ref<!fir.char<1,10>>, !fir.ref<!fir.char<1,10>>)
+  
+  call perror(string)
+  ! CHECK: %[[VAL_4:.*]] = fir.embox %[[VAL_3]]#0 : (!fir.ref<!fir.char<1,10>>) -> !fir.box<!fir.char<1,10>>
+  ! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.box<!fir.char<1,10>>) -> !fir.ref<!fir.char<1,10>>
+  ! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<i8>
+  ! CHECK: fir.call @_FortranAPerror(%[[VAL_6]]) fastmath<contract> : (!fir.ref<i8>) -> () 
+  
+  call perror("prefix")
+  ! CHECK: %[[VAL_7:.*]] = fir.address_of(@{{.*}}) : !fir.ref<!fir.char<1,6>>
+  ! CHECK: %[[C6:.*]] = arith.constant 6 : index
+  ! CHECK: %[[VAL_8:.*]]:2 = hlfir.declare %[[VAL_7]] typeparams %[[C6]] {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = {{.*}}} : (!fir.ref<!fir.char<1,6>>, index) -> (!fir.ref<!fir.char<1,6>>, !fir.ref<!fir.char<1,6>>)
+  ! CHECK: %[[VAL_9:.*]] = fir.embox %[[VAL_8]]#0 : (!fir.ref<!fir.char<1,6>>) -> !fir.box<!fir.char<1,6>>
+  ! CHECK: %[[VAL_10:.*]] = fir.box_addr %[[VAL_9]] : (!fir.box<!fir.char<1,6>>) -> !fir.ref<!fir.char<1,6>>
+  ! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (!fir.ref<!fir.char<1,6>>) -> !fir.ref<i8>
+  ! CHECK: fir.call @_FortranAPerror(%[[VAL_11]]) fastmath<contract> : (!fir.ref<i8>) -> () 
+  
+  call perror(one)
+  ! CHECK: %[[VAL_12:.*]] = fir.embox %[[VAL_1]]#0 : (!fir.ref<!fir.char<1>>) -> !fir.box<!fir.char<1>>
+  ! CHECK: %[[VAL_13:.*]] = fir.box_addr %[[VAL_12]] : (!fir.box<!fir.char<1>>) -> !fir.ref<!fir.char<1>>
+  ! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (!fir.ref<!fir.char<1>>) -> !fir.ref<i8>
+  ! CHECK: fir.call @_FortranAPerror(%[[VAL_14]]) fastmath<contract> : (!fir.ref<i8>) -> () 
+end subroutine test_perror
+
+! CHECK-LABEL: func @_QPtest_perror_unknown_length(
+! CHECK-SAME: %[[ARG0:.*]]:  !fir.boxchar<1> {fir.bindc_name = "str"}
+subroutine test_perror_unknown_length(str)
+    implicit none
+    character(len=*), intent(in) :: str
+
+  call perror(str)
+  ! CHECK: %[[VAL_0:.*]] = fir.dummy_scope : !fir.dscope
+  ! CHECK: %[[VAL_1:.*]]:2 = fir.unboxchar %[[ARG0]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+  ! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_1]]#0 typeparams %[[VAL_1]]#1 dummy_scope %[[VAL_0]] {fortran_attrs = #fir.var_attrs<intent_in>, uniq_name = "_QFtest_perror_unknown_lengthEstr"} : (!fir.ref<!fir.char<1,?>>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+  ! CHECK: %[[VAL_3:.*]] = fir.embox %[[VAL_2]]#1 typeparams %[[VAL_1]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.box<!fir.char<1,?>>
+  ! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.box<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,?>>
+  ! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
+  ! CHECK: fir.call @_FortranAPerror(%[[VAL_5]]) fastmath<contract> : (!fir.ref<i8>) -> ()
+  ! CHECK: return
+end subroutine test_perror_unknown_length
