Commit | Line | Data |
---|---|---|
0f2d19dd JB |
1 | /* classes: src_files */ |
2 | ||
e1c01129 | 3 | /* Copyright (C) 1994, 1996, 1997 Free Software Foundation, Inc. |
0f2d19dd JB |
4 | |
5 | This program is free software; you can redistribute it and/or modify | |
6 | it under the terms of the GNU General Public License as published by | |
7 | the Free Software Foundation; either version 2, or (at your option) | |
8 | any later version. | |
9 | ||
10 | This program is distributed in the hope that it will be useful, | |
11 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 | GNU General Public License for more details. | |
14 | ||
15 | You should have received a copy of the GNU General Public License | |
82892bed JB |
16 | along with this software; see the file COPYING. If not, write to the |
17 | Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA | |
18 | 02111-1307 USA */ | |
0f2d19dd JB |
19 | |
20 | \f | |
21 | ||
22 | #include <stdio.h> | |
23 | #include "_scm.h" | |
20e6290e | 24 | #include "chars.h" |
0f2d19dd | 25 | |
20e6290e | 26 | #include "strop.h" |
99a9952d | 27 | #include "read.h" /*For SCM_CASE_INSENSITIVE_P*/ |
0f2d19dd JB |
28 | \f |
29 | ||
1cc91f1b | 30 | |
03bc4386 GH |
31 | /* implements index if direction > 0 otherwise rindex. */ |
32 | static int | |
99a9952d JB |
33 | scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, |
34 | SCM sub_end, const char *why) | |
35 | ||
0f2d19dd JB |
36 | { |
37 | unsigned char * p; | |
38 | int x; | |
03bc4386 GH |
39 | int lower; |
40 | int upper; | |
0f2d19dd JB |
41 | int ch; |
42 | ||
99a9952d JB |
43 | SCM_ASSERT (SCM_NIMP (*str) && SCM_ROSTRINGP (*str), *str, SCM_ARG1, why); |
44 | SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, why); | |
0f2d19dd JB |
45 | |
46 | if (sub_start == SCM_BOOL_F) | |
47 | sub_start = SCM_MAKINUM (0); | |
03bc4386 | 48 | |
99a9952d | 49 | SCM_ASSERT (SCM_INUMP (sub_start), sub_start, SCM_ARG3, why); |
03bc4386 GH |
50 | lower = SCM_INUM (sub_start); |
51 | if (lower < 0 | |
67ec3667 | 52 | || lower > SCM_ROLENGTH (*str)) |
03bc4386 | 53 | scm_out_of_range (why, sub_start); |
0f2d19dd JB |
54 | |
55 | if (sub_end == SCM_BOOL_F) | |
56 | sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str)); | |
03bc4386 | 57 | |
99a9952d | 58 | SCM_ASSERT (SCM_INUMP (sub_end), sub_end, SCM_ARG4, why); |
03bc4386 GH |
59 | upper = SCM_INUM (sub_end); |
60 | if (upper < SCM_INUM (sub_start) | |
61 | || upper > SCM_ROLENGTH (*str)) | |
62 | scm_out_of_range (why, sub_end); | |
63 | ||
64 | if (direction > 0) | |
65 | { | |
66 | p = (unsigned char *)SCM_ROCHARS (*str) + lower; | |
67 | ch = SCM_ICHR (chr); | |
68 | ||
69 | for (x = SCM_INUM (sub_start); x < upper; ++x, ++p) | |
70 | if (*p == ch) | |
71 | return x; | |
72 | } | |
0f2d19dd | 73 | else |
03bc4386 GH |
74 | { |
75 | p = upper - 1 + (unsigned char *)SCM_ROCHARS (*str); | |
76 | ch = SCM_ICHR (chr); | |
77 | for (x = upper - 1; x >= lower; --x, --p) | |
78 | if (*p == ch) | |
79 | return x; | |
80 | } | |
0f2d19dd JB |
81 | |
82 | return -1; | |
83 | } | |
84 | ||
0f2d19dd | 85 | SCM_PROC(s_string_index, "string-index", 2, 2, 0, scm_string_index); |
1cc91f1b | 86 | |
0f2d19dd | 87 | SCM |
99a9952d | 88 | scm_string_index (SCM str, SCM chr, SCM frm, SCM to) |
0f2d19dd JB |
89 | { |
90 | int pos; | |
91 | ||
92 | if (frm == SCM_UNDEFINED) | |
93 | frm = SCM_BOOL_F; | |
94 | if (to == SCM_UNDEFINED) | |
95 | to = SCM_BOOL_F; | |
99a9952d | 96 | pos = scm_i_index (&str, chr, 1, frm, to, s_string_index); |
0f2d19dd JB |
97 | return (pos < 0 |
98 | ? SCM_BOOL_F | |
99 | : SCM_MAKINUM (pos)); | |
100 | } | |
101 | ||
102 | SCM_PROC(s_string_rindex, "string-rindex", 2, 2, 0, scm_string_rindex); | |
1cc91f1b | 103 | |
0f2d19dd | 104 | SCM |
99a9952d | 105 | scm_string_rindex (SCM str, SCM chr, SCM frm, SCM to) |
0f2d19dd JB |
106 | { |
107 | int pos; | |
108 | ||
109 | if (frm == SCM_UNDEFINED) | |
110 | frm = SCM_BOOL_F; | |
111 | if (to == SCM_UNDEFINED) | |
112 | to = SCM_BOOL_F; | |
99a9952d | 113 | pos = scm_i_index (&str, chr, -1, frm, to, s_string_rindex); |
0f2d19dd JB |
114 | return (pos < 0 |
115 | ? SCM_BOOL_F | |
116 | : SCM_MAKINUM (pos)); | |
117 | } | |
e41530ba | 118 | |
e41530ba | 119 | |
b1349e46 JB |
120 | SCM_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x); |
121 | SCM_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x); | |
122 | SCM_PROC(s_substring_move_x, "substring-move!", 5, 0, 0, scm_substring_move_x); | |
1cc91f1b | 123 | |
0f2d19dd | 124 | SCM |
b1349e46 JB |
125 | scm_substring_move_x (SCM str1, SCM start1, SCM end1, |
126 | SCM str2, SCM start2) | |
99a9952d | 127 | |
0f2d19dd | 128 | { |
99a9952d JB |
129 | long s1, s2, e, len; |
130 | ||
131 | SCM_ASSERT (SCM_NIMP (str1) && SCM_STRINGP (str1), str1, | |
b1349e46 JB |
132 | SCM_ARG1, s_substring_move_x); |
133 | SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_substring_move_x); | |
134 | SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_substring_move_x); | |
99a9952d | 135 | SCM_ASSERT (SCM_NIMP (str2) && SCM_STRINGP (str2), str2, |
b1349e46 JB |
136 | SCM_ARG4, s_substring_move_x); |
137 | SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_substring_move_x); | |
99a9952d JB |
138 | |
139 | s1 = SCM_INUM (start1), s2 = SCM_INUM (start2), e = SCM_INUM (end1); | |
140 | len = e - s1; | |
141 | SCM_ASSERT (s1 <= SCM_LENGTH (str1) && s1 >= 0, start1, | |
b1349e46 | 142 | SCM_OUTOFRANGE, s_substring_move_x); |
99a9952d | 143 | SCM_ASSERT (s2 <= SCM_LENGTH (str2) && s2 >= 0, start2, |
b1349e46 | 144 | SCM_OUTOFRANGE, s_substring_move_x); |
99a9952d | 145 | SCM_ASSERT (e <= SCM_LENGTH (str1) && e >= 0, end1, |
b1349e46 | 146 | SCM_OUTOFRANGE, s_substring_move_x); |
99a9952d | 147 | SCM_ASSERT (len+s2 <= SCM_LENGTH (str2), start2, |
b1349e46 | 148 | SCM_OUTOFRANGE, s_substring_move_x); |
0f2d19dd | 149 | |
99a9952d JB |
150 | SCM_SYSCALL(memmove((void *)(&(SCM_CHARS(str2)[s2])), |
151 | (void *)(&(SCM_CHARS(str1)[s1])), | |
152 | len)); | |
153 | ||
b1349e46 | 154 | return scm_return_first(SCM_UNSPECIFIED, str1, str2); |
0f2d19dd JB |
155 | } |
156 | ||
157 | ||
99a9952d | 158 | SCM_PROC(s_substring_fill_x, "substring-fill!", 4, 0, 0, scm_substring_fill_x); |
1cc91f1b | 159 | |
0f2d19dd | 160 | SCM |
99a9952d JB |
161 | scm_substring_fill_x (SCM str, SCM start, SCM end, SCM fill) |
162 | ||
0f2d19dd | 163 | { |
0f2d19dd JB |
164 | long i, e; |
165 | char c; | |
0f2d19dd JB |
166 | SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_substring_fill_x); |
167 | SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_substring_fill_x); | |
168 | SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_substring_fill_x); | |
169 | SCM_ASSERT (SCM_ICHRP (fill), fill, SCM_ARG4, s_substring_fill_x); | |
170 | i = SCM_INUM (start), e = SCM_INUM (end);c = SCM_ICHR (fill); | |
99a9952d JB |
171 | SCM_ASSERT (i <= SCM_LENGTH (str) && i >= 0, start, |
172 | SCM_OUTOFRANGE, s_substring_fill_x); | |
173 | SCM_ASSERT (e <= SCM_LENGTH (str) && e >= 0, end, | |
174 | SCM_OUTOFRANGE, s_substring_fill_x); | |
0f2d19dd JB |
175 | while (i<e) SCM_CHARS (str)[i++] = c; |
176 | return SCM_UNSPECIFIED; | |
177 | } | |
178 | ||
179 | ||
180 | SCM_PROC(s_string_null_p, "string-null?", 1, 0, 0, scm_string_null_p); | |
1cc91f1b | 181 | |
0f2d19dd JB |
182 | SCM |
183 | scm_string_null_p (str) | |
184 | SCM str; | |
0f2d19dd JB |
185 | { |
186 | SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_null_p); | |
187 | return (SCM_ROLENGTH (str) | |
188 | ? SCM_BOOL_F | |
189 | : SCM_BOOL_T); | |
190 | } | |
191 | ||
192 | ||
193 | SCM_PROC(s_string_to_list, "string->list", 1, 0, 0, scm_string_to_list); | |
1cc91f1b | 194 | |
0f2d19dd JB |
195 | SCM |
196 | scm_string_to_list (str) | |
197 | SCM str; | |
0f2d19dd JB |
198 | { |
199 | long i; | |
200 | SCM res = SCM_EOL; | |
201 | unsigned char *src; | |
202 | SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_to_list); | |
203 | src = SCM_ROUCHARS (str); | |
204 | for (i = SCM_ROLENGTH (str)-1;i >= 0;i--) res = scm_cons ((SCM)SCM_MAKICHR (src[i]), res); | |
205 | return res; | |
206 | } | |
207 | ||
208 | ||
209 | ||
210 | SCM_PROC(s_string_copy, "string-copy", 1, 0, 0, scm_string_copy); | |
1cc91f1b | 211 | |
0f2d19dd JB |
212 | SCM |
213 | scm_string_copy (str) | |
214 | SCM str; | |
0f2d19dd | 215 | { |
3d8d56df GH |
216 | SCM_ASSERT (SCM_NIMP (str) && (SCM_STRINGP (str) || SCM_SUBSTRP (str)), |
217 | str, SCM_ARG1, s_string_copy); | |
218 | return scm_makfromstr (SCM_ROCHARS (str), (scm_sizet)SCM_ROLENGTH (str), 0); | |
0f2d19dd JB |
219 | } |
220 | ||
221 | ||
222 | SCM_PROC(s_string_fill_x, "string-fill!", 2, 0, 0, scm_string_fill_x); | |
1cc91f1b | 223 | |
0f2d19dd JB |
224 | SCM |
225 | scm_string_fill_x (str, chr) | |
226 | SCM str; | |
227 | SCM chr; | |
0f2d19dd JB |
228 | { |
229 | register char *dst, c; | |
230 | register long k; | |
231 | SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_fill_x); | |
232 | SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, s_string_fill_x); | |
233 | c = SCM_ICHR (chr); | |
234 | dst = SCM_CHARS (str); | |
235 | for (k = SCM_LENGTH (str)-1;k >= 0;k--) dst[k] = c; | |
236 | return SCM_UNSPECIFIED; | |
237 | } | |
238 | ||
c101e39e GH |
239 | SCM_PROC(s_string_upcase_x, "string-upcase!", 1, 0, 0, scm_string_upcase_x); |
240 | ||
241 | SCM | |
242 | scm_string_upcase_x (v) | |
243 | SCM v; | |
244 | { | |
245 | register long k; | |
246 | register unsigned char *cs; | |
247 | SCM_ASRTGO (SCM_NIMP (v), badarg1); | |
248 | k = SCM_LENGTH (v); | |
249 | switch SCM_TYP7 | |
250 | (v) | |
251 | { | |
252 | case scm_tc7_string: | |
253 | cs = SCM_UCHARS (v); | |
254 | while (k--) | |
255 | cs[k] = scm_upcase(cs[k]); | |
256 | break; | |
257 | default: | |
258 | badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_upcase_x); | |
259 | } | |
260 | return v; | |
261 | } | |
262 | ||
99a9952d JB |
263 | SCM_PROC(s_string_upcase, "string-upcase", 1, 0, 0, scm_string_upcase); |
264 | ||
265 | SCM | |
266 | scm_string_upcase(SCM str) | |
267 | { | |
268 | return scm_string_upcase_x(scm_string_copy(str)); | |
269 | } | |
270 | ||
c101e39e GH |
271 | SCM_PROC(s_string_downcase_x, "string-downcase!", 1, 0, 0, scm_string_downcase_x); |
272 | ||
273 | SCM | |
274 | scm_string_downcase_x (v) | |
275 | SCM v; | |
276 | { | |
277 | register long k; | |
278 | register unsigned char *cs; | |
279 | SCM_ASRTGO (SCM_NIMP (v), badarg1); | |
280 | k = SCM_LENGTH (v); | |
99a9952d | 281 | switch (SCM_TYP7(v)) |
c101e39e | 282 | { |
99a9952d JB |
283 | case scm_tc7_string: |
284 | cs = SCM_UCHARS (v); | |
285 | while (k--) | |
286 | cs[k] = scm_downcase(cs[k]); | |
287 | break; | |
288 | default: | |
c101e39e GH |
289 | badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_downcase_x); |
290 | } | |
291 | return v; | |
292 | } | |
0f2d19dd | 293 | |
99a9952d JB |
294 | SCM_PROC(s_string_downcase, "string-downcase", 1, 0, 0, scm_string_downcase); |
295 | ||
296 | SCM | |
297 | scm_string_downcase(SCM str) | |
298 | { | |
299 | SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, SCM_ARG1, s_string_downcase); | |
300 | return scm_string_downcase_x(scm_string_copy(str)); | |
301 | } | |
302 | ||
303 | SCM_PROC(s_string_capitalize_x, "string-capitalize!", 1, 0, 0, scm_string_capitalize_x); | |
304 | ||
305 | SCM | |
306 | scm_string_capitalize_x (SCM s) | |
307 | { | |
308 | char *str; | |
309 | int i, len, in_word=0; | |
b1349e46 | 310 | SCM_ASSERT(SCM_NIMP(s) && SCM_STRINGP(s), s, SCM_ARG1, s_string_capitalize_x); |
99a9952d JB |
311 | len = SCM_LENGTH(s); |
312 | str = SCM_CHARS(s); | |
313 | for(i=0; i<len; i++) { | |
314 | if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKICHR(str[i])))) { | |
315 | if(!in_word) { | |
316 | str[i] = scm_upcase(str[i]); | |
317 | in_word = 1; | |
318 | } else { | |
319 | str[i] = scm_downcase(str[i]); | |
320 | } | |
321 | } | |
322 | else in_word = 0; | |
323 | } | |
324 | return s; | |
325 | } | |
326 | ||
327 | SCM_PROC(s_string_capitalize, "string-capitalize", 1, 0, 0, scm_string_capitalize); | |
328 | ||
329 | SCM | |
330 | scm_string_capitalize(SCM s) | |
331 | { | |
332 | SCM_ASSERT((SCM_NIMP(s)) && (SCM_STRINGP(s)), s, SCM_ARG1, s_string_capitalize); | |
333 | return scm_string_capitalize_x(scm_string_copy(s)); | |
334 | } | |
335 | ||
336 | SCM_PROC(s_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, scm_string_ci_to_symbol); | |
337 | ||
338 | SCM | |
339 | scm_string_ci_to_symbol(SCM str) | |
340 | { | |
341 | return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P | |
342 | ? scm_string_downcase(str) | |
343 | : str); | |
344 | } | |
1cc91f1b | 345 | |
0f2d19dd JB |
346 | void |
347 | scm_init_strop () | |
0f2d19dd JB |
348 | { |
349 | #include "strop.x" | |
350 | } | |
351 |