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 <cstring>
21#include <ctime>
22#include <signal.h>
23#include <thread>
24
25#ifdef _WIN32
26inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
27 Fortran::runtime::Terminator terminator) {
28 int error{ctime_s(buffer, bufsize, &cur_time)};
29 RUNTIME_CHECK(terminator, error == 0);
30}
31#elif _POSIX_C_SOURCE >= 1 || _XOPEN_SOURCE || _BSD_SOURCE || _SVID_SOURCE || \
32 defined(_POSIX_SOURCE)
33inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
34 Fortran::runtime::Terminator terminator) {
35 const char *res{ctime_r(timer: &cur_time, buf: buffer)};
36 RUNTIME_CHECK(terminator, res != nullptr);
37}
38#else
39inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
40 Fortran::runtime::Terminator terminator) {
41 buffer[0] = '\0';
42 terminator.Crash("fdate is not supported.");
43}
44#endif
45
46#ifndef _WIN32
47// posix-compliant and has getlogin_r and F_OK
48#include <unistd.h>
49#endif
50
51extern "C" {
52
53namespace Fortran::runtime {
54
55void GetUsernameEnvVar(const char *envName, char *arg, std::int64_t length) {
56 Descriptor name{*Descriptor::Create(
57 1, std::strlen(envName) + 1, const_cast<char *>(envName), 0)};
58 Descriptor value{*Descriptor::Create(1, length, arg, 0)};
59
60 RTNAME(GetEnvVariable)
61 (name, &value, nullptr, false, nullptr, __FILE__, __LINE__);
62}
63namespace io {
64// SUBROUTINE FLUSH(N)
65// FLUSH N
66// END
67void FORTRAN_PROCEDURE_NAME(flush)(const int &unit) {
68 Cookie cookie{IONAME(BeginFlush)(unit, __FILE__, __LINE__)};
69 IONAME(EndIoStatement)(cookie);
70}
71} // namespace io
72
73// CALL FDATE(DATE)
74void FORTRAN_PROCEDURE_NAME(fdate)(char *arg, std::int64_t length) {
75 // Day Mon dd hh:mm:ss yyyy\n\0 is 26 characters, e.g.
76 // Tue May 26 21:51:03 2015\n\0
77 char str[26];
78 // Insufficient space, fill with spaces and return.
79 if (length < 24) {
80 std::memset(arg, ' ', length);
81 return;
82 }
83
84 Terminator terminator{__FILE__, __LINE__};
85 std::time_t current_time;
86 std::time(timer: &current_time);
87 CtimeBuffer(buffer: str, bufsize: sizeof(str), cur_time: current_time, terminator);
88
89 // Pad space on the last two byte `\n\0`, start at index 24 included.
90 CopyAndPad(arg, str, length, 24);
91}
92
93// RESULT = IARGC()
94std::int32_t FORTRAN_PROCEDURE_NAME(iargc)() { return RTNAME(ArgumentCount)(); }
95
96// CALL GETARG(N, ARG)
97void FORTRAN_PROCEDURE_NAME(getarg)(
98 std::int32_t &n, char *arg, std::int64_t length) {
99 Descriptor value{*Descriptor::Create(1, length, arg, 0)};
100 (void)RTNAME(GetCommandArgument)(
101 n, &value, nullptr, nullptr, __FILE__, __LINE__);
102}
103
104// CALL GETLOG(USRNAME)
105void FORTRAN_PROCEDURE_NAME(getlog)(char *arg, std::int64_t length) {
106#if _REENTRANT || _POSIX_C_SOURCE >= 199506L
107 if (length >= 1 && getlogin_r(arg, length) == 0) {
108 auto loginLen{std::strlen(arg)};
109 std::memset(
110 arg + loginLen, ' ', static_cast<std::size_t>(length) - loginLen);
111 return;
112 }
113#endif
114#if _WIN32
115 GetUsernameEnvVar("USERNAME", arg, length);
116#else
117 GetUsernameEnvVar("LOGNAME", arg, length);
118#endif
119}
120
121std::int64_t RTNAME(Signal)(std::int64_t number, void (*handler)(int)) {
122 // using auto for portability:
123 // on Windows, this is a void *
124 // on POSIX, this has the same type as handler
125 auto result = signal(number, handler);
126
127 // GNU defines the intrinsic as returning an integer, not a pointer. So we
128 // have to reinterpret_cast
129 return static_cast<int64_t>(reinterpret_cast<std::uintptr_t>(result));
130}
131
132// CALL SLEEP(SECONDS)
133void RTNAME(Sleep)(std::int64_t seconds) {
134 // ensure that conversion to unsigned makes sense,
135 // sleep(0) is an immidiate return anyway
136 if (seconds < 1) {
137 return;
138 }
139 std::this_thread::sleep_for(std::chrono::seconds(seconds));
140}
141
142// TODO: not supported on Windows
143#ifndef _WIN32
144std::int64_t FORTRAN_PROCEDURE_NAME(access)(const char *name,
145 std::int64_t nameLength, const char *mode, std::int64_t modeLength) {
146 std::int64_t ret{-1};
147 if (nameLength <= 0 || modeLength <= 0 || !name || !mode) {
148 return ret;
149 }
150
151 // ensure name is null terminated
152 char *newName{nullptr};
153 if (name[nameLength - 1] != '\0') {
154 newName = static_cast<char *>(std::malloc(nameLength + 1));
155 std::memcpy(newName, name, nameLength);
156 newName[nameLength] = '\0';
157 name = newName;
158 }
159
160 // calculate mode
161 bool read{false};
162 bool write{false};
163 bool execute{false};
164 bool exists{false};
165 int imode{0};
166
167 for (std::int64_t i = 0; i < modeLength; ++i) {
168 switch (mode[i]) {
169 case 'r':
170 read = true;
171 break;
172 case 'w':
173 write = true;
174 break;
175 case 'x':
176 execute = true;
177 break;
178 case ' ':
179 exists = true;
180 break;
181 default:
182 // invalid mode
183 goto cleanup;
184 }
185 }
186 if (!read && !write && !execute && !exists) {
187 // invalid mode
188 goto cleanup;
189 }
190
191 if (!read && !write && !execute) {
192 imode = F_OK;
193 } else {
194 if (read) {
195 imode |= R_OK;
196 }
197 if (write) {
198 imode |= W_OK;
199 }
200 if (execute) {
201 imode |= X_OK;
202 }
203 }
204 ret = access(name, imode);
205
206cleanup:
207 if (newName) {
208 free(newName);
209 }
210 return ret;
211}
212#endif
213
214} // namespace Fortran::runtime
215} // extern "C"
216

source code of flang/runtime/extensions.cpp