diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md index 189920a0881b27..8f9294cb7685aa 100644 --- a/flang/docs/Intrinsics.md +++ b/flang/docs/Intrinsics.md @@ -697,6 +697,7 @@ MALLOC ### Library subroutine ``` +CALL FDATE(TIME) CALL GETLOG(USRNAME) ``` @@ -759,7 +760,7 @@ This phase currently supports all the intrinsic procedures listed above but the | 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 | | Atomic intrinsic subroutines | ATOMIC_ADD | | Collective intrinsic subroutines | CO_REDUCE | -| Library subroutines | GETLOG| +| Library subroutines | FDATE, GETLOG | ### Intrinsic Function Folding diff --git a/flang/include/flang/Runtime/extensions.h b/flang/include/flang/Runtime/extensions.h index 175113c57ccb52..b34edb94ada43a 100644 --- a/flang/include/flang/Runtime/extensions.h +++ b/flang/include/flang/Runtime/extensions.h @@ -22,6 +22,9 @@ extern "C" { // CALL FLUSH(n) antedates the Fortran 2003 FLUSH statement. void FORTRAN_PROCEDURE_NAME(flush)(const int &unit); +// GNU extension subroutine FDATE +void FORTRAN_PROCEDURE_NAME(fdate)(char *string, std::int64_t length); + // GNU Fortran 77 compatibility function IARGC. std::int32_t FORTRAN_PROCEDURE_NAME(iargc)(); diff --git a/flang/runtime/extensions.cpp b/flang/runtime/extensions.cpp index 1c025d40b39524..8fc132aeff4ee1 100644 --- a/flang/runtime/extensions.cpp +++ b/flang/runtime/extensions.cpp @@ -10,10 +10,33 @@ // extensions that will eventually be implemented in Fortran. #include "flang/Runtime/extensions.h" +#include "terminator.h" #include "tools.h" #include "flang/Runtime/command.h" #include "flang/Runtime/descriptor.h" #include "flang/Runtime/io-api.h" +#include + +#ifdef _WIN32 +inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time, + Fortran::runtime::Terminator terminator) { + int error{ctime_s(buffer, bufsize, &cur_time)}; + RUNTIME_CHECK(terminator, error == 0); +} +#elif _POSIX_C_SOURCE >= 1 || _XOPEN_SOURCE || _BSD_SOURCE || _SVID_SOURCE || \ + _POSIX_SOURCE +inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time, + Fortran::runtime::Terminator terminator) { + const char *res{ctime_r(&cur_time, buffer)}; + RUNTIME_CHECK(terminator, res != nullptr); +} +#else +inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time, + Fortran::runtime::Terminator terminator) { + buffer[0] = '\0'; + terminator.Crash("fdate is not supported."); +} +#endif #if _REENTRANT || _POSIX_C_SOURCE >= 199506L // System is posix-compliant and has getlogin_r @@ -43,6 +66,26 @@ void FORTRAN_PROCEDURE_NAME(flush)(const int &unit) { } } // namespace io +// CALL FDATE(DATE) +void FORTRAN_PROCEDURE_NAME(fdate)(char *arg, std::int64_t length) { + // Day Mon dd hh:mm:ss yyyy\n\0 is 26 characters, e.g. + // Tue May 26 21:51:03 2015\n\0 + char str[26]; + // Insufficient space, fill with spaces and return. + if (length < 24) { + std::memset(arg, ' ', length); + return; + } + + Terminator terminator{__FILE__, __LINE__}; + std::time_t current_time; + std::time(¤t_time); + CtimeBuffer(str, sizeof(str), current_time, terminator); + + // Pad space on the last two byte `\n\0`, start at index 24 included. + CopyAndPad(arg, str, length, 24); +} + // RESULT = IARGC() std::int32_t FORTRAN_PROCEDURE_NAME(iargc)() { return RTNAME(ArgumentCount)(); } diff --git a/flang/unittests/Runtime/CommandTest.cpp b/flang/unittests/Runtime/CommandTest.cpp index dfc3ad68b3ab97..e418f17c93e3cf 100644 --- a/flang/unittests/Runtime/CommandTest.cpp +++ b/flang/unittests/Runtime/CommandTest.cpp @@ -220,6 +220,62 @@ class NoArgv : public CommandFixture { NoArgv() : CommandFixture(0, nullptr) {} }; +#if _WIN32 || _POSIX_C_SOURCE >= 1 || _XOPEN_SOURCE || _BSD_SOURCE || \ + _SVID_SOURCE || _POSIX_SOURCE +TEST_F(NoArgv, FdateGetDate) { + char input[]{"24LengthCharIsJustRight"}; + const std::size_t charLen = sizeof(input); + + FORTRAN_PROCEDURE_NAME(fdate)(input, charLen); + + // Tue May 26 21:51:03 2015\n\0 + // index at 3, 7, 10, 19 should be space + // when date is less than two digit, index 8 would be space + // Tue May 6 21:51:03 2015\n\0 + for (std::size_t i{0}; i < charLen; i++) { + if (i == 8) + continue; + if (i == 3 || i == 7 || i == 10 || i == 19) { + EXPECT_EQ(input[i], ' '); + continue; + } + EXPECT_NE(input[i], ' '); + } +} + +TEST_F(NoArgv, FdateGetDateTooShort) { + char input[]{"TooShortAllPadSpace"}; + const std::size_t charLen = sizeof(input); + + FORTRAN_PROCEDURE_NAME(fdate)(input, charLen); + + for (std::size_t i{0}; i < charLen; i++) { + EXPECT_EQ(input[i], ' '); + } +} + +TEST_F(NoArgv, FdateGetDatePadSpace) { + char input[]{"All char after 23 pad spaces"}; + const std::size_t charLen = sizeof(input); + + FORTRAN_PROCEDURE_NAME(fdate)(input, charLen); + + for (std::size_t i{24}; i < charLen; i++) { + EXPECT_EQ(input[i], ' '); + } +} + +#else +TEST_F(NoArgv, FdateNotSupported) { + char input[]{"No change due to crash"}; + + EXPECT_DEATH(FORTRAN_PROCEDURE_NAME(fdate)(input, sizeof(input)), + "fdate is not supported."); + + CheckCharEqStr(input, "No change due to crash"); +} +#endif + // TODO: Test other intrinsics with this fixture. TEST_F(NoArgv, GetCommand) { CheckMissingCommandValue(); }