c1db35f0c2
Define APIs, naively implement, and add basic sanity unit tests for the transformational intrinsic functions CSHIFT, EOSHIFT, PACK, SPREAD, TRANSPOSE, and UNPACK. These are the remaining transformational intrinsic functions that rearrange data without regard to type (except for default boundary values in EOSHIFT); RESHAPE was already in place as a stress test for the runtime's descriptor handling facilities. Code is in place to create copies of allocatable/automatic components when transforming arrays of derived type, but it won't do anything until we have derived type information being passed to the runtime from the frontend. Differential Revision: https://reviews.llvm.org/D102857
110 lines
3.1 KiB
C++
110 lines
3.1 KiB
C++
//===-- runtime/tools.cpp ---------------------------------------*- C++ -*-===//
|
|
//
|
|
// 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
|
|
//
|
|
//===----------------------------------------------------------------------===//
|
|
|
|
#include "tools.h"
|
|
#include "terminator.h"
|
|
#include <algorithm>
|
|
#include <cstdint>
|
|
#include <cstring>
|
|
|
|
namespace Fortran::runtime {
|
|
|
|
std::size_t TrimTrailingSpaces(const char *s, std::size_t n) {
|
|
while (n > 0 && s[n - 1] == ' ') {
|
|
--n;
|
|
}
|
|
return n;
|
|
}
|
|
|
|
OwningPtr<char> SaveDefaultCharacter(
|
|
const char *s, std::size_t length, const Terminator &terminator) {
|
|
if (s) {
|
|
auto *p{static_cast<char *>(AllocateMemoryOrCrash(terminator, length + 1))};
|
|
std::memcpy(p, s, length);
|
|
p[length] = '\0';
|
|
return OwningPtr<char>{p};
|
|
} else {
|
|
return OwningPtr<char>{};
|
|
}
|
|
}
|
|
|
|
static bool CaseInsensitiveMatch(
|
|
const char *value, std::size_t length, const char *possibility) {
|
|
for (; length-- > 0; ++possibility) {
|
|
char ch{*value++};
|
|
if (ch >= 'a' && ch <= 'z') {
|
|
ch += 'A' - 'a';
|
|
}
|
|
if (*possibility != ch) {
|
|
if (*possibility != '\0' || ch != ' ') {
|
|
return false;
|
|
}
|
|
// Ignore trailing blanks (12.5.6.2 p1)
|
|
while (length-- > 0) {
|
|
if (*value++ != ' ') {
|
|
return false;
|
|
}
|
|
}
|
|
return true;
|
|
}
|
|
}
|
|
return *possibility == '\0';
|
|
}
|
|
|
|
int IdentifyValue(
|
|
const char *value, std::size_t length, const char *possibilities[]) {
|
|
if (value) {
|
|
for (int j{0}; possibilities[j]; ++j) {
|
|
if (CaseInsensitiveMatch(value, length, possibilities[j])) {
|
|
return j;
|
|
}
|
|
}
|
|
}
|
|
return -1;
|
|
}
|
|
|
|
void ToFortranDefaultCharacter(
|
|
char *to, std::size_t toLength, const char *from) {
|
|
std::size_t len{std::strlen(from)};
|
|
std::memcpy(to, from, std::max(toLength, len));
|
|
if (len < toLength) {
|
|
std::memset(to + len, ' ', toLength - len);
|
|
}
|
|
}
|
|
|
|
void CheckConformability(const Descriptor &to, const Descriptor &x,
|
|
Terminator &terminator, const char *funcName, const char *toName,
|
|
const char *xName) {
|
|
if (x.rank() == 0) {
|
|
return; // scalar conforms with anything
|
|
}
|
|
int rank{to.rank()};
|
|
if (x.rank() != rank) {
|
|
terminator.Crash(
|
|
"Incompatible array arguments to %s: %s has rank %d but %s has rank %d",
|
|
funcName, toName, rank, xName, x.rank());
|
|
} else {
|
|
for (int j{0}; j < rank; ++j) {
|
|
auto toExtent{static_cast<std::int64_t>(to.GetDimension(j).Extent())};
|
|
auto xExtent{static_cast<std::int64_t>(x.GetDimension(j).Extent())};
|
|
if (xExtent != toExtent) {
|
|
terminator.Crash("Incompatible array arguments to %s: dimension %d of "
|
|
"%s has extent %" PRId64 " but %s has extent %" PRId64,
|
|
funcName, j, toName, toExtent, xName, xExtent);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
void CheckIntegerKind(Terminator &terminator, int kind, const char *intrinsic) {
|
|
if (kind < 1 || kind > 16 || (kind & (kind - 1)) != 0) {
|
|
terminator.Crash("%s: bad KIND=%d argument", intrinsic, kind);
|
|
}
|
|
}
|
|
} // namespace Fortran::runtime
|