1 /*
2 * Copyright (c) 2017, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /* fortran miscelleneous character support routines */
19
20 #include <string.h>
21 #include "stdarg.h"
22 #include "enames.h"
23 #include "ftni64.h"
24 #define TRUE 1
25 #define FALSE 0
26
27 #ifndef NULL
28 #define NULL (void *)0
29 #endif
30
31 /*************************************************************************/
32 /* function: Ftn_str_kindex:
33 *
34 * Implements the INDEX intrinsic; is an integer*8 function which returns the
35 * value according to the INDEX intrinsic.
36 */
37 /*************************************************************************/
38 _LONGLONG_T
ftn_str_kindex(a1,a2,a1_len,a2_len)39 ftn_str_kindex(a1, a2, a1_len,
40 a2_len) char *a1; /* pointer to string being searched */
41 char *a2; /* pointer to string being searched for */
42 int a1_len; /* length of a1 */
43 int a2_len; /* length of a2 */
44 {
45 int idx1, idx2, match;
46 for (idx1 = 0; idx1 < a1_len; idx1++) {
47 if (a2_len > (a1_len - idx1))
48 return 0;
49 match = TRUE;
50 for (idx2 = 0; idx2 < a2_len; idx2++) {
51 if (a1[idx1 + idx2] != a2[idx2]) {
52 match = FALSE;
53 break;
54 }
55 }
56 if (match) {
57 return (idx1 + 1);
58 }
59 }
60 return 0;
61 }
62
63 /*************************************************************************/
64 /* function: Ftn_strcmp
65 *
66 * Implements realational operators with string operands and the lexical
67 * intrinsics. Returns integer value:
68 * 0 => strings are the same
69 * -1 => a1 lexically less than a2
70 * 1 => a1 lexically greater than a2
71 * If the strings are of unequal lengths, treats shorter string as if it were
72 * padded with blanks.
73 */
74 /*************************************************************************/
Ftn_kstrcmp(a1,a2,a1_len,a2_len)75 int Ftn_kstrcmp(a1, a2, a1_len,
76 a2_len) char *a1; /* first string to be compared */
77 char *a2; /* second string to be compared */
78 int a1_len; /* length of a1 */
79 int a2_len; /* length of a2 */
80 {
81 int ret_val, idx1;
82 if (a1_len == a2_len) {
83 ret_val = (memcmp(a1, a2, a1_len));
84 if (ret_val == 0)
85 return (0);
86 if (ret_val < 0)
87 return (-1);
88 if (ret_val > 0)
89 return (1);
90 }
91 if (a1_len > a2_len) {
92 /* first compare the first a2_len characters of the strings */
93 ret_val = memcmp(a1, a2, a2_len);
94 if (ret_val != 0) {
95 if (ret_val < 0)
96 return (-1);
97 if (ret_val > 0)
98 return (1);
99 }
100 /*
101 * if the last (a1_len - a2_len) characters of a1 are blank, then the
102 * strings are equal; otherwise, compare the first non-blank char. to
103 * blank
104 */
105
106 for (idx1 = 0; idx1 < (a1_len - a2_len); idx1++) {
107 if (a1[a2_len + idx1] != ' ') {
108 if (a1[a2_len + idx1] > ' ')
109 return (1);
110 return (-1);
111 }
112 }
113 return (0);
114 } else {
115 /* a2_len > a1_len */
116 /* first compare the first a1_len characters of the strings */
117 ret_val = memcmp(a1, a2, a1_len);
118 if (ret_val != 0) {
119 if (ret_val < 0)
120 return (-1);
121 if (ret_val > 0)
122 return (1);
123 }
124 /*
125 * if the last (a2_len - a1_len) characters of a2 are blank, then the
126 * strings are equal; otherwise, compare the first non-blank char. to
127 * blank
128 */
129
130 for (idx1 = 0; idx1 < (a2_len - a1_len); idx1++) {
131 if (a2[a1_len + idx1] != ' ') {
132 if (a2[a1_len + idx1] > ' ')
133 return (-1);
134 return (1);
135 }
136 }
137 return (0);
138 }
139 }
140
141 /*************************************************************************/
142 /* function: Ftn_str_kindex_klen:
143 *
144 * Implements the INDEX intrinsic; is an integer*8 function which returns the
145 * value according to the INDEX intrinsic.
146 */
147 /*************************************************************************/
148 _LONGLONG_T
ftn_str_kindex_klen(a1,a2,a1_len,a2_len)149 ftn_str_kindex_klen(a1, a2, a1_len,
150 a2_len) char *a1; /* pointer to string being searched */
151 char *a2; /* pointer to string being searched for */
152 _LONGLONG_T a1_len; /* length of a1 */
153 _LONGLONG_T a2_len; /* length of a2 */
154 {
155 _LONGLONG_T idx1, idx2;
156 int match;
157 for (idx1 = 0; idx1 < a1_len; idx1++) {
158 if (a2_len > (a1_len - idx1))
159 return 0;
160 match = TRUE;
161 for (idx2 = 0; idx2 < a2_len; idx2++) {
162 if (a1[idx1 + idx2] != a2[idx2]) {
163 match = FALSE;
164 break;
165 }
166 }
167 if (match) {
168 return (idx1 + 1);
169 }
170 }
171 return 0;
172 }
173
174 /*************************************************************************/
175 /* function: Ftn_strcmp_klen
176 *
177 * Implements realational operators with string operands and the lexical
178 * intrinsics. Returns integer value:
179 * 0 => strings are the same
180 * -1 => a1 lexically less than a2
181 * 1 => a1 lexically greater than a2
182 * If the strings are of unequal lengths, treats shorter string as if it were
183 * padded with blanks.
184 */
185 /*************************************************************************/
Ftn_kstrcmp_klen(a1,a2,a1_len,a2_len)186 int Ftn_kstrcmp_klen(a1, a2, a1_len,
187 a2_len) char *a1; /* first string to be compared */
188 char *a2; /* second string to be compared */
189 _LONGLONG_T a1_len; /* length of a1 */
190 _LONGLONG_T a2_len; /* length of a2 */
191 {
192 _LONGLONG_T idx1;
193 int ret_val;
194 if (a1_len == a2_len) {
195 ret_val = (memcmp(a1, a2, (size_t)a1_len));
196 if (ret_val == 0)
197 return (0);
198 if (ret_val < 0)
199 return (-1);
200 if (ret_val > 0)
201 return (1);
202 }
203 if (a1_len > a2_len) {
204 /* first compare the first a2_len characters of the strings */
205 ret_val = memcmp(a1, a2, (size_t)a2_len);
206 if (ret_val != 0) {
207 if (ret_val < 0)
208 return (-1);
209 if (ret_val > 0)
210 return (1);
211 }
212 /*
213 * if the last (a1_len - a2_len) characters of a1 are blank, then the
214 * strings are equal; otherwise, compare the first non-blank char. to
215 * blank
216 */
217
218 for (idx1 = 0; idx1 < (a1_len - a2_len); idx1++) {
219 if (a1[a2_len + idx1] != ' ') {
220 if (a1[a2_len + idx1] > ' ')
221 return (1);
222 return (-1);
223 }
224 }
225 return (0);
226 } else {
227 /* a2_len > a1_len */
228 /* first compare the first a1_len characters of the strings */
229 ret_val = memcmp(a1, a2, (size_t)a1_len);
230 if (ret_val != 0) {
231 if (ret_val < 0)
232 return (-1);
233 if (ret_val > 0)
234 return (1);
235 }
236 /*
237 * if the last (a2_len - a1_len) characters of a2 are blank, then the
238 * strings are equal; otherwise, compare the first non-blank char. to
239 * blank
240 */
241
242 for (idx1 = 0; idx1 < (a2_len - a1_len); idx1++) {
243 if (a2[a1_len + idx1] != ' ') {
244 if (a2[a1_len + idx1] > ' ')
245 return (-1);
246 return (1);
247 }
248 }
249 return (0);
250 }
251 }
252