1//===-- runtime/extensions.cpp --------------------------------------------===//
2//
3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4// See https://llvm.org/LICENSE.txt for license information.
5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6//
7//===----------------------------------------------------------------------===//
8
9// These C-coded entry points with Fortran-mangled names implement legacy
10// extensions that will eventually be implemented in Fortran.
11
12#include "flang/Runtime/extensions.h"
13#include "terminator.h"
14#include "tools.h"
15#include "flang/Runtime/command.h"
16#include "flang/Runtime/descriptor.h"
17#include "flang/Runtime/entry-names.h"
18#include "flang/Runtime/io-api.h"
19#include <chrono>
20#include <ctime>
21#include <signal.h>
22#include <thread>
23
24#ifdef _WIN32
25inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
26 Fortran::runtime::Terminator terminator) {
27 int error{ctime_s(buffer, bufsize, &cur_time)};
28 RUNTIME_CHECK(terminator, error == 0);
29}
30#elif _POSIX_C_SOURCE >= 1 || _XOPEN_SOURCE || _BSD_SOURCE || _SVID_SOURCE || \
31 defined(_POSIX_SOURCE)
32inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
33 Fortran::runtime::Terminator terminator) {
34 const char *res{ctime_r(timer: &cur_time, buf: buffer)};
35 RUNTIME_CHECK(terminator, res != nullptr);
36}
37#else
38inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
39 Fortran::runtime::Terminator terminator) {
40 buffer[0] = '\0';
41 terminator.Crash("fdate is not supported.");
42}
43#endif
44
45#if _REENTRANT || _POSIX_C_SOURCE >= 199506L
46// System is posix-compliant and has getlogin_r
47#include <unistd.h>
48#endif
49
50extern "C" {
51
52namespace Fortran::runtime {
53
54void GetUsernameEnvVar(const char *envName, char *arg, std::int64_t length) {
55 Descriptor name{*Descriptor::Create(
56 1, std::strlen(envName) + 1, const_cast<char *>(envName), 0)};
57 Descriptor value{*Descriptor::Create(1, length, arg, 0)};
58
59 RTNAME(GetEnvVariable)
60 (name, &value, nullptr, false, nullptr, __FILE__, __LINE__);
61}
62namespace io {
63// SUBROUTINE FLUSH(N)
64// FLUSH N
65// END
66void FORTRAN_PROCEDURE_NAME(flush)(const int &unit) {
67 Cookie cookie{IONAME(BeginFlush)(unit, __FILE__, __LINE__)};
68 IONAME(EndIoStatement)(cookie);
69}
70} // namespace io
71
72// CALL FDATE(DATE)
73void FORTRAN_PROCEDURE_NAME(fdate)(char *arg, std::int64_t length) {
74 // Day Mon dd hh:mm:ss yyyy\n\0 is 26 characters, e.g.
75 // Tue May 26 21:51:03 2015\n\0
76 char str[26];
77 // Insufficient space, fill with spaces and return.
78 if (length < 24) {
79 std::memset(arg, ' ', length);
80 return;
81 }
82
83 Terminator terminator{__FILE__, __LINE__};
84 std::time_t current_time;
85 std::time(timer: &current_time);
86 CtimeBuffer(buffer: str, bufsize: sizeof(str), cur_time: current_time, terminator);
87
88 // Pad space on the last two byte `\n\0`, start at index 24 included.
89 CopyAndPad(arg, str, length, 24);
90}
91
92// RESULT = IARGC()
93std::int32_t FORTRAN_PROCEDURE_NAME(iargc)() { return RTNAME(ArgumentCount)(); }
94
95// CALL GETARG(N, ARG)
96void FORTRAN_PROCEDURE_NAME(getarg)(
97 std::int32_t &n, char *arg, std::int64_t length) {
98 Descriptor value{*Descriptor::Create(1, length, arg, 0)};
99 (void)RTNAME(GetCommandArgument)(
100 n, &value, nullptr, nullptr, __FILE__, __LINE__);
101}
102
103// CALL GETLOG(USRNAME)
104void FORTRAN_PROCEDURE_NAME(getlog)(char *arg, std::int64_t length) {
105#if _REENTRANT || _POSIX_C_SOURCE >= 199506L
106 if (length >= 1 && getlogin_r(arg, length) == 0) {
107 auto loginLen{std::strlen(arg)};
108 std::memset(
109 arg + loginLen, ' ', static_cast<std::size_t>(length) - loginLen);
110 return;
111 }
112#endif
113#if _WIN32
114 GetUsernameEnvVar("USERNAME", arg, length);
115#else
116 GetUsernameEnvVar("LOGNAME", arg, length);
117#endif
118}
119
120std::int64_t RTNAME(Signal)(std::int64_t number, void (*handler)(int)) {
121 // using auto for portability:
122 // on Windows, this is a void *
123 // on POSIX, this has the same type as handler
124 auto result = signal(number, handler);
125
126 // GNU defines the intrinsic as returning an integer, not a pointer. So we
127 // have to reinterpret_cast
128 return static_cast<int64_t>(reinterpret_cast<std::uintptr_t>(result));
129}
130
131// CALL SLEEP(SECONDS)
132void RTNAME(Sleep)(std::int64_t seconds) {
133 // ensure that conversion to unsigned makes sense,
134 // sleep(0) is an immidiate return anyway
135 if (seconds < 1) {
136 return;
137 }
138 std::this_thread::sleep_for(std::chrono::seconds(seconds));
139}
140
141} // namespace Fortran::runtime
142} // extern "C"
143

source code of flang/runtime/extensions.cpp