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