1 /* Copyright 1995-1996,1999-2000,2004,2006,2008-2010,2018
2 Free Software Foundation, Inc.
3
4 This file is part of Guile.
5
6 Guile is free software: you can redistribute it and/or modify it
7 under the terms of the GNU Lesser General Public License as published
8 by the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
10
11 Guile is distributed in the hope that it will be useful, but WITHOUT
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
14 License for more details.
15
16 You should have received a copy of the GNU Lesser General Public
17 License along with Guile. If not, see
18 <https://www.gnu.org/licenses/>. */
19
20
21
22 #ifdef HAVE_CONFIG_H
23 # include <config.h>
24 #endif
25
26 #include "boolean.h"
27 #include "chars.h"
28 #include "gsubr.h"
29 #include "pairs.h"
30 #include "srfi-13.h"
31 #include "strings.h"
32 #include "symbols.h"
33
34 #include "strorder.h"
35
36
37
38
39
40 SCM_C_INLINE_KEYWORD static SCM
srfi13_cmp(SCM s1,SCM s2,SCM (* cmp)(SCM,SCM,SCM,SCM,SCM,SCM))41 srfi13_cmp (SCM s1, SCM s2, SCM (*cmp) (SCM, SCM, SCM, SCM, SCM, SCM))
42 {
43 if (scm_is_true (cmp (s1, s2,
44 SCM_UNDEFINED, SCM_UNDEFINED,
45 SCM_UNDEFINED, SCM_UNDEFINED)))
46 return SCM_BOOL_T;
47 else
48 return SCM_BOOL_F;
49 }
50
51 static SCM scm_i_string_equal_p (SCM s1, SCM s2, SCM rest);
52 SCM_DEFINE (scm_i_string_equal_p, "string=?", 0, 2, 1,
53 (SCM s1, SCM s2, SCM rest),
54 "Lexicographic equality predicate; return @code{#t} if the two\n"
55 "strings are the same length and contain the same characters in\n"
56 "the same positions, otherwise return @code{#f}.\n"
57 "\n"
58 "The procedure @code{string-ci=?} treats upper and lower case\n"
59 "letters as though they were the same character, but\n"
60 "@code{string=?} treats upper and lower case as distinct\n"
61 "characters.")
62 #define FUNC_NAME s_scm_i_string_equal_p
63 {
64 if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
65 return SCM_BOOL_T;
66 while (!scm_is_null (rest))
67 {
68 if (scm_is_false (srfi13_cmp (s1, s2, scm_string_eq)))
69 return SCM_BOOL_F;
70 s1 = s2;
71 s2 = scm_car (rest);
72 rest = scm_cdr (rest);
73 }
74 return srfi13_cmp (s1, s2, scm_string_eq);
75 }
76 #undef FUNC_NAME
77
scm_string_equal_p(SCM s1,SCM s2)78 SCM scm_string_equal_p (SCM s1, SCM s2)
79 #define FUNC_NAME s_scm_i_string_equal_p
80 {
81 return srfi13_cmp (s1, s2, scm_string_eq);
82 }
83 #undef FUNC_NAME
84
85 static SCM scm_i_string_ci_equal_p (SCM s1, SCM s2, SCM rest);
86 SCM_DEFINE (scm_i_string_ci_equal_p, "string-ci=?", 0, 2, 1,
87 (SCM s1, SCM s2, SCM rest),
88 "Case-insensitive string equality predicate; return @code{#t} if\n"
89 "the two strings are the same length and their component\n"
90 "characters match (ignoring case) at each position; otherwise\n"
91 "return @code{#f}.")
92 #define FUNC_NAME s_scm_i_string_ci_equal_p
93 {
94 if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
95 return SCM_BOOL_T;
96 while (!scm_is_null (rest))
97 {
98 if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_eq)))
99 return SCM_BOOL_F;
100 s1 = s2;
101 s2 = scm_car (rest);
102 rest = scm_cdr (rest);
103 }
104 return srfi13_cmp (s1, s2, scm_string_ci_eq);
105 }
106 #undef FUNC_NAME
107
scm_string_ci_equal_p(SCM s1,SCM s2)108 SCM scm_string_ci_equal_p (SCM s1, SCM s2)
109 #define FUNC_NAME s_scm_i_string_ci_equal_p
110 {
111 return srfi13_cmp (s1, s2, scm_string_ci_eq);
112 }
113 #undef FUNC_NAME
114
115 static SCM scm_i_string_less_p (SCM s1, SCM s2, SCM rest);
116 SCM_DEFINE (scm_i_string_less_p, "string<?", 0, 2, 1,
117 (SCM s1, SCM s2, SCM rest),
118 "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
119 "is lexicographically less than @var{s2}.")
120 #define FUNC_NAME s_scm_i_string_less_p
121 {
122 if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
123 return SCM_BOOL_T;
124 while (!scm_is_null (rest))
125 {
126 if (scm_is_false (srfi13_cmp (s1, s2, scm_string_lt)))
127 return SCM_BOOL_F;
128 s1 = s2;
129 s2 = scm_car (rest);
130 rest = scm_cdr (rest);
131 }
132 return srfi13_cmp (s1, s2, scm_string_lt);
133 }
134 #undef FUNC_NAME
135
scm_string_less_p(SCM s1,SCM s2)136 SCM scm_string_less_p (SCM s1, SCM s2)
137 #define FUNC_NAME s_scm_i_string_less_p
138 {
139 return srfi13_cmp (s1, s2, scm_string_lt);
140 }
141 #undef FUNC_NAME
142
143 static SCM scm_i_string_leq_p (SCM s1, SCM s2, SCM rest);
144 SCM_DEFINE (scm_i_string_leq_p, "string<=?", 0, 2, 1,
145 (SCM s1, SCM s2, SCM rest),
146 "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
147 "is lexicographically less than or equal to @var{s2}.")
148 #define FUNC_NAME s_scm_i_string_leq_p
149 {
150 if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
151 return SCM_BOOL_T;
152 while (!scm_is_null (rest))
153 {
154 if (scm_is_false (srfi13_cmp (s1, s2, scm_string_le)))
155 return SCM_BOOL_F;
156 s1 = s2;
157 s2 = scm_car (rest);
158 rest = scm_cdr (rest);
159 }
160 return srfi13_cmp (s1, s2, scm_string_le);
161 }
162 #undef FUNC_NAME
163
scm_string_leq_p(SCM s1,SCM s2)164 SCM scm_string_leq_p (SCM s1, SCM s2)
165 #define FUNC_NAME s_scm_i_string_leq_p
166 {
167 return srfi13_cmp (s1, s2, scm_string_le);
168 }
169 #undef FUNC_NAME
170
171 static SCM scm_i_string_gr_p (SCM s1, SCM s2, SCM rest);
172 SCM_DEFINE (scm_i_string_gr_p, "string>?", 0, 2, 1,
173 (SCM s1, SCM s2, SCM rest),
174 "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
175 "is lexicographically greater than @var{s2}.")
176 #define FUNC_NAME s_scm_i_string_gr_p
177 {
178 if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
179 return SCM_BOOL_T;
180 while (!scm_is_null (rest))
181 {
182 if (scm_is_false (srfi13_cmp (s1, s2, scm_string_gt)))
183 return SCM_BOOL_F;
184 s1 = s2;
185 s2 = scm_car (rest);
186 rest = scm_cdr (rest);
187 }
188 return srfi13_cmp (s1, s2, scm_string_gt);
189 }
190 #undef FUNC_NAME
191
scm_string_gr_p(SCM s1,SCM s2)192 SCM scm_string_gr_p (SCM s1, SCM s2)
193 #define FUNC_NAME s_scm_i_string_gr_p
194 {
195 return srfi13_cmp (s1, s2, scm_string_gt);
196 }
197 #undef FUNC_NAME
198
199 static SCM scm_i_string_geq_p (SCM s1, SCM s2, SCM rest);
200 SCM_DEFINE (scm_i_string_geq_p, "string>=?", 0, 2, 1,
201 (SCM s1, SCM s2, SCM rest),
202 "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
203 "is lexicographically greater than or equal to @var{s2}.")
204 #define FUNC_NAME s_scm_i_string_geq_p
205 {
206 if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
207 return SCM_BOOL_T;
208 while (!scm_is_null (rest))
209 {
210 if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ge)))
211 return SCM_BOOL_F;
212 s1 = s2;
213 s2 = scm_car (rest);
214 rest = scm_cdr (rest);
215 }
216 return srfi13_cmp (s1, s2, scm_string_ge);
217 }
218 #undef FUNC_NAME
219
scm_string_geq_p(SCM s1,SCM s2)220 SCM scm_string_geq_p (SCM s1, SCM s2)
221 #define FUNC_NAME s_scm_i_string_geq_p
222 {
223 return srfi13_cmp (s1, s2, scm_string_ge);
224 }
225 #undef FUNC_NAME
226
227 static SCM scm_i_string_ci_less_p (SCM s1, SCM s2, SCM rest);
228 SCM_DEFINE (scm_i_string_ci_less_p, "string-ci<?", 0, 2, 1,
229 (SCM s1, SCM s2, SCM rest),
230 "Case insensitive lexicographic ordering predicate; return\n"
231 "@code{#t} if @var{s1} is lexicographically less than @var{s2}\n"
232 "regardless of case.")
233 #define FUNC_NAME s_scm_i_string_ci_less_p
234 {
235 if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
236 return SCM_BOOL_T;
237 while (!scm_is_null (rest))
238 {
239 if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_lt)))
240 return SCM_BOOL_F;
241 s1 = s2;
242 s2 = scm_car (rest);
243 rest = scm_cdr (rest);
244 }
245 return srfi13_cmp (s1, s2, scm_string_ci_lt);
246 }
247 #undef FUNC_NAME
248
scm_string_ci_less_p(SCM s1,SCM s2)249 SCM scm_string_ci_less_p (SCM s1, SCM s2)
250 #define FUNC_NAME s_scm_i_string_ci_less_p
251 {
252 return srfi13_cmp (s1, s2, scm_string_ci_lt);
253 }
254 #undef FUNC_NAME
255
256 static SCM scm_i_string_ci_leq_p (SCM s1, SCM s2, SCM rest);
257 SCM_DEFINE (scm_i_string_ci_leq_p, "string-ci<=?", 0, 2, 1,
258 (SCM s1, SCM s2, SCM rest),
259 "Case insensitive lexicographic ordering predicate; return\n"
260 "@code{#t} if @var{s1} is lexicographically less than or equal\n"
261 "to @var{s2} regardless of case.")
262 #define FUNC_NAME s_scm_i_string_ci_leq_p
263 {
264 if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
265 return SCM_BOOL_T;
266 while (!scm_is_null (rest))
267 {
268 if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_le)))
269 return SCM_BOOL_F;
270 s1 = s2;
271 s2 = scm_car (rest);
272 rest = scm_cdr (rest);
273 }
274 return srfi13_cmp (s1, s2, scm_string_ci_le);
275 }
276 #undef FUNC_NAME
277
scm_string_ci_leq_p(SCM s1,SCM s2)278 SCM scm_string_ci_leq_p (SCM s1, SCM s2)
279 #define FUNC_NAME s_scm_i_string_ci_leq_p
280 {
281 return srfi13_cmp (s1, s2, scm_string_ci_le);
282 }
283 #undef FUNC_NAME
284
285 static SCM scm_i_string_ci_gr_p (SCM s1, SCM s2, SCM rest);
286 SCM_DEFINE (scm_i_string_ci_gr_p, "string-ci>?", 0, 2, 1,
287 (SCM s1, SCM s2, SCM rest),
288 "Case insensitive lexicographic ordering predicate; return\n"
289 "@code{#t} if @var{s1} is lexicographically greater than\n"
290 "@var{s2} regardless of case.")
291 #define FUNC_NAME s_scm_i_string_ci_gr_p
292 {
293 if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
294 return SCM_BOOL_T;
295 while (!scm_is_null (rest))
296 {
297 if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_gt)))
298 return SCM_BOOL_F;
299 s1 = s2;
300 s2 = scm_car (rest);
301 rest = scm_cdr (rest);
302 }
303 return srfi13_cmp (s1, s2, scm_string_ci_gt);
304 }
305 #undef FUNC_NAME
306
scm_string_ci_gr_p(SCM s1,SCM s2)307 SCM scm_string_ci_gr_p (SCM s1, SCM s2)
308 #define FUNC_NAME s_scm_i_string_ci_gr_p
309 {
310 return srfi13_cmp (s1, s2, scm_string_ci_gt);
311 }
312 #undef FUNC_NAME
313
314 static SCM scm_i_string_ci_geq_p (SCM s1, SCM s2, SCM rest);
315 SCM_DEFINE (scm_i_string_ci_geq_p, "string-ci>=?", 0, 2, 1,
316 (SCM s1, SCM s2, SCM rest),
317 "Case insensitive lexicographic ordering predicate; return\n"
318 "@code{#t} if @var{s1} is lexicographically greater than or\n"
319 "equal to @var{s2} regardless of case.")
320 #define FUNC_NAME s_scm_i_string_ci_geq_p
321 {
322 if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
323 return SCM_BOOL_T;
324 while (!scm_is_null (rest))
325 {
326 if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_ge)))
327 return SCM_BOOL_F;
328 s1 = s2;
329 s2 = scm_car (rest);
330 rest = scm_cdr (rest);
331 }
332 return srfi13_cmp (s1, s2, scm_string_ci_ge);
333 }
334 #undef FUNC_NAME
335
scm_string_ci_geq_p(SCM s1,SCM s2)336 SCM scm_string_ci_geq_p (SCM s1, SCM s2)
337 #define FUNC_NAME s_scm_i_string_ci_geq_p
338 {
339 return srfi13_cmp (s1, s2, scm_string_ci_ge);
340 }
341 #undef FUNC_NAME
342
343
344
345 void
scm_init_strorder()346 scm_init_strorder ()
347 {
348 #include "strorder.x"
349 }
350
351