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