Commit | Line | Data |
---|---|---|
0f2d19dd JB |
1 | /* classes: src_files */ |
2 | ||
5b20cc4b | 3 | /* Copyright (C) 1994, 1996, 1997, 1999 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 | 19 | |
1bbd0b84 GB |
20 | /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, |
21 | gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ | |
22 | ||
23 | ||
0f2d19dd JB |
24 | \f |
25 | ||
26 | #include <stdio.h> | |
27 | #include "_scm.h" | |
20e6290e | 28 | #include "chars.h" |
0f2d19dd | 29 | |
1bbd0b84 | 30 | #include "scm_validate.h" |
20e6290e | 31 | #include "strop.h" |
99a9952d | 32 | #include "read.h" /*For SCM_CASE_INSENSITIVE_P*/ |
0f2d19dd JB |
33 | \f |
34 | ||
1cc91f1b | 35 | |
03bc4386 GH |
36 | /* implements index if direction > 0 otherwise rindex. */ |
37 | static int | |
99a9952d JB |
38 | scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, |
39 | SCM sub_end, const char *why) | |
0f2d19dd JB |
40 | { |
41 | unsigned char * p; | |
42 | int x; | |
03bc4386 GH |
43 | int lower; |
44 | int upper; | |
0f2d19dd JB |
45 | int ch; |
46 | ||
0c95b57d | 47 | SCM_ASSERT (SCM_ROSTRINGP (*str), *str, SCM_ARG1, why); |
99a9952d | 48 | SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, why); |
0f2d19dd JB |
49 | |
50 | if (sub_start == SCM_BOOL_F) | |
51 | sub_start = SCM_MAKINUM (0); | |
03bc4386 | 52 | |
99a9952d | 53 | SCM_ASSERT (SCM_INUMP (sub_start), sub_start, SCM_ARG3, why); |
03bc4386 GH |
54 | lower = SCM_INUM (sub_start); |
55 | if (lower < 0 | |
67ec3667 | 56 | || lower > SCM_ROLENGTH (*str)) |
03bc4386 | 57 | scm_out_of_range (why, sub_start); |
0f2d19dd JB |
58 | |
59 | if (sub_end == SCM_BOOL_F) | |
60 | sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str)); | |
03bc4386 | 61 | |
99a9952d | 62 | SCM_ASSERT (SCM_INUMP (sub_end), sub_end, SCM_ARG4, why); |
03bc4386 GH |
63 | upper = SCM_INUM (sub_end); |
64 | if (upper < SCM_INUM (sub_start) | |
65 | || upper > SCM_ROLENGTH (*str)) | |
66 | scm_out_of_range (why, sub_end); | |
67 | ||
68 | if (direction > 0) | |
69 | { | |
70 | p = (unsigned char *)SCM_ROCHARS (*str) + lower; | |
71 | ch = SCM_ICHR (chr); | |
72 | ||
73 | for (x = SCM_INUM (sub_start); x < upper; ++x, ++p) | |
74 | if (*p == ch) | |
75 | return x; | |
76 | } | |
0f2d19dd | 77 | else |
03bc4386 GH |
78 | { |
79 | p = upper - 1 + (unsigned char *)SCM_ROCHARS (*str); | |
80 | ch = SCM_ICHR (chr); | |
81 | for (x = upper - 1; x >= lower; --x, --p) | |
82 | if (*p == ch) | |
83 | return x; | |
84 | } | |
0f2d19dd JB |
85 | |
86 | return -1; | |
87 | } | |
88 | ||
1bbd0b84 GB |
89 | GUILE_PROC(scm_string_index, "string-index", 2, 2, 0, |
90 | (SCM str, SCM chr, SCM frm, SCM to), | |
4079f87e GB |
91 | "Return the index of the first occurrence of @var{chr} in @var{str}. The |
92 | optional integer arguments @var{frm} and @var{to} limit the search to | |
93 | a portion of the string. This procedure essentially implements the | |
94 | @code{index} or @code{strchr} functions from the C library.") | |
1bbd0b84 | 95 | #define FUNC_NAME s_scm_string_index |
0f2d19dd JB |
96 | { |
97 | int pos; | |
98 | ||
99 | if (frm == SCM_UNDEFINED) | |
100 | frm = SCM_BOOL_F; | |
101 | if (to == SCM_UNDEFINED) | |
102 | to = SCM_BOOL_F; | |
1bbd0b84 | 103 | pos = scm_i_index (&str, chr, 1, frm, to, FUNC_NAME); |
0f2d19dd JB |
104 | return (pos < 0 |
105 | ? SCM_BOOL_F | |
106 | : SCM_MAKINUM (pos)); | |
107 | } | |
1bbd0b84 | 108 | #undef FUNC_NAME |
0f2d19dd | 109 | |
1bbd0b84 GB |
110 | GUILE_PROC(scm_string_rindex, "string-rindex", 2, 2, 0, |
111 | (SCM str, SCM chr, SCM frm, SCM to), | |
4079f87e GB |
112 | "Like @code{string-index}, but search from the right of the string rather |
113 | than from the left. This procedure essentially implements the | |
114 | @code{rindex} or @code{strrchr} functions from the C library.") | |
1bbd0b84 | 115 | #define FUNC_NAME s_scm_string_rindex |
0f2d19dd JB |
116 | { |
117 | int pos; | |
118 | ||
119 | if (frm == SCM_UNDEFINED) | |
120 | frm = SCM_BOOL_F; | |
121 | if (to == SCM_UNDEFINED) | |
122 | to = SCM_BOOL_F; | |
1bbd0b84 | 123 | pos = scm_i_index (&str, chr, -1, frm, to, FUNC_NAME); |
0f2d19dd JB |
124 | return (pos < 0 |
125 | ? SCM_BOOL_F | |
126 | : SCM_MAKINUM (pos)); | |
127 | } | |
1bbd0b84 GB |
128 | #undef FUNC_NAME |
129 | ||
e41530ba | 130 | |
1bbd0b84 GB |
131 | SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x); |
132 | SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x); | |
e41530ba | 133 | |
1cc91f1b | 134 | |
1bbd0b84 GB |
135 | GUILE_PROC(scm_substring_move_x, "substring-move!", 5, 0, 0, |
136 | (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2), | |
4079f87e GB |
137 | "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1} |
138 | into @var{str2} beginning at position @var{end2}. | |
139 | @code{substring-move-right!} begins copying from the rightmost character | |
140 | and moves left, and @code{substring-move-left!} copies from the leftmost | |
141 | character moving right. | |
142 | ||
143 | It is useful to have two functions that copy in different directions so | |
144 | that substrings can be copied back and forth within a single string. If | |
145 | you wish to copy text from the left-hand side of a string to the | |
146 | right-hand side of the same string, and the source and destination | |
147 | overlap, you must be careful to copy the rightmost characters of the | |
148 | text first, to avoid clobbering your data. Hence, when @var{str1} and | |
149 | @var{str2} are the same string, you should use | |
150 | @code{substring-move-right!} when moving text from left to right, and | |
151 | @code{substring-move-left!} otherwise. If @code{str1} and @samp{str2} | |
152 | are different strings, it does not matter which function you use.") | |
1bbd0b84 | 153 | #define FUNC_NAME s_scm_substring_move_x |
0f2d19dd | 154 | { |
99a9952d JB |
155 | long s1, s2, e, len; |
156 | ||
1bbd0b84 GB |
157 | SCM_VALIDATE_STRING(1,str1); |
158 | SCM_VALIDATE_INT_COPY(2,start1,s1); | |
159 | SCM_VALIDATE_INT_COPY(3,end1,e); | |
160 | SCM_VALIDATE_STRING(4,str2); | |
161 | SCM_VALIDATE_INT_COPY(5,start2,s2); | |
99a9952d | 162 | len = e - s1; |
1bbd0b84 GB |
163 | SCM_ASSERT_RANGE (3,end1,len >= 0); |
164 | SCM_ASSERT_RANGE (2,start1,s1 <= SCM_LENGTH (str1) && s1 >= 0); | |
165 | SCM_ASSERT_RANGE (5,start2,s2 <= SCM_LENGTH (str2) && s2 >= 0); | |
166 | SCM_ASSERT_RANGE (3,end1,e <= SCM_LENGTH (str1) && e >= 0); | |
167 | SCM_ASSERT_RANGE (5,start2,len+s2 <= SCM_LENGTH (str2)); | |
0f2d19dd | 168 | |
99a9952d JB |
169 | SCM_SYSCALL(memmove((void *)(&(SCM_CHARS(str2)[s2])), |
170 | (void *)(&(SCM_CHARS(str1)[s1])), | |
171 | len)); | |
172 | ||
b1349e46 | 173 | return scm_return_first(SCM_UNSPECIFIED, str1, str2); |
0f2d19dd | 174 | } |
1bbd0b84 | 175 | #undef FUNC_NAME |
0f2d19dd JB |
176 | |
177 | ||
1bbd0b84 GB |
178 | GUILE_PROC(scm_substring_fill_x, "substring-fill!", 4, 0, 0, |
179 | (SCM str, SCM start, SCM end, SCM fill), | |
4079f87e GB |
180 | "Change every character in @var{str} between @var{start} and @var{end} to |
181 | @var{fill-char}.") | |
1bbd0b84 | 182 | #define FUNC_NAME s_scm_substring_fill_x |
0f2d19dd | 183 | { |
0f2d19dd JB |
184 | long i, e; |
185 | char c; | |
1bbd0b84 GB |
186 | SCM_VALIDATE_STRING(1,str); |
187 | SCM_VALIDATE_INT_COPY(2,start,i); | |
188 | SCM_VALIDATE_INT_COPY(3,end,e); | |
189 | SCM_VALIDATE_CHAR_COPY(4,fill,c); | |
190 | SCM_ASSERT_RANGE (2,start,i <= SCM_LENGTH (str) && i >= 0); | |
191 | SCM_ASSERT_RANGE (3,end,e <= SCM_LENGTH (str) && e >= 0); | |
0f2d19dd JB |
192 | while (i<e) SCM_CHARS (str)[i++] = c; |
193 | return SCM_UNSPECIFIED; | |
194 | } | |
1bbd0b84 | 195 | #undef FUNC_NAME |
0f2d19dd JB |
196 | |
197 | ||
1bbd0b84 GB |
198 | GUILE_PROC(scm_string_null_p, "string-null?", 1, 0, 0, |
199 | (SCM str), | |
4079f87e GB |
200 | "Return @code{#t} if @var{str}'s length is nonzero, and @code{#f} |
201 | otherwise.") | |
1bbd0b84 | 202 | #define FUNC_NAME s_scm_string_null_p |
0f2d19dd | 203 | { |
1bbd0b84 GB |
204 | SCM_VALIDATE_ROSTRING(1,str); |
205 | return SCM_NEGATE_BOOL(SCM_ROLENGTH (str)); | |
0f2d19dd | 206 | } |
1bbd0b84 | 207 | #undef FUNC_NAME |
0f2d19dd JB |
208 | |
209 | ||
1bbd0b84 GB |
210 | GUILE_PROC(scm_string_to_list, "string->list", 1, 0, 0, |
211 | (SCM str), | |
212 | "") | |
213 | #define FUNC_NAME s_scm_string_to_list | |
0f2d19dd JB |
214 | { |
215 | long i; | |
216 | SCM res = SCM_EOL; | |
217 | unsigned char *src; | |
1bbd0b84 | 218 | SCM_VALIDATE_ROSTRING(1,str); |
0f2d19dd JB |
219 | src = SCM_ROUCHARS (str); |
220 | for (i = SCM_ROLENGTH (str)-1;i >= 0;i--) res = scm_cons ((SCM)SCM_MAKICHR (src[i]), res); | |
221 | return res; | |
222 | } | |
1bbd0b84 | 223 | #undef FUNC_NAME |
0f2d19dd JB |
224 | |
225 | ||
226 | ||
1bbd0b84 GB |
227 | GUILE_PROC(scm_string_copy, "string-copy", 1, 0, 0, |
228 | (SCM str), | |
229 | "") | |
230 | #define FUNC_NAME s_scm_string_copy | |
0f2d19dd | 231 | { |
1bbd0b84 | 232 | SCM_VALIDATE_STRINGORSUBSTR(1,str); |
3d8d56df | 233 | return scm_makfromstr (SCM_ROCHARS (str), (scm_sizet)SCM_ROLENGTH (str), 0); |
0f2d19dd | 234 | } |
1bbd0b84 | 235 | #undef FUNC_NAME |
0f2d19dd JB |
236 | |
237 | ||
1bbd0b84 GB |
238 | GUILE_PROC(scm_string_fill_x, "string-fill!", 2, 0, 0, |
239 | (SCM str, SCM chr), | |
240 | "") | |
241 | #define FUNC_NAME s_scm_string_fill_x | |
0f2d19dd JB |
242 | { |
243 | register char *dst, c; | |
244 | register long k; | |
1bbd0b84 GB |
245 | SCM_VALIDATE_STRING_COPY(1,str,dst); |
246 | SCM_VALIDATE_CHAR_COPY(2,chr,c); | |
0f2d19dd JB |
247 | for (k = SCM_LENGTH (str)-1;k >= 0;k--) dst[k] = c; |
248 | return SCM_UNSPECIFIED; | |
249 | } | |
1bbd0b84 | 250 | #undef FUNC_NAME |
0f2d19dd | 251 | |
1bbd0b84 GB |
252 | GUILE_PROC(scm_string_upcase_x, "string-upcase!", 1, 0, 0, |
253 | (SCM v), | |
4079f87e GB |
254 | "@deffnx primitive string-downcase! str |
255 | Upcase or downcase every character in @code{str}, respectively.") | |
1bbd0b84 | 256 | #define FUNC_NAME s_scm_string_upcase_x |
c101e39e GH |
257 | { |
258 | register long k; | |
259 | register unsigned char *cs; | |
260 | SCM_ASRTGO (SCM_NIMP (v), badarg1); | |
261 | k = SCM_LENGTH (v); | |
262 | switch SCM_TYP7 | |
263 | (v) | |
264 | { | |
265 | case scm_tc7_string: | |
266 | cs = SCM_UCHARS (v); | |
267 | while (k--) | |
268 | cs[k] = scm_upcase(cs[k]); | |
269 | break; | |
270 | default: | |
1bbd0b84 | 271 | badarg1:SCM_WTA (1,v); |
c101e39e GH |
272 | } |
273 | return v; | |
274 | } | |
1bbd0b84 | 275 | #undef FUNC_NAME |
c101e39e | 276 | |
1bbd0b84 GB |
277 | GUILE_PROC(scm_string_upcase, "string-upcase", 1, 0, 0, |
278 | (SCM str), | |
279 | "") | |
280 | #define FUNC_NAME s_scm_string_upcase | |
99a9952d JB |
281 | { |
282 | return scm_string_upcase_x(scm_string_copy(str)); | |
283 | } | |
1bbd0b84 | 284 | #undef FUNC_NAME |
99a9952d | 285 | |
1bbd0b84 GB |
286 | GUILE_PROC(scm_string_downcase_x, "string-downcase!", 1, 0, 0, |
287 | (SCM v), | |
288 | "") | |
289 | #define FUNC_NAME s_scm_string_downcase_x | |
c101e39e GH |
290 | { |
291 | register long k; | |
292 | register unsigned char *cs; | |
293 | SCM_ASRTGO (SCM_NIMP (v), badarg1); | |
294 | k = SCM_LENGTH (v); | |
99a9952d | 295 | switch (SCM_TYP7(v)) |
c101e39e | 296 | { |
99a9952d JB |
297 | case scm_tc7_string: |
298 | cs = SCM_UCHARS (v); | |
299 | while (k--) | |
300 | cs[k] = scm_downcase(cs[k]); | |
301 | break; | |
302 | default: | |
1bbd0b84 | 303 | badarg1:SCM_WTA (1,v); |
c101e39e GH |
304 | } |
305 | return v; | |
306 | } | |
1bbd0b84 | 307 | #undef FUNC_NAME |
0f2d19dd | 308 | |
1bbd0b84 GB |
309 | GUILE_PROC(scm_string_downcase, "string-downcase", 1, 0, 0, |
310 | (SCM str), | |
311 | "") | |
312 | #define FUNC_NAME s_scm_string_downcase | |
99a9952d | 313 | { |
1bbd0b84 | 314 | SCM_VALIDATE_STRING(1,str); |
99a9952d JB |
315 | return scm_string_downcase_x(scm_string_copy(str)); |
316 | } | |
1bbd0b84 | 317 | #undef FUNC_NAME |
99a9952d | 318 | |
1bbd0b84 GB |
319 | GUILE_PROC(scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, |
320 | (SCM s), | |
321 | "") | |
322 | #define FUNC_NAME s_scm_string_capitalize_x | |
99a9952d JB |
323 | { |
324 | char *str; | |
325 | int i, len, in_word=0; | |
1bbd0b84 | 326 | SCM_VALIDATE_STRING(1,s); |
99a9952d JB |
327 | len = SCM_LENGTH(s); |
328 | str = SCM_CHARS(s); | |
329 | for(i=0; i<len; i++) { | |
330 | if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKICHR(str[i])))) { | |
331 | if(!in_word) { | |
332 | str[i] = scm_upcase(str[i]); | |
333 | in_word = 1; | |
334 | } else { | |
335 | str[i] = scm_downcase(str[i]); | |
336 | } | |
337 | } | |
338 | else in_word = 0; | |
339 | } | |
340 | return s; | |
341 | } | |
1bbd0b84 | 342 | #undef FUNC_NAME |
99a9952d | 343 | |
1bbd0b84 GB |
344 | GUILE_PROC(scm_string_capitalize, "string-capitalize", 1, 0, 0, |
345 | (SCM s), | |
346 | "") | |
347 | #define FUNC_NAME s_scm_string_capitalize | |
99a9952d | 348 | { |
1bbd0b84 | 349 | SCM_VALIDATE_STRING(1,s); |
99a9952d JB |
350 | return scm_string_capitalize_x(scm_string_copy(s)); |
351 | } | |
1bbd0b84 | 352 | #undef FUNC_NAME |
99a9952d | 353 | |
1bbd0b84 GB |
354 | GUILE_PROC(scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, |
355 | (SCM str), | |
356 | "") | |
357 | #define FUNC_NAME s_scm_string_ci_to_symbol | |
99a9952d JB |
358 | { |
359 | return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P | |
360 | ? scm_string_downcase(str) | |
361 | : str); | |
362 | } | |
1bbd0b84 | 363 | #undef FUNC_NAME |
1cc91f1b | 364 | |
0f2d19dd JB |
365 | void |
366 | scm_init_strop () | |
0f2d19dd JB |
367 | { |
368 | #include "strop.x" | |
369 | } |