1//===-- lib/runtime/extensions.cpp ------------------------------*- C++ -*-===//
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 "unit.h"
14#include "flang-rt/runtime/descriptor.h"
15#include "flang-rt/runtime/terminator.h"
16#include "flang-rt/runtime/tools.h"
17#include "flang/Runtime/command.h"
18#include "flang/Runtime/entry-names.h"
19#include "flang/Runtime/io-api.h"
20#include "flang/Runtime/iostat-consts.h"
21#include <chrono>
22#include <cstdio>
23#include <cstring>
24#include <ctime>
25#include <signal.h>
26#include <stdlib.h>
27#include <thread>
28
29#ifdef _WIN32
30#define WIN32_LEAN_AND_MEAN
31#define NOMINMAX
32#include <windows.h>
33
34#include <synchapi.h>
35
36inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
37 Fortran::runtime::Terminator terminator) {
38 int error{ctime_s(buffer, bufsize, &cur_time)};
39 RUNTIME_CHECK(terminator, error == 0);
40}
41#elif _POSIX_C_SOURCE >= 1 || _XOPEN_SOURCE || _BSD_SOURCE || _SVID_SOURCE || \
42 defined(_POSIX_SOURCE)
43inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
44 Fortran::runtime::Terminator terminator) {
45 const char *res{ctime_r(timer: &cur_time, buf: buffer)};
46 RUNTIME_CHECK(terminator, res != nullptr);
47}
48#else
49inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
50 Fortran::runtime::Terminator terminator) {
51 buffer[0] = '\0';
52 terminator.Crash("fdate is not supported.");
53}
54#endif
55
56#ifndef _WIN32
57// posix-compliant and has getlogin_r and F_OK
58#include <unistd.h>
59#else
60#include <direct.h>
61#endif
62
63extern "C" {
64
65namespace Fortran::runtime {
66
67gid_t RTNAME(GetGID)() {
68#ifdef _WIN32
69 // Group IDs don't exist on Windows, return 1 to avoid errors
70 return 1;
71#else
72 return getgid();
73#endif
74}
75
76uid_t RTNAME(GetUID)() {
77#ifdef _WIN32
78 // User IDs don't exist on Windows, return 1 to avoid errors
79 return 1;
80#else
81 return getuid();
82#endif
83}
84
85void GetUsernameEnvVar(const char *envName, char *arg, std::int64_t length) {
86 Descriptor name{*Descriptor::Create(
87 1, std::strlen(envName) + 1, const_cast<char *>(envName), 0)};
88 Descriptor value{*Descriptor::Create(1, length, arg, 0)};
89
90 RTNAME(GetEnvVariable)
91 (name, &value, nullptr, false, nullptr, __FILE__, __LINE__);
92}
93
94namespace io {
95// SUBROUTINE FLUSH(N)
96// FLUSH N
97// END
98void FORTRAN_PROCEDURE_NAME(flush)(const int &unit) {
99 Cookie cookie{IONAME(BeginFlush)(unit, __FILE__, __LINE__)};
100 IONAME(EndIoStatement)(cookie);
101}
102} // namespace io
103
104// CALL FDATE(DATE)
105void FORTRAN_PROCEDURE_NAME(fdate)(char *arg, std::int64_t length) {
106 // Day Mon dd hh:mm:ss yyyy\n\0 is 26 characters, e.g.
107 // Tue May 26 21:51:03 2015\n\0
108 char str[26];
109 // Insufficient space, fill with spaces and return.
110 if (length < 24) {
111 std::memset(s: arg, c: ' ', n: length);
112 return;
113 }
114
115 Terminator terminator{__FILE__, __LINE__};
116 std::time_t current_time;
117 std::time(timer: &current_time);
118 CtimeBuffer(str, sizeof(str), current_time, terminator);
119
120 // Pad space on the last two byte `\n\0`, start at index 24 included.
121 CopyAndPad(arg, str, length, 24);
122}
123
124std::intptr_t RTNAME(Malloc)(std::size_t size) {
125 return reinterpret_cast<std::intptr_t>(std::malloc(size: size));
126}
127
128// RESULT = IARGC()
129std::int32_t FORTRAN_PROCEDURE_NAME(iargc)() { return RTNAME(ArgumentCount)(); }
130
131// CALL GETARG(N, ARG)
132void FORTRAN_PROCEDURE_NAME(getarg)(
133 std::int32_t &n, char *arg, std::int64_t length) {
134 Descriptor value{*Descriptor::Create(1, length, arg, 0)};
135 (void)RTNAME(GetCommandArgument)(
136 n, &value, nullptr, nullptr, __FILE__, __LINE__);
137}
138
139// CALL GETLOG(USRNAME)
140void FORTRAN_PROCEDURE_NAME(getlog)(char *arg, std::int64_t length) {
141#if _REENTRANT || _POSIX_C_SOURCE >= 199506L
142 if (length >= 1 && getlogin_r(arg, length) == 0) {
143 auto loginLen{std::strlen(arg)};
144 std::memset(
145 arg + loginLen, ' ', static_cast<std::size_t>(length) - loginLen);
146 return;
147 }
148#endif
149#if _WIN32
150 GetUsernameEnvVar("USERNAME", arg, length);
151#else
152 GetUsernameEnvVar("LOGNAME", arg, length);
153#endif
154}
155
156void RTNAME(Free)(std::intptr_t ptr) {
157 std::free(reinterpret_cast<void *>(ptr));
158}
159
160std::int64_t RTNAME(Signal)(std::int64_t number, void (*handler)(int)) {
161 // using auto for portability:
162 // on Windows, this is a void *
163 // on POSIX, this has the same type as handler
164 auto result = signal(number, handler);
165
166 // GNU defines the intrinsic as returning an integer, not a pointer. So we
167 // have to reinterpret_cast
168 return static_cast<int64_t>(reinterpret_cast<std::uintptr_t>(result));
169}
170
171// CALL SLEEP(SECONDS)
172void RTNAME(Sleep)(std::int64_t seconds) {
173 // ensure that conversion to unsigned makes sense,
174 // sleep(0) is an immidiate return anyway
175 if (seconds < 1) {
176 return;
177 }
178#if _WIN32
179 Sleep(seconds * 1000);
180#else
181 sleep(seconds);
182#endif
183}
184
185// TODO: not supported on Windows
186#ifndef _WIN32
187std::int64_t FORTRAN_PROCEDURE_NAME(access)(const char *name,
188 std::int64_t nameLength, const char *mode, std::int64_t modeLength) {
189 std::int64_t ret{-1};
190 if (nameLength <= 0 || modeLength <= 0 || !name || !mode) {
191 return ret;
192 }
193
194 // ensure name is null terminated
195 char *newName{nullptr};
196 if (name[nameLength - 1] != '\0') {
197 newName = static_cast<char *>(std::malloc(nameLength + 1));
198 std::memcpy(newName, name, nameLength);
199 newName[nameLength] = '\0';
200 name = newName;
201 }
202
203 // calculate mode
204 bool read{false};
205 bool write{false};
206 bool execute{false};
207 bool exists{false};
208 int imode{0};
209
210 for (std::int64_t i = 0; i < modeLength; ++i) {
211 switch (mode[i]) {
212 case 'r':
213 read = true;
214 break;
215 case 'w':
216 write = true;
217 break;
218 case 'x':
219 execute = true;
220 break;
221 case ' ':
222 exists = true;
223 break;
224 default:
225 // invalid mode
226 goto cleanup;
227 }
228 }
229 if (!read && !write && !execute && !exists) {
230 // invalid mode
231 goto cleanup;
232 }
233
234 if (!read && !write && !execute) {
235 imode = F_OK;
236 } else {
237 if (read) {
238 imode |= R_OK;
239 }
240 if (write) {
241 imode |= W_OK;
242 }
243 if (execute) {
244 imode |= X_OK;
245 }
246 }
247 ret = access(name, imode);
248
249cleanup:
250 if (newName) {
251 free(newName);
252 }
253 return ret;
254}
255#endif
256
257// CHDIR(DIR)
258int RTNAME(Chdir)(const char *name) {
259// chdir alias seems to be deprecated on Windows.
260#ifndef _WIN32
261 return chdir(name);
262#else
263 return _chdir(name);
264#endif
265}
266
267int FORTRAN_PROCEDURE_NAME(hostnm)(char *hn, int length) {
268 std::int32_t status{0};
269
270 if (!hn || length < 0) {
271 return EINVAL;
272 }
273
274#ifdef _WIN32
275 DWORD dwSize{static_cast<DWORD>(length)};
276
277 // Note: Winsock has gethostname(), but use Win32 API GetComputerNameEx(),
278 // in order to avoid adding dependency on Winsock.
279 if (!GetComputerNameExA(ComputerNameDnsHostname, hn, &dwSize)) {
280 status = GetLastError();
281 }
282#else
283 if (gethostname(hn, length) < 0) {
284 status = errno;
285 }
286#endif
287
288 if (status == 0) {
289 // Find zero terminator and fill the string from the
290 // zero terminator to the end with spaces
291 char *str_end{hn + length};
292 char *str_zero{std::find(hn, str_end, '\0')};
293 std::fill(first: str_zero, last: str_end, value: ' ');
294 }
295
296 return status;
297}
298
299int FORTRAN_PROCEDURE_NAME(ierrno)() { return errno; }
300
301void FORTRAN_PROCEDURE_NAME(qsort)(int *array, int *len, int *isize,
302 int (*compar)(const void *, const void *)) {
303 qsort(array, *len, *isize, compar);
304}
305
306// PERROR(STRING)
307void RTNAME(Perror)(const char *str) { perror(str); }
308
309// GNU extension function TIME()
310std::int64_t RTNAME(time)() { return time(nullptr); }
311
312// Extension procedures related to I/O
313
314namespace io {
315std::int32_t RTNAME(Fseek)(int unitNumber, std::int64_t zeroBasedPos,
316 int whence, const char *sourceFileName, int lineNumber) {
317 if (ExternalFileUnit * unit{ExternalFileUnit::LookUp(unitNumber)}) {
318 Terminator terminator{sourceFileName, lineNumber};
319 IoErrorHandler handler{terminator};
320 if (unit->Fseek(
321 zeroBasedPos, static_cast<enum FseekWhence>(whence), handler)) {
322 return IostatOk;
323 } else {
324 return IostatCannotReposition;
325 }
326 } else {
327 return IostatBadUnitNumber;
328 }
329}
330
331std::int64_t RTNAME(Ftell)(int unitNumber) {
332 if (ExternalFileUnit * unit{ExternalFileUnit::LookUp(unitNumber)}) {
333 return unit->InquirePos() - 1; // zero-based result
334 } else {
335 return -1;
336 }
337}
338} // namespace io
339
340} // namespace Fortran::runtime
341} // extern "C"
342

source code of flang-rt/lib/runtime/extensions.cpp