[flang-commits] [flang] FDATE extension implementation: get date and time in ctime format (PR #71222)
Yi Wu via flang-commits
flang-commits at lists.llvm.org
Mon Nov 6 12:08:32 PST 2023
https://github.com/PAX-12-WU updated https://github.com/llvm/llvm-project/pull/71222
>From e0d99fb5baa4231ab351f7fd5abf0a1ffe589547 Mon Sep 17 00:00:00 2001
From: Yi Wu <yi.wu2 at arm.com>
Date: Mon, 6 Nov 2023 19:55:06 +0000
Subject: [PATCH] FDATE extension implementation: get date and time in ctime
format
reference to gfortran fdate https://gcc.gnu.org/onlinedocs/gfortran/FDATE.html
usage:
CHARACTER(32) :: time
CALL fdate(time)
WRITE(*,*) time
---
flang/docs/Intrinsics.md | 2 +-
flang/include/flang/Runtime/command.h | 5 +++++
flang/include/flang/Runtime/extensions.h | 2 ++
flang/runtime/command.cpp | 28 ++++++++++++++++++++++++
flang/runtime/extensions.cpp | 5 +++++
flang/unittests/Runtime/CommandTest.cpp | 14 ++++++++++++
6 files changed, 55 insertions(+), 1 deletion(-)
diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md
index ab0a940e53e5538..982be8208164296 100644
--- a/flang/docs/Intrinsics.md
+++ b/flang/docs/Intrinsics.md
@@ -751,7 +751,7 @@ This phase currently supports all the intrinsic procedures listed above but the
| Object characteristic inquiry functions | ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, IS_CONTIGUOUS, PRESENT, RANK, SAME_TYPE, STORAGE_SIZE |
| Type inquiry intrinsic functions | BIT_SIZE, DIGITS, EPSILON, HUGE, KIND, MAXEXPONENT, MINEXPONENT, NEW_LINE, PRECISION, RADIX, RANGE, TINY|
| Non-standard intrinsic functions | AND, OR, XOR, SHIFT, ZEXT, IZEXT, COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, QCMPLX, DREAL, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, NUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF, MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR, IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC |
-| Intrinsic subroutines |MVBITS (elemental), CPU_TIME, DATE_AND_TIME, EVENT_QUERY, EXECUTE_COMMAND_LINE, GET_COMMAND, GET_COMMAND_ARGUMENT, GET_ENVIRONMENT_VARIABLE, MOVE_ALLOC, RANDOM_INIT, RANDOM_NUMBER, RANDOM_SEED, SYSTEM_CLOCK |
+| Intrinsic subroutines |MVBITS (elemental), CPU_TIME, DATE_AND_TIME, EVENT_QUERY, EXECUTE_COMMAND_LINE, FDATE, GET_COMMAND, GET_COMMAND_ARGUMENT, GET_ENVIRONMENT_VARIABLE, MOVE_ALLOC, RANDOM_INIT, RANDOM_NUMBER, RANDOM_SEED, SYSTEM_CLOCK |
| Atomic intrinsic subroutines | ATOMIC_ADD |
| Collective intrinsic subroutines | CO_REDUCE |
diff --git a/flang/include/flang/Runtime/command.h b/flang/include/flang/Runtime/command.h
index ec6289390545479..07f6d8e169ead6c 100644
--- a/flang/include/flang/Runtime/command.h
+++ b/flang/include/flang/Runtime/command.h
@@ -23,6 +23,11 @@ extern "C" {
// integer kind.
std::int32_t RTNAME(ArgumentCount)();
+// Try to get the the current date (same format as CTIME: convert to a string)
+// Return a STATUS as described in the standard.
+std::int32_t RTNAME(FDate)(
+ const Descriptor *argument = nullptr, const Descriptor *errmsg = nullptr);
+
// 16.9.82 GET_COMMAND
// Try to get the value of the whole command. All of the parameters are
// optional.
diff --git a/flang/include/flang/Runtime/extensions.h b/flang/include/flang/Runtime/extensions.h
index ad592814e5acb79..92b9907860121aa 100644
--- a/flang/include/flang/Runtime/extensions.h
+++ b/flang/include/flang/Runtime/extensions.h
@@ -24,6 +24,8 @@ void FORTRAN_PROCEDURE_NAME(flush)(const int &unit);
// GNU Fortran 77 compatibility function IARGC.
std::int32_t FORTRAN_PROCEDURE_NAME(iargc)();
+void FORTRAN_PROCEDURE_NAME(fdate)(std::int8_t *string, std::int64_t length);
+
// GNU Fortran 77 compatibility subroutine GETARG(N, ARG).
void FORTRAN_PROCEDURE_NAME(getarg)(
std::int32_t &n, std::int8_t *arg, std::int64_t length);
diff --git a/flang/runtime/command.cpp b/flang/runtime/command.cpp
index b81a0791c5e571b..da0803c39f49b6d 100644
--- a/flang/runtime/command.cpp
+++ b/flang/runtime/command.cpp
@@ -14,6 +14,7 @@
#include "flang/Runtime/descriptor.h"
#include <cstdlib>
#include <limits>
+#include <time.h>
namespace Fortran::runtime {
std::int32_t RTNAME(ArgumentCount)() {
@@ -125,6 +126,33 @@ static bool FitsInDescriptor(
kind, terminator, value);
}
+void removeNewLine(char *str) {
+ char *newlinePos = strchr(str, '\n');
+ if (newlinePos != NULL) {
+ *newlinePos = '\0'; // Replace with null terminator
+ }
+}
+
+std::int32_t RTNAME(FDate)(const Descriptor *value, const Descriptor *errmsg) {
+ FillWithSpaces(*value);
+
+ time_t current_time;
+ time(¤t_time);
+
+ char *time_string = ctime(¤t_time);
+ removeNewLine(time_string);
+ std::int64_t stringLen{StringLength(time_string)};
+ if (stringLen <= 0) {
+ return ToErrmsg(errmsg, StatMissingArgument);
+ }
+
+ if (value) {
+ return CopyToDescriptor(*value, time_string, stringLen, errmsg);
+ }
+
+ return StatOk;
+}
+
std::int32_t RTNAME(GetCommandArgument)(std::int32_t n, const Descriptor *value,
const Descriptor *length, const Descriptor *errmsg, const char *sourceFile,
int line) {
diff --git a/flang/runtime/extensions.cpp b/flang/runtime/extensions.cpp
index b8e9b6eae132059..0142cac1d929d4d 100644
--- a/flang/runtime/extensions.cpp
+++ b/flang/runtime/extensions.cpp
@@ -30,6 +30,11 @@ void FORTRAN_PROCEDURE_NAME(flush)(const int &unit) {
// RESULT = IARGC()
std::int32_t FORTRAN_PROCEDURE_NAME(iargc)() { return RTNAME(ArgumentCount)(); }
+void FORTRAN_PROCEDURE_NAME(fdate)(std::int8_t *arg, std::int64_t length) {
+ Descriptor value{*Descriptor::Create(1, length, arg, 0)};
+ (void)RTNAME(FDate)(&value, nullptr);
+}
+
// CALL GETARG(N, ARG)
void FORTRAN_PROCEDURE_NAME(getarg)(
std::int32_t &n, std::int8_t *arg, std::int64_t length) {
diff --git a/flang/unittests/Runtime/CommandTest.cpp b/flang/unittests/Runtime/CommandTest.cpp
index c3571c9684e4b07..091870e4baf1730 100644
--- a/flang/unittests/Runtime/CommandTest.cpp
+++ b/flang/unittests/Runtime/CommandTest.cpp
@@ -225,6 +225,12 @@ TEST_F(ZeroArguments, GetCommandArgument) {
CheckMissingArgumentValue(1);
}
+TEST_F(ZeroArguments, FDate) {
+ CheckMissingArgumentValue(-1);
+ CheckArgumentValue(commandOnlyArgv[0], 0);
+ CheckMissingArgumentValue(1);
+}
+
TEST_F(ZeroArguments, GetCommand) { CheckCommandValue(commandOnlyArgv, 1); }
static const char *oneArgArgv[]{"aProgram", "anArgumentOfLength20"};
@@ -242,6 +248,13 @@ TEST_F(OneArgument, GetCommandArgument) {
CheckMissingArgumentValue(2);
}
+TEST_F(OneArgument, FDate) {
+ CheckMissingArgumentValue(-1);
+ CheckArgumentValue(oneArgArgv[0], 0);
+ CheckArgumentValue(oneArgArgv[1], 1);
+ CheckMissingArgumentValue(2);
+}
+
TEST_F(OneArgument, GetCommand) { CheckCommandValue(oneArgArgv, 2); }
static const char *severalArgsArgv[]{
@@ -284,6 +297,7 @@ TEST_F(SeveralArguments, ArgValueTooShort) {
ASSERT_NE(tooShort, nullptr);
EXPECT_EQ(RTNAME(GetCommandArgument)(1, tooShort.get()), -1);
CheckDescriptorEqStr(tooShort.get(), severalArgsArgv[1]);
+ EXPECT_EQ(RTNAME(FDate)(tooShort.get()), -1);
OwningPtr<Descriptor> length{EmptyIntDescriptor()};
ASSERT_NE(length, nullptr);
More information about the flang-commits
mailing list