Commit | Line | Data |
---|---|---|
0f2d19dd JB |
1 | /* classes: src_files */ |
2 | ||
e6e2e95a | 3 | /* Copyright (C) 1994, 1996, 1997, 1999, 2000, 2001 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 | ||
e6e2e95a MD |
26 | #include <errno.h> |
27 | ||
a0599745 MD |
28 | #include "libguile/_scm.h" |
29 | #include "libguile/chars.h" | |
30 | #include "libguile/strings.h" | |
0f2d19dd | 31 | |
a0599745 MD |
32 | #include "libguile/validate.h" |
33 | #include "libguile/strop.h" | |
34 | #include "libguile/read.h" /*For SCM_CASE_INSENSITIVE_P*/ | |
bd9e24b3 GH |
35 | |
36 | #ifdef HAVE_STRING_H | |
37 | #include <string.h> | |
38 | #endif | |
39 | ||
0f2d19dd JB |
40 | \f |
41 | ||
6552dbf7 | 42 | /* |
5ad8ab0a | 43 | xSCM_DEFINE (scm_i_index, "i-index", 2, 2, 0, |
6552dbf7 GB |
44 | (SCM str, SCM chr, SCM frm, SCM to), |
45 | "@deftypefn {Internal C Function} {static int} scm_i_index (SCM *@var{str}, \n" | |
46 | "SCM @var{chr}, int @var{direction}, SCM @var{sub_start}, SCM @var{sub_end}, char *@var{why}) | |
47 | "This is a workhorse function that performs either an @code{index} or\n" | |
2b7b76d5 | 48 | "@code{rindex} function, depending on the value of @var{direction}." |
6552dbf7 | 49 | */ |
03bc4386 | 50 | /* implements index if direction > 0 otherwise rindex. */ |
c014a02e | 51 | static long |
5ad8ab0a | 52 | scm_i_index (SCM *str, SCM chr, int direction, SCM sub_start, |
99a9952d | 53 | SCM sub_end, const char *why) |
0f2d19dd JB |
54 | { |
55 | unsigned char * p; | |
c014a02e ML |
56 | long x; |
57 | long lower; | |
58 | long upper; | |
0f2d19dd JB |
59 | int ch; |
60 | ||
a6d9e5ab | 61 | SCM_ASSERT (SCM_STRINGP (*str), *str, SCM_ARG1, why); |
7866a09b | 62 | SCM_ASSERT (SCM_CHARP (chr), chr, SCM_ARG2, why); |
0f2d19dd | 63 | |
54778cd3 | 64 | if (SCM_FALSEP (sub_start)) |
0f2d19dd | 65 | sub_start = SCM_MAKINUM (0); |
03bc4386 | 66 | |
99a9952d | 67 | SCM_ASSERT (SCM_INUMP (sub_start), sub_start, SCM_ARG3, why); |
03bc4386 | 68 | lower = SCM_INUM (sub_start); |
a6d9e5ab | 69 | if (lower < 0 || lower > SCM_STRING_LENGTH (*str)) |
03bc4386 | 70 | scm_out_of_range (why, sub_start); |
0f2d19dd | 71 | |
54778cd3 | 72 | if (SCM_FALSEP (sub_end)) |
a6d9e5ab | 73 | sub_end = SCM_MAKINUM (SCM_STRING_LENGTH (*str)); |
03bc4386 | 74 | |
99a9952d | 75 | SCM_ASSERT (SCM_INUMP (sub_end), sub_end, SCM_ARG4, why); |
03bc4386 | 76 | upper = SCM_INUM (sub_end); |
a6d9e5ab | 77 | if (upper < SCM_INUM (sub_start) || upper > SCM_STRING_LENGTH (*str)) |
03bc4386 GH |
78 | scm_out_of_range (why, sub_end); |
79 | ||
80 | if (direction > 0) | |
81 | { | |
34f0f2b8 | 82 | p = SCM_STRING_UCHARS (*str) + lower; |
7866a09b | 83 | ch = SCM_CHAR (chr); |
03bc4386 GH |
84 | |
85 | for (x = SCM_INUM (sub_start); x < upper; ++x, ++p) | |
86 | if (*p == ch) | |
87 | return x; | |
88 | } | |
0f2d19dd | 89 | else |
03bc4386 | 90 | { |
34f0f2b8 | 91 | p = upper - 1 + SCM_STRING_UCHARS (*str); |
7866a09b | 92 | ch = SCM_CHAR (chr); |
03bc4386 GH |
93 | for (x = upper - 1; x >= lower; --x, --p) |
94 | if (*p == ch) | |
95 | return x; | |
96 | } | |
0f2d19dd JB |
97 | |
98 | return -1; | |
99 | } | |
100 | ||
5ad8ab0a | 101 | SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, |
1bbd0b84 | 102 | (SCM str, SCM chr, SCM frm, SCM to), |
5352393c MG |
103 | "Return the index of the first occurrence of @var{chr} in\n" |
104 | "@var{str}. The optional integer arguments @var{frm} and\n" | |
105 | "@var{to} limit the search to a portion of the string. This\n" | |
106 | "procedure essentially implements the @code{index} or\n" | |
1e6808ea MG |
107 | "@code{strchr} functions from the C library.\n" |
108 | "\n" | |
109 | "@lisp\n" | |
1670bef9 | 110 | "(string-index \"weiner\" #\\e)\n" |
6552dbf7 | 111 | "@result{} 1\n\n" |
1670bef9 | 112 | "(string-index \"weiner\" #\\e 2)\n" |
6552dbf7 | 113 | "@result{} 4\n\n" |
1670bef9 | 114 | "(string-index \"weiner\" #\\e 2 4)\n" |
6552dbf7 | 115 | "@result{} #f\n" |
1e6808ea | 116 | "@end lisp") |
1bbd0b84 | 117 | #define FUNC_NAME s_scm_string_index |
0f2d19dd | 118 | { |
c014a02e | 119 | long pos; |
5ad8ab0a | 120 | |
54778cd3 | 121 | if (SCM_UNBNDP (frm)) |
0f2d19dd | 122 | frm = SCM_BOOL_F; |
54778cd3 | 123 | if (SCM_UNBNDP (to)) |
0f2d19dd | 124 | to = SCM_BOOL_F; |
1bbd0b84 | 125 | pos = scm_i_index (&str, chr, 1, frm, to, FUNC_NAME); |
0f2d19dd JB |
126 | return (pos < 0 |
127 | ? SCM_BOOL_F | |
128 | : SCM_MAKINUM (pos)); | |
129 | } | |
1bbd0b84 | 130 | #undef FUNC_NAME |
0f2d19dd | 131 | |
5ad8ab0a | 132 | SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0, |
1bbd0b84 | 133 | (SCM str, SCM chr, SCM frm, SCM to), |
1e6808ea MG |
134 | "Like @code{string-index}, but search from the right of the\n" |
135 | "string rather than from the left. This procedure essentially\n" | |
136 | "implements the @code{rindex} or @code{strrchr} functions from\n" | |
137 | "the C library.\n" | |
138 | "\n" | |
139 | "@lisp\n" | |
1670bef9 | 140 | "(string-rindex \"weiner\" #\\e)\n" |
6552dbf7 | 141 | "@result{} 4\n\n" |
1670bef9 | 142 | "(string-rindex \"weiner\" #\\e 2 4)\n" |
6552dbf7 | 143 | "@result{} #f\n\n" |
1670bef9 | 144 | "(string-rindex \"weiner\" #\\e 2 5)\n" |
6552dbf7 | 145 | "@result{} 4\n" |
1e6808ea | 146 | "@end lisp") |
1bbd0b84 | 147 | #define FUNC_NAME s_scm_string_rindex |
0f2d19dd | 148 | { |
c014a02e | 149 | long pos; |
5ad8ab0a | 150 | |
54778cd3 | 151 | if (SCM_UNBNDP (frm)) |
0f2d19dd | 152 | frm = SCM_BOOL_F; |
54778cd3 | 153 | if (SCM_UNBNDP (to)) |
0f2d19dd | 154 | to = SCM_BOOL_F; |
1bbd0b84 | 155 | pos = scm_i_index (&str, chr, -1, frm, to, FUNC_NAME); |
0f2d19dd JB |
156 | return (pos < 0 |
157 | ? SCM_BOOL_F | |
158 | : SCM_MAKINUM (pos)); | |
159 | } | |
1bbd0b84 GB |
160 | #undef FUNC_NAME |
161 | ||
e41530ba | 162 | |
1bbd0b84 GB |
163 | SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x); |
164 | SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x); | |
e41530ba | 165 | |
6552dbf7 GB |
166 | /* |
167 | @defun substring-move-left! str1 start1 end1 str2 start2 | |
168 | @end defun | |
169 | @deftypefn {C Function} SCM scm_substring_move_left_x (SCM @var{str1}, SCM @var{start1}, SCM @var{end1}, SCM @var{str2}, SCM @var{start2}) | |
170 | [@strong{Note:} this is only valid if you've applied the strop patch]. | |
171 | ||
172 | Moves a substring of @var{str1}, from @var{start1} to @var{end1} | |
173 | (@var{end1} is exclusive), into @var{str2}, starting at | |
174 | @var{start2}. Allows overlapping strings. | |
175 | ||
1e6808ea | 176 | @lisp |
6552dbf7 GB |
177 | (define x (make-string 10 #\a)) |
178 | (define y "bcd") | |
179 | (substring-move-left! x 2 5 y 0) | |
180 | y | |
181 | @result{} "aaa" | |
182 | ||
183 | x | |
184 | @result{} "aaaaaaaaaa" | |
185 | ||
186 | (define y "bcdefg") | |
187 | (substring-move-left! x 2 5 y 0) | |
188 | y | |
189 | @result{} "aaaefg" | |
190 | ||
191 | (define y "abcdefg") | |
192 | (substring-move-left! y 2 5 y 3) | |
193 | y | |
194 | @result{} "abccccg" | |
1e6808ea | 195 | @end lisp |
6552dbf7 GB |
196 | */ |
197 | ||
198 | /* | |
199 | @defun substring-move-right! str1 start1 end1 str2 start2 | |
200 | @end defun | |
201 | @deftypefn {C Function} SCM scm_substring_move_right_x (SCM @var{str1}, SCM @var{start1}, SCM @var{end1}, SCM @var{str2}, SCM @var{start2}) | |
202 | [@strong{Note:} this is only valid if you've applied the strop patch, if | |
203 | it hasn't made it into the guile tree]. | |
204 | ||
205 | Does much the same thing as @code{substring-move-left!}, except it | |
206 | starts moving at the end of the sequence, rather than the beginning. | |
1e6808ea | 207 | @lisp |
6552dbf7 GB |
208 | (define y "abcdefg") |
209 | (substring-move-right! y 2 5 y 0) | |
210 | y | |
211 | @result{} "ededefg" | |
212 | ||
213 | (define y "abcdefg") | |
214 | (substring-move-right! y 2 5 y 3) | |
215 | y | |
216 | @result{} "abccdeg" | |
1e6808ea | 217 | @end lisp |
5ad8ab0a | 218 | */ |
1cc91f1b | 219 | |
5ad8ab0a | 220 | SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, |
1bbd0b84 | 221 | (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2), |
11768c04 NJ |
222 | "@deffnx primitive substring-move-left! str1 start1 end1 str2 start2\n" |
223 | "@deffnx primitive substring-move-right! str1 start1 end1 str2 start2\n" | |
b380b885 | 224 | "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n" |
5ad8ab0a | 225 | "into @var{str2} beginning at position @var{start2}.\n" |
b380b885 MD |
226 | "@code{substring-move-right!} begins copying from the rightmost character\n" |
227 | "and moves left, and @code{substring-move-left!} copies from the leftmost\n" | |
228 | "character moving right.\n\n" | |
229 | "It is useful to have two functions that copy in different directions so\n" | |
230 | "that substrings can be copied back and forth within a single string. If\n" | |
231 | "you wish to copy text from the left-hand side of a string to the\n" | |
232 | "right-hand side of the same string, and the source and destination\n" | |
233 | "overlap, you must be careful to copy the rightmost characters of the\n" | |
234 | "text first, to avoid clobbering your data. Hence, when @var{str1} and\n" | |
235 | "@var{str2} are the same string, you should use\n" | |
236 | "@code{substring-move-right!} when moving text from left to right, and\n" | |
237 | "@code{substring-move-left!} otherwise. If @code{str1} and @samp{str2}\n" | |
238 | "are different strings, it does not matter which function you use.") | |
1bbd0b84 | 239 | #define FUNC_NAME s_scm_substring_move_x |
0f2d19dd | 240 | { |
c014a02e | 241 | long s1, s2, e, len; |
99a9952d | 242 | |
3b3b36dd GB |
243 | SCM_VALIDATE_STRING (1,str1); |
244 | SCM_VALIDATE_INUM_COPY (2,start1,s1); | |
245 | SCM_VALIDATE_INUM_COPY (3,end1,e); | |
246 | SCM_VALIDATE_STRING (4,str2); | |
247 | SCM_VALIDATE_INUM_COPY (5,start2,s2); | |
99a9952d | 248 | len = e - s1; |
1bbd0b84 | 249 | SCM_ASSERT_RANGE (3,end1,len >= 0); |
bfa974f0 DH |
250 | SCM_ASSERT_RANGE (2,start1,s1 <= SCM_STRING_LENGTH (str1) && s1 >= 0); |
251 | SCM_ASSERT_RANGE (5,start2,s2 <= SCM_STRING_LENGTH (str2) && s2 >= 0); | |
252 | SCM_ASSERT_RANGE (3,end1,e <= SCM_STRING_LENGTH (str1) && e >= 0); | |
253 | SCM_ASSERT_RANGE (5,start2,len+s2 <= SCM_STRING_LENGTH (str2)); | |
0f2d19dd | 254 | |
86c991c2 DH |
255 | SCM_SYSCALL(memmove((void *)(&(SCM_STRING_CHARS(str2)[s2])), |
256 | (void *)(&(SCM_STRING_CHARS(str1)[s1])), | |
99a9952d | 257 | len)); |
5ad8ab0a | 258 | |
b1349e46 | 259 | return scm_return_first(SCM_UNSPECIFIED, str1, str2); |
0f2d19dd | 260 | } |
1bbd0b84 | 261 | #undef FUNC_NAME |
0f2d19dd JB |
262 | |
263 | ||
5ad8ab0a | 264 | SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, |
1bbd0b84 | 265 | (SCM str, SCM start, SCM end, SCM fill), |
1e6808ea MG |
266 | "Change every character in @var{str} between @var{start} and\n" |
267 | "@var{end} to @var{fill}.\n" | |
268 | "\n" | |
269 | "@lisp\n" | |
6552dbf7 | 270 | "(define y \"abcdefg\")\n" |
1670bef9 | 271 | "(substring-fill! y 1 3 #\\r)\n" |
6552dbf7 GB |
272 | "y\n" |
273 | "@result{} \"arrdefg\"\n" | |
1e6808ea | 274 | "@end lisp") |
1bbd0b84 | 275 | #define FUNC_NAME s_scm_substring_fill_x |
0f2d19dd | 276 | { |
c014a02e | 277 | long i, e; |
0f2d19dd | 278 | char c; |
3b3b36dd GB |
279 | SCM_VALIDATE_STRING (1,str); |
280 | SCM_VALIDATE_INUM_COPY (2,start,i); | |
281 | SCM_VALIDATE_INUM_COPY (3,end,e); | |
7866a09b | 282 | SCM_VALIDATE_CHAR_COPY (4,fill,c); |
bfa974f0 DH |
283 | SCM_ASSERT_RANGE (2,start,i <= SCM_STRING_LENGTH (str) && i >= 0); |
284 | SCM_ASSERT_RANGE (3,end,e <= SCM_STRING_LENGTH (str) && e >= 0); | |
86c991c2 | 285 | while (i<e) SCM_STRING_CHARS (str)[i++] = c; |
0f2d19dd JB |
286 | return SCM_UNSPECIFIED; |
287 | } | |
1bbd0b84 | 288 | #undef FUNC_NAME |
0f2d19dd JB |
289 | |
290 | ||
5ad8ab0a | 291 | SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0, |
1bbd0b84 | 292 | (SCM str), |
1e6808ea MG |
293 | "Return @code{#t} if @var{str}'s length is nonzero, and\n" |
294 | "@code{#f} otherwise.\n" | |
295 | "@lisp\n" | |
296 | "(string-null? \"\") @result{} #t\n" | |
297 | "y @result{} \"foo\"\n" | |
298 | "(string-null? y) @result{} #f\n" | |
299 | "@end lisp") | |
1bbd0b84 | 300 | #define FUNC_NAME s_scm_string_null_p |
0f2d19dd | 301 | { |
a6d9e5ab DH |
302 | SCM_VALIDATE_STRING (1,str); |
303 | return SCM_NEGATE_BOOL (SCM_STRING_LENGTH (str)); | |
0f2d19dd | 304 | } |
1bbd0b84 | 305 | #undef FUNC_NAME |
0f2d19dd JB |
306 | |
307 | ||
5ad8ab0a | 308 | SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0, |
1bbd0b84 | 309 | (SCM str), |
91344ceb MG |
310 | "Return a newly allocated list of the characters that make up\n" |
311 | "the given string @var{str}. @code{string->list} and\n" | |
312 | "@code{list->string} are inverses as far as @samp{equal?} is\n" | |
313 | "concerned.") | |
1bbd0b84 | 314 | #define FUNC_NAME s_scm_string_to_list |
0f2d19dd | 315 | { |
c014a02e | 316 | long i; |
0f2d19dd JB |
317 | SCM res = SCM_EOL; |
318 | unsigned char *src; | |
a6d9e5ab | 319 | SCM_VALIDATE_STRING (1,str); |
34f0f2b8 | 320 | src = SCM_STRING_UCHARS (str); |
a6d9e5ab | 321 | for (i = SCM_STRING_LENGTH (str)-1;i >= 0;i--) res = scm_cons (SCM_MAKE_CHAR (src[i]), res); |
0f2d19dd JB |
322 | return res; |
323 | } | |
1bbd0b84 | 324 | #undef FUNC_NAME |
0f2d19dd JB |
325 | |
326 | ||
a49af0c0 DH |
327 | /* Helper function for the string copy and string conversion functions. |
328 | * No argument checking is performed. */ | |
329 | static SCM | |
330 | string_copy (SCM str) | |
331 | { | |
332 | return scm_makfromstr (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), 0); | |
333 | } | |
334 | ||
0f2d19dd | 335 | |
5ad8ab0a | 336 | SCM_DEFINE (scm_string_copy, "string-copy", 1, 0, 0, |
a49af0c0 | 337 | (SCM str), |
1e6808ea | 338 | "Return a newly allocated copy of the given @var{string}.") |
1bbd0b84 | 339 | #define FUNC_NAME s_scm_string_copy |
0f2d19dd | 340 | { |
d1ca2c64 | 341 | SCM_VALIDATE_STRING (1, str); |
a49af0c0 DH |
342 | |
343 | return string_copy (str); | |
0f2d19dd | 344 | } |
1bbd0b84 | 345 | #undef FUNC_NAME |
0f2d19dd JB |
346 | |
347 | ||
3b3b36dd | 348 | SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0, |
1bbd0b84 | 349 | (SCM str, SCM chr), |
1e6808ea MG |
350 | "Store @var{char} in every element of the given @var{string} and\n" |
351 | "return an unspecified value.") | |
1bbd0b84 | 352 | #define FUNC_NAME s_scm_string_fill_x |
0f2d19dd JB |
353 | { |
354 | register char *dst, c; | |
c014a02e | 355 | register long k; |
3b3b36dd | 356 | SCM_VALIDATE_STRING_COPY (1,str,dst); |
7866a09b | 357 | SCM_VALIDATE_CHAR_COPY (2,chr,c); |
bfa974f0 | 358 | for (k = SCM_STRING_LENGTH (str)-1;k >= 0;k--) dst[k] = c; |
0f2d19dd JB |
359 | return SCM_UNSPECIFIED; |
360 | } | |
1bbd0b84 | 361 | #undef FUNC_NAME |
0f2d19dd | 362 | |
a49af0c0 | 363 | |
5ad8ab0a | 364 | /* Helper function for the string uppercase conversion functions. |
a49af0c0 DH |
365 | * No argument checking is performed. */ |
366 | static SCM | |
367 | string_upcase_x (SCM v) | |
368 | { | |
c014a02e | 369 | unsigned long k; |
a49af0c0 DH |
370 | |
371 | for (k = 0; k < SCM_STRING_LENGTH (v); ++k) | |
372 | SCM_STRING_UCHARS (v) [k] = scm_upcase (SCM_STRING_UCHARS (v) [k]); | |
373 | ||
374 | return v; | |
375 | } | |
376 | ||
377 | ||
5ad8ab0a | 378 | SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0, |
a49af0c0 | 379 | (SCM str), |
91344ceb MG |
380 | "Destructively upcase every character in @var{str} and return\n" |
381 | "@var{str}.\n" | |
382 | "@lisp\n" | |
383 | "y @result{} \"arrdefg\"\n" | |
384 | "(string-upcase! y) @result{} \"ARRDEFG\"\n" | |
385 | "y @result{} \"ARRDEFG\"\n" | |
386 | "@end lisp") | |
1bbd0b84 | 387 | #define FUNC_NAME s_scm_string_upcase_x |
c101e39e | 388 | { |
a49af0c0 | 389 | SCM_VALIDATE_STRING (1, str); |
322ac0c5 | 390 | |
a49af0c0 | 391 | return string_upcase_x (str); |
c101e39e | 392 | } |
1bbd0b84 | 393 | #undef FUNC_NAME |
c101e39e | 394 | |
a49af0c0 | 395 | |
5ad8ab0a | 396 | SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0, |
a49af0c0 | 397 | (SCM str), |
91344ceb MG |
398 | "Return a freshly allocated string containing the characters of\n" |
399 | "@var{str} in upper case.") | |
1bbd0b84 | 400 | #define FUNC_NAME s_scm_string_upcase |
99a9952d | 401 | { |
a49af0c0 DH |
402 | SCM_VALIDATE_STRING (1, str); |
403 | ||
404 | return string_upcase_x (string_copy (str)); | |
99a9952d | 405 | } |
1bbd0b84 | 406 | #undef FUNC_NAME |
99a9952d | 407 | |
a49af0c0 | 408 | |
5ad8ab0a | 409 | /* Helper function for the string lowercase conversion functions. |
a49af0c0 DH |
410 | * No argument checking is performed. */ |
411 | static SCM | |
412 | string_downcase_x (SCM v) | |
413 | { | |
c014a02e | 414 | unsigned long k; |
a49af0c0 DH |
415 | |
416 | for (k = 0; k < SCM_STRING_LENGTH (v); ++k) | |
417 | SCM_STRING_UCHARS (v) [k] = scm_downcase (SCM_STRING_UCHARS (v) [k]); | |
418 | ||
419 | return v; | |
420 | } | |
421 | ||
422 | ||
5ad8ab0a | 423 | SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0, |
a49af0c0 | 424 | (SCM str), |
91344ceb MG |
425 | "Destructively downcase every character in @var{str} and return\n" |
426 | "@var{str}.\n" | |
427 | "@lisp\n" | |
428 | "y @result{} \"ARRDEFG\"\n" | |
429 | "(string-downcase! y) @result{} \"arrdefg\"\n" | |
430 | "y @result{} \"arrdefg\"\n" | |
431 | "@end lisp") | |
1bbd0b84 | 432 | #define FUNC_NAME s_scm_string_downcase_x |
c101e39e | 433 | { |
a49af0c0 | 434 | SCM_VALIDATE_STRING (1, str); |
322ac0c5 | 435 | |
a49af0c0 | 436 | return string_downcase_x (str); |
c101e39e | 437 | } |
1bbd0b84 | 438 | #undef FUNC_NAME |
0f2d19dd | 439 | |
a49af0c0 | 440 | |
5ad8ab0a | 441 | SCM_DEFINE (scm_string_downcase, "string-downcase", 1, 0, 0, |
a49af0c0 | 442 | (SCM str), |
91344ceb MG |
443 | "Return a freshly allocation string containing the characters in\n" |
444 | "@var{str} in lower case.") | |
1bbd0b84 | 445 | #define FUNC_NAME s_scm_string_downcase |
99a9952d | 446 | { |
a49af0c0 DH |
447 | SCM_VALIDATE_STRING (1, str); |
448 | ||
449 | return string_downcase_x (string_copy (str)); | |
99a9952d | 450 | } |
1bbd0b84 | 451 | #undef FUNC_NAME |
99a9952d | 452 | |
a49af0c0 | 453 | |
5ad8ab0a | 454 | /* Helper function for the string capitalization functions. |
a49af0c0 DH |
455 | * No argument checking is performed. */ |
456 | static SCM | |
457 | string_capitalize_x (SCM str) | |
99a9952d | 458 | { |
6552dbf7 | 459 | char *sz; |
c014a02e | 460 | long i, len; |
1be6b49c | 461 | int in_word=0; |
a49af0c0 | 462 | |
bfa974f0 | 463 | len = SCM_STRING_LENGTH(str); |
86c991c2 | 464 | sz = SCM_STRING_CHARS (str); |
99a9952d | 465 | for(i=0; i<len; i++) { |
7866a09b | 466 | if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKE_CHAR(sz[i])))) { |
99a9952d | 467 | if(!in_word) { |
6552dbf7 | 468 | sz[i] = scm_upcase(sz[i]); |
99a9952d JB |
469 | in_word = 1; |
470 | } else { | |
6552dbf7 | 471 | sz[i] = scm_downcase(sz[i]); |
99a9952d JB |
472 | } |
473 | } | |
474 | else in_word = 0; | |
475 | } | |
6552dbf7 | 476 | return str; |
99a9952d | 477 | } |
a49af0c0 DH |
478 | |
479 | ||
5ad8ab0a | 480 | SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, |
a49af0c0 | 481 | (SCM str), |
91344ceb MG |
482 | "Upcase the first character of every word in @var{str}\n" |
483 | "destructively and return @var{str}.\n" | |
484 | "\n" | |
485 | "@lisp\n" | |
486 | "y @result{} "hello world"\n" | |
487 | "(string-capitalize! y) @result{} "Hello World"\n" | |
488 | "y @result{} "Hello World"\n" | |
489 | "@end lisp") | |
a49af0c0 DH |
490 | #define FUNC_NAME s_scm_string_capitalize_x |
491 | { | |
492 | SCM_VALIDATE_STRING (1, str); | |
493 | ||
494 | return string_capitalize_x (str); | |
495 | } | |
1bbd0b84 | 496 | #undef FUNC_NAME |
99a9952d | 497 | |
a49af0c0 | 498 | |
5ad8ab0a | 499 | SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0, |
a49af0c0 | 500 | (SCM str), |
91344ceb MG |
501 | "Return a freshly allocated string with the characters in\n" |
502 | "@var{str}, where the first character of every word is\n" | |
503 | "capitalized.") | |
1bbd0b84 | 504 | #define FUNC_NAME s_scm_string_capitalize |
99a9952d | 505 | { |
a49af0c0 DH |
506 | SCM_VALIDATE_STRING (1, str); |
507 | ||
508 | return string_capitalize_x (string_copy (str)); | |
99a9952d | 509 | } |
1bbd0b84 | 510 | #undef FUNC_NAME |
99a9952d | 511 | |
a49af0c0 | 512 | |
5ad8ab0a | 513 | SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, |
dd2a6f3a MG |
514 | (SCM str, SCM chr), |
515 | "Split the string @var{str} into the a list of the substrings delimited\n" | |
516 | "by appearances of the character @var{chr}. Note that an empty substring\n" | |
517 | "between separator characters will result in an empty string in the\n" | |
518 | "result list.\n" | |
519 | "\n" | |
520 | "@lisp\n" | |
521 | "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\:)\n" | |
522 | "@result{}\n" | |
523 | "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n" | |
524 | "\n" | |
525 | "(string-split \"::\" #\:)\n" | |
526 | "@result{}\n" | |
527 | "(\"\" \"\" \"\")\n" | |
528 | "\n" | |
529 | "(string-split \"\" #\:)\n" | |
530 | "@result{}\n" | |
531 | "(\"\")\n" | |
532 | "@end lisp") | |
533 | #define FUNC_NAME s_scm_string_split | |
534 | { | |
c014a02e | 535 | long idx, last_idx; |
dd2a6f3a MG |
536 | char * p; |
537 | int ch; | |
538 | SCM res = SCM_EOL; | |
539 | ||
540 | SCM_VALIDATE_STRING (1, str); | |
541 | SCM_VALIDATE_CHAR (2, chr); | |
542 | ||
543 | idx = SCM_STRING_LENGTH (str); | |
544 | p = SCM_STRING_CHARS (str); | |
545 | ch = SCM_CHAR (chr); | |
546 | while (idx >= 0) | |
547 | { | |
548 | last_idx = idx; | |
549 | while (idx > 0 && p[idx - 1] != ch) | |
550 | idx--; | |
551 | if (idx >= 0) | |
552 | { | |
553 | res = scm_cons (scm_makfromstr (p + idx, last_idx - idx, 0), res); | |
554 | idx--; | |
555 | } | |
556 | } | |
557 | return res; | |
558 | } | |
559 | #undef FUNC_NAME | |
560 | ||
561 | ||
5ad8ab0a | 562 | SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, |
91344ceb MG |
563 | (SCM str), |
564 | "Return the symbol whose name is @var{str}. @var{str} is\n" | |
565 | "converted to lowercase before the conversion is done, if Guile\n" | |
566 | "is currently reading symbols case--insensitively.") | |
1bbd0b84 | 567 | #define FUNC_NAME s_scm_string_ci_to_symbol |
99a9952d JB |
568 | { |
569 | return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P | |
570 | ? scm_string_downcase(str) | |
571 | : str); | |
572 | } | |
1bbd0b84 | 573 | #undef FUNC_NAME |
1cc91f1b | 574 | |
0f2d19dd JB |
575 | void |
576 | scm_init_strop () | |
0f2d19dd | 577 | { |
8dc9439f | 578 | #ifndef SCM_MAGIC_SNARFER |
a0599745 | 579 | #include "libguile/strop.x" |
8dc9439f | 580 | #endif |
0f2d19dd | 581 | } |
89e00824 ML |
582 | |
583 | /* | |
584 | Local Variables: | |
585 | c-file-style: "gnu" | |
586 | End: | |
587 | */ |