Commit | Line | Data |
---|---|---|
0f2d19dd JB |
1 | /* Copyright (C) 1995,1996 Free Software Foundation, Inc. |
2 | * | |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
15 | * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
16 | * | |
17 | * As a special exception, the Free Software Foundation gives permission | |
18 | * for additional uses of the text contained in its release of GUILE. | |
19 | * | |
20 | * The exception is that, if you link the GUILE library with other files | |
21 | * to produce an executable, this does not by itself cause the | |
22 | * resulting executable to be covered by the GNU General Public License. | |
23 | * Your use of that executable is in no way restricted on account of | |
24 | * linking the GUILE library code into it. | |
25 | * | |
26 | * This exception does not however invalidate any other reasons why | |
27 | * the executable file might be covered by the GNU General Public License. | |
28 | * | |
29 | * This exception applies only to the code released by the | |
30 | * Free Software Foundation under the name GUILE. If you copy | |
31 | * code from other Free Software Foundation releases into a copy of | |
32 | * GUILE, as the General Public License permits, the exception does | |
33 | * not apply to the code that you add in this way. To avoid misleading | |
34 | * anyone as to the status of such modified files, you must delete | |
35 | * this exception notice from them. | |
36 | * | |
37 | * If you write modifications of your own for GUILE, it is your choice | |
38 | * whether to permit this exception to apply to your modifications. | |
39 | * If you do not wish that, delete this exception notice. | |
40 | */ | |
41 | \f | |
42 | ||
43 | #include <stdio.h> | |
44 | #include "_scm.h" | |
20e6290e | 45 | #include "chars.h" |
0f2d19dd | 46 | |
20e6290e | 47 | #include "strorder.h" |
0f2d19dd JB |
48 | \f |
49 | ||
50 | SCM_PROC1 (s_string_equal_p, "string=?", scm_tc7_rpsubr, scm_string_equal_p); | |
51 | #ifdef __STDC__ | |
52 | SCM | |
53 | scm_string_equal_p (SCM s1, SCM s2) | |
54 | #else | |
55 | SCM | |
56 | scm_string_equal_p (s1, s2) | |
57 | SCM s1; | |
58 | SCM s2; | |
59 | #endif | |
60 | { | |
61 | register scm_sizet i; | |
62 | register char *c1, *c2; | |
63 | SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_equal_p); | |
64 | SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_equal_p); | |
65 | ||
66 | i = SCM_ROLENGTH (s2); | |
67 | if (SCM_ROLENGTH (s1) != i) | |
68 | { | |
69 | return SCM_BOOL_F; | |
70 | } | |
71 | c1 = SCM_ROCHARS (s1); | |
72 | c2 = SCM_ROCHARS (s2); | |
73 | while (0 != i--) | |
74 | if (*c1++ != *c2++) | |
75 | return SCM_BOOL_F; | |
76 | return SCM_BOOL_T; | |
77 | } | |
78 | ||
79 | SCM_PROC1 (s_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, scm_string_ci_equal_p); | |
80 | #ifdef __STDC__ | |
81 | SCM | |
82 | scm_string_ci_equal_p (SCM s1, SCM s2) | |
83 | #else | |
84 | SCM | |
85 | scm_string_ci_equal_p (s1, s2) | |
86 | SCM s1; | |
87 | SCM s2; | |
88 | #endif | |
89 | { | |
90 | register scm_sizet i; | |
91 | register unsigned char *c1, *c2; | |
92 | SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_ci_equal_p); | |
93 | SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_ci_equal_p); | |
94 | i = SCM_ROLENGTH (s2); | |
95 | if (SCM_ROLENGTH (s1) != i) | |
96 | { | |
97 | return SCM_BOOL_F; | |
98 | } | |
99 | c1 = SCM_ROUCHARS (s1); | |
100 | c2 = SCM_ROUCHARS (s2); | |
101 | while (0 != i--) | |
102 | if (scm_upcase(*c1++) != scm_upcase(*c2++)) | |
103 | return SCM_BOOL_F; | |
104 | return SCM_BOOL_T; | |
105 | } | |
106 | ||
107 | SCM_PROC1 (s_string_less_p, "string<?", scm_tc7_rpsubr, scm_string_less_p); | |
108 | #ifdef __STDC__ | |
109 | SCM | |
110 | scm_string_less_p (SCM s1, SCM s2) | |
111 | #else | |
112 | SCM | |
113 | scm_string_less_p (s1, s2) | |
114 | SCM s1; | |
115 | SCM s2; | |
116 | #endif | |
117 | { | |
118 | register scm_sizet i, len, s2len; | |
119 | register unsigned char *c1, *c2; | |
120 | register int c; | |
121 | ||
122 | SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_less_p); | |
123 | SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_less_p); | |
124 | len = SCM_ROLENGTH (s1); | |
125 | s2len = i = SCM_ROLENGTH (s2); | |
126 | if (len>i) i = len; | |
127 | c1 = SCM_ROUCHARS (s1); | |
128 | c2 = SCM_ROUCHARS (s2); | |
129 | ||
130 | for (i = 0;i<len;i++) { | |
131 | c = (*c1++ - *c2++); | |
132 | if (c>0) | |
133 | return SCM_BOOL_F; | |
134 | if (c<0) | |
135 | return SCM_BOOL_T; | |
136 | } | |
137 | { | |
138 | SCM answer; | |
139 | answer = (s2len != len) ? SCM_BOOL_T : SCM_BOOL_F; | |
140 | return answer; | |
141 | } | |
142 | } | |
143 | ||
144 | SCM_PROC1 (s_string_leq_p, "string<=?", scm_tc7_rpsubr, scm_string_leq_p); | |
145 | #ifdef __STDC__ | |
146 | SCM | |
147 | scm_string_leq_p (SCM s1, SCM s2) | |
148 | #else | |
149 | SCM | |
150 | scm_string_leq_p (s1, s2) | |
151 | SCM s1; | |
152 | SCM s2; | |
153 | #endif | |
154 | { | |
155 | return SCM_BOOL_NOT (scm_string_less_p (s2, s1)); | |
156 | } | |
157 | ||
158 | SCM_PROC1 (s_string_gr_p, "string>?", scm_tc7_rpsubr, scm_string_gr_p); | |
159 | #ifdef __STDC__ | |
160 | SCM | |
161 | scm_string_gr_p (SCM s1, SCM s2) | |
162 | #else | |
163 | SCM | |
164 | scm_string_gr_p (s1, s2) | |
165 | SCM s1; | |
166 | SCM s2; | |
167 | #endif | |
168 | { | |
169 | return scm_string_less_p (s2, s1); | |
170 | } | |
171 | ||
172 | SCM_PROC1 (s_string_geq_p, "string>=?", scm_tc7_rpsubr, scm_string_geq_p); | |
173 | #ifdef __STDC__ | |
174 | SCM | |
175 | scm_string_geq_p (SCM s1, SCM s2) | |
176 | #else | |
177 | SCM | |
178 | scm_string_geq_p (s1, s2) | |
179 | SCM s1; | |
180 | SCM s2; | |
181 | #endif | |
182 | { | |
183 | return SCM_BOOL_NOT (scm_string_less_p (s1, s2)); | |
184 | } | |
185 | ||
186 | SCM_PROC1 (s_string_ci_less_p, "string-ci<?", scm_tc7_rpsubr, scm_string_ci_less_p); | |
187 | #ifdef __STDC__ | |
188 | SCM | |
189 | scm_string_ci_less_p (SCM s1, SCM s2) | |
190 | #else | |
191 | SCM | |
192 | scm_string_ci_less_p (s1, s2) | |
193 | SCM s1; | |
194 | SCM s2; | |
195 | #endif | |
196 | { | |
197 | register scm_sizet i, len, s2len; | |
198 | register unsigned char *c1, *c2; | |
199 | register int c; | |
200 | SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_ci_less_p); | |
201 | SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_ci_less_p); | |
202 | len = SCM_ROLENGTH (s1); | |
203 | s2len = i = SCM_ROLENGTH (s2); | |
204 | if (len>i) i=len; | |
205 | c1 = SCM_ROUCHARS (s1); | |
206 | c2 = SCM_ROUCHARS (s2); | |
207 | for (i = 0;i<len;i++) { | |
208 | c = (scm_upcase(*c1++) - scm_upcase(*c2++)); | |
209 | if (c>0) return SCM_BOOL_F; | |
210 | if (c<0) return SCM_BOOL_T; | |
211 | } | |
212 | return (s2len != len) ? SCM_BOOL_T : SCM_BOOL_F; | |
213 | } | |
214 | ||
215 | SCM_PROC1 (s_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr, scm_string_ci_leq_p); | |
216 | #ifdef __STDC__ | |
217 | SCM | |
218 | scm_string_ci_leq_p (SCM s1, SCM s2) | |
219 | #else | |
220 | SCM | |
221 | scm_string_ci_leq_p (s1, s2) | |
222 | SCM s1; | |
223 | SCM s2; | |
224 | #endif | |
225 | { | |
226 | return SCM_BOOL_NOT (scm_string_ci_less_p (s2, s1)); | |
227 | } | |
228 | ||
229 | SCM_PROC1 (s_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr, scm_string_ci_gr_p); | |
230 | #ifdef __STDC__ | |
231 | SCM | |
232 | scm_string_ci_gr_p (SCM s1, SCM s2) | |
233 | #else | |
234 | SCM | |
235 | scm_string_ci_gr_p (s1, s2) | |
236 | SCM s1; | |
237 | SCM s2; | |
238 | #endif | |
239 | { | |
240 | return scm_string_ci_less_p (s2, s1); | |
241 | } | |
242 | ||
243 | SCM_PROC1 (s_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, scm_string_ci_geq_p); | |
244 | #ifdef __STDC__ | |
245 | SCM | |
246 | scm_string_ci_geq_p (SCM s1, SCM s2) | |
247 | #else | |
248 | SCM | |
249 | scm_string_ci_geq_p (s1, s2) | |
250 | SCM s1; | |
251 | SCM s2; | |
252 | #endif | |
253 | { | |
254 | return SCM_BOOL_NOT (scm_string_ci_less_p (s1, s2)); | |
255 | } | |
256 | ||
257 | \f | |
258 | #ifdef __STDC__ | |
259 | void | |
260 | scm_init_strorder (void) | |
261 | #else | |
262 | void | |
263 | scm_init_strorder () | |
264 | #endif | |
265 | { | |
266 | #include "strorder.x" | |
267 | } | |
268 |