flang/runtime/extensions.cpp

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