1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252
|
//===-- runtime/extensions.cpp --------------------------------------------===//
//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
//
//===----------------------------------------------------------------------===//
// These C-coded entry points with Fortran-mangled names implement legacy
// 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/entry-names.h"
#include "flang/Runtime/io-api.h"
#include <chrono>
#include <cstring>
#include <ctime>
#include <signal.h>
#include <thread>
#ifdef _WIN32
#define WIN32_LEAN_AND_MEAN
#define NOMINMAX
#include <windows.h>
#include <synchapi.h>
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 || \
defined(_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
#ifndef _WIN32
// posix-compliant and has getlogin_r and F_OK
#include <unistd.h>
#endif
extern "C" {
namespace Fortran::runtime {
gid_t RTNAME(GetGID)() {
#ifdef _WIN32
// Group IDs don't exist on Windows, return 1 to avoid errors
return 1;
#else
return getgid();
#endif
}
uid_t RTNAME(GetUID)() {
#ifdef _WIN32
// User IDs don't exist on Windows, return 1 to avoid errors
return 1;
#else
return getuid();
#endif
}
void GetUsernameEnvVar(const char *envName, char *arg, std::int64_t length) {
Descriptor name{*Descriptor::Create(
1, std::strlen(envName) + 1, const_cast<char *>(envName), 0)};
Descriptor value{*Descriptor::Create(1, length, arg, 0)};
RTNAME(GetEnvVariable)
(name, &value, nullptr, false, nullptr, __FILE__, __LINE__);
}
namespace io {
// SUBROUTINE FLUSH(N)
// FLUSH N
// END
void FORTRAN_PROCEDURE_NAME(flush)(const int &unit) {
Cookie cookie{IONAME(BeginFlush)(unit, __FILE__, __LINE__)};
IONAME(EndIoStatement)(cookie);
}
} // 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);
}
std::intptr_t RTNAME(Malloc)(std::size_t size) {
return reinterpret_cast<std::intptr_t>(std::malloc(size));
}
// RESULT = IARGC()
std::int32_t FORTRAN_PROCEDURE_NAME(iargc)() { return RTNAME(ArgumentCount)(); }
// CALL GETARG(N, ARG)
void FORTRAN_PROCEDURE_NAME(getarg)(
std::int32_t &n, char *arg, std::int64_t length) {
Descriptor value{*Descriptor::Create(1, length, arg, 0)};
(void)RTNAME(GetCommandArgument)(
n, &value, nullptr, nullptr, __FILE__, __LINE__);
}
// CALL GETLOG(USRNAME)
void FORTRAN_PROCEDURE_NAME(getlog)(char *arg, std::int64_t length) {
#if _REENTRANT || _POSIX_C_SOURCE >= 199506L
if (length >= 1 && getlogin_r(arg, length) == 0) {
auto loginLen{std::strlen(arg)};
std::memset(
arg + loginLen, ' ', static_cast<std::size_t>(length) - loginLen);
return;
}
#endif
#if _WIN32
GetUsernameEnvVar("USERNAME", arg, length);
#else
GetUsernameEnvVar("LOGNAME", arg, length);
#endif
}
void RTNAME(Free)(std::intptr_t ptr) {
std::free(reinterpret_cast<void *>(ptr));
}
std::int64_t RTNAME(Signal)(std::int64_t number, void (*handler)(int)) {
// using auto for portability:
// on Windows, this is a void *
// on POSIX, this has the same type as handler
auto result = signal(number, handler);
// GNU defines the intrinsic as returning an integer, not a pointer. So we
// have to reinterpret_cast
return static_cast<int64_t>(reinterpret_cast<std::uintptr_t>(result));
}
// CALL SLEEP(SECONDS)
void RTNAME(Sleep)(std::int64_t seconds) {
// ensure that conversion to unsigned makes sense,
// sleep(0) is an immidiate return anyway
if (seconds < 1) {
return;
}
#if _WIN32
Sleep(seconds * 1000);
#else
sleep(seconds);
#endif
}
// TODO: not supported on Windows
#ifndef _WIN32
std::int64_t FORTRAN_PROCEDURE_NAME(access)(const char *name,
std::int64_t nameLength, const char *mode, std::int64_t modeLength) {
std::int64_t ret{-1};
if (nameLength <= 0 || modeLength <= 0 || !name || !mode) {
return ret;
}
// ensure name is null terminated
char *newName{nullptr};
if (name[nameLength - 1] != '\0') {
newName = static_cast<char *>(std::malloc(nameLength + 1));
std::memcpy(newName, name, nameLength);
newName[nameLength] = '\0';
name = newName;
}
// calculate mode
bool read{false};
bool write{false};
bool execute{false};
bool exists{false};
int imode{0};
for (std::int64_t i = 0; i < modeLength; ++i) {
switch (mode[i]) {
case 'r':
read = true;
break;
case 'w':
write = true;
break;
case 'x':
execute = true;
break;
case ' ':
exists = true;
break;
default:
// invalid mode
goto cleanup;
}
}
if (!read && !write && !execute && !exists) {
// invalid mode
goto cleanup;
}
if (!read && !write && !execute) {
imode = F_OK;
} else {
if (read) {
imode |= R_OK;
}
if (write) {
imode |= W_OK;
}
if (execute) {
imode |= X_OK;
}
}
ret = access(name, imode);
cleanup:
if (newName) {
free(newName);
}
return ret;
}
#endif
} // namespace Fortran::runtime
} // extern "C"
|