1 //===-- runtime/tools.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 #include "tools.h"
10 #include "terminator.h"
11 #include <algorithm>
12 #include <cstdint>
13 #include <cstdlib>
14 #include <cstring>
15
16 namespace Fortran::runtime {
17
TrimTrailingSpaces(const char * s,std::size_t n)18 std::size_t TrimTrailingSpaces(const char *s, std::size_t n) {
19 while (n > 0 && s[n - 1] == ' ') {
20 --n;
21 }
22 return n;
23 }
24
SaveDefaultCharacter(const char * s,std::size_t length,const Terminator & terminator)25 OwningPtr<char> SaveDefaultCharacter(
26 const char *s, std::size_t length, const Terminator &terminator) {
27 if (s) {
28 auto *p{static_cast<char *>(AllocateMemoryOrCrash(terminator, length + 1))};
29 std::memcpy(p, s, length);
30 p[length] = '\0';
31 return OwningPtr<char>{p};
32 } else {
33 return OwningPtr<char>{};
34 }
35 }
36
CaseInsensitiveMatch(const char * value,std::size_t length,const char * possibility)37 static bool CaseInsensitiveMatch(
38 const char *value, std::size_t length, const char *possibility) {
39 for (; length-- > 0; ++possibility) {
40 char ch{*value++};
41 if (ch >= 'a' && ch <= 'z') {
42 ch += 'A' - 'a';
43 }
44 if (*possibility != ch) {
45 if (*possibility != '\0' || ch != ' ') {
46 return false;
47 }
48 // Ignore trailing blanks (12.5.6.2 p1)
49 while (length-- > 0) {
50 if (*value++ != ' ') {
51 return false;
52 }
53 }
54 return true;
55 }
56 }
57 return *possibility == '\0';
58 }
59
IdentifyValue(const char * value,std::size_t length,const char * possibilities[])60 int IdentifyValue(
61 const char *value, std::size_t length, const char *possibilities[]) {
62 if (value) {
63 for (int j{0}; possibilities[j]; ++j) {
64 if (CaseInsensitiveMatch(value, length, possibilities[j])) {
65 return j;
66 }
67 }
68 }
69 return -1;
70 }
71
ToFortranDefaultCharacter(char * to,std::size_t toLength,const char * from)72 void ToFortranDefaultCharacter(
73 char *to, std::size_t toLength, const char *from) {
74 std::size_t len{std::strlen(from)};
75 if (len < toLength) {
76 std::memcpy(to, from, len);
77 std::memset(to + len, ' ', toLength - len);
78 } else {
79 std::memcpy(to, from, toLength);
80 }
81 }
82
CheckConformability(const Descriptor & to,const Descriptor & x,Terminator & terminator,const char * funcName,const char * toName,const char * xName)83 void CheckConformability(const Descriptor &to, const Descriptor &x,
84 Terminator &terminator, const char *funcName, const char *toName,
85 const char *xName) {
86 if (x.rank() == 0) {
87 return; // scalar conforms with anything
88 }
89 int rank{to.rank()};
90 if (x.rank() != rank) {
91 terminator.Crash(
92 "Incompatible array arguments to %s: %s has rank %d but %s has rank %d",
93 funcName, toName, rank, xName, x.rank());
94 } else {
95 for (int j{0}; j < rank; ++j) {
96 auto toExtent{static_cast<std::int64_t>(to.GetDimension(j).Extent())};
97 auto xExtent{static_cast<std::int64_t>(x.GetDimension(j).Extent())};
98 if (xExtent != toExtent) {
99 terminator.Crash("Incompatible array arguments to %s: dimension %d of "
100 "%s has extent %" PRId64 " but %s has extent %" PRId64,
101 funcName, j + 1, toName, toExtent, xName, xExtent);
102 }
103 }
104 }
105 }
106
CheckIntegerKind(Terminator & terminator,int kind,const char * intrinsic)107 void CheckIntegerKind(Terminator &terminator, int kind, const char *intrinsic) {
108 if (kind < 1 || kind > 16 || (kind & (kind - 1)) != 0) {
109 terminator.Crash(
110 "not yet implemented: %s: KIND=%d argument", intrinsic, kind);
111 }
112 }
113 } // namespace Fortran::runtime
114