1 /* classes: src_files */
3 /* Copyright (C) 1994, 1996, 1997, 1999 Free Software Foundation, Inc.
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)
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.
15 You should have received a copy of the GNU General Public License
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
20 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
21 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
30 #include "scm_validate.h"
32 #include "read.h" /*For SCM_CASE_INSENSITIVE_P*/
36 /* implements index if direction > 0 otherwise rindex. */
38 scm_i_index (SCM
*str
, SCM chr
, int direction
, SCM sub_start
,
39 SCM sub_end
, const char *why
)
47 SCM_ASSERT (SCM_ROSTRINGP (*str
), *str
, SCM_ARG1
, why
);
48 SCM_ASSERT (SCM_ICHRP (chr
), chr
, SCM_ARG2
, why
);
50 if (sub_start
== SCM_BOOL_F
)
51 sub_start
= SCM_MAKINUM (0);
53 SCM_ASSERT (SCM_INUMP (sub_start
), sub_start
, SCM_ARG3
, why
);
54 lower
= SCM_INUM (sub_start
);
56 || lower
> SCM_ROLENGTH (*str
))
57 scm_out_of_range (why
, sub_start
);
59 if (sub_end
== SCM_BOOL_F
)
60 sub_end
= SCM_MAKINUM (SCM_ROLENGTH (*str
));
62 SCM_ASSERT (SCM_INUMP (sub_end
), sub_end
, SCM_ARG4
, why
);
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
);
70 p
= (unsigned char *)SCM_ROCHARS (*str
) + lower
;
73 for (x
= SCM_INUM (sub_start
); x
< upper
; ++x
, ++p
)
79 p
= upper
- 1 + (unsigned char *)SCM_ROCHARS (*str
);
81 for (x
= upper
- 1; x
>= lower
; --x
, --p
)
89 GUILE_PROC(scm_string_index
, "string-index", 2, 2, 0,
90 (SCM str
, SCM chr
, SCM frm
, SCM to
),
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.")
95 #define FUNC_NAME s_scm_string_index
99 if (frm
== SCM_UNDEFINED
)
101 if (to
== SCM_UNDEFINED
)
103 pos
= scm_i_index (&str
, chr
, 1, frm
, to
, FUNC_NAME
);
106 : SCM_MAKINUM (pos
));
110 GUILE_PROC(scm_string_rindex
, "string-rindex", 2, 2, 0,
111 (SCM str
, SCM chr
, SCM frm
, SCM to
),
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.")
115 #define FUNC_NAME s_scm_string_rindex
119 if (frm
== SCM_UNDEFINED
)
121 if (to
== SCM_UNDEFINED
)
123 pos
= scm_i_index (&str
, chr
, -1, frm
, to
, FUNC_NAME
);
126 : SCM_MAKINUM (pos
));
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
);
135 GUILE_PROC(scm_substring_move_x
, "substring-move!", 5, 0, 0,
136 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
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.
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.")
153 #define FUNC_NAME s_scm_substring_move_x
157 SCM_VALIDATE_STRING(1,str1
);
158 SCM_VALIDATE_INUM_COPY(2,start1
,s1
);
159 SCM_VALIDATE_INUM_COPY(3,end1
,e
);
160 SCM_VALIDATE_STRING(4,str2
);
161 SCM_VALIDATE_INUM_COPY(5,start2
,s2
);
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
));
169 SCM_SYSCALL(memmove((void *)(&(SCM_CHARS(str2
)[s2
])),
170 (void *)(&(SCM_CHARS(str1
)[s1
])),
173 return scm_return_first(SCM_UNSPECIFIED
, str1
, str2
);
178 GUILE_PROC(scm_substring_fill_x
, "substring-fill!", 4, 0, 0,
179 (SCM str
, SCM start
, SCM end
, SCM fill
),
180 "Change every character in @var{str} between @var{start} and @var{end} to
182 #define FUNC_NAME s_scm_substring_fill_x
186 SCM_VALIDATE_STRING(1,str
);
187 SCM_VALIDATE_INUM_COPY(2,start
,i
);
188 SCM_VALIDATE_INUM_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);
192 while (i
<e
) SCM_CHARS (str
)[i
++] = c
;
193 return SCM_UNSPECIFIED
;
198 GUILE_PROC(scm_string_null_p
, "string-null?", 1, 0, 0,
200 "Return @code{#t} if @var{str}'s length is nonzero, and @code{#f}
202 #define FUNC_NAME s_scm_string_null_p
204 SCM_VALIDATE_ROSTRING(1,str
);
205 return SCM_NEGATE_BOOL(SCM_ROLENGTH (str
));
210 GUILE_PROC(scm_string_to_list
, "string->list", 1, 0, 0,
213 #define FUNC_NAME s_scm_string_to_list
218 SCM_VALIDATE_ROSTRING(1,str
);
219 src
= SCM_ROUCHARS (str
);
220 for (i
= SCM_ROLENGTH (str
)-1;i
>= 0;i
--) res
= scm_cons ((SCM
)SCM_MAKICHR (src
[i
]), res
);
227 GUILE_PROC(scm_string_copy
, "string-copy", 1, 0, 0,
230 #define FUNC_NAME s_scm_string_copy
232 SCM_VALIDATE_STRINGORSUBSTR(1,str
);
233 return scm_makfromstr (SCM_ROCHARS (str
), (scm_sizet
)SCM_ROLENGTH (str
), 0);
238 GUILE_PROC(scm_string_fill_x
, "string-fill!", 2, 0, 0,
241 #define FUNC_NAME s_scm_string_fill_x
243 register char *dst
, c
;
245 SCM_VALIDATE_STRING_COPY(1,str
,dst
);
246 SCM_VALIDATE_CHAR_COPY(2,chr
,c
);
247 for (k
= SCM_LENGTH (str
)-1;k
>= 0;k
--) dst
[k
] = c
;
248 return SCM_UNSPECIFIED
;
252 GUILE_PROC(scm_string_upcase_x
, "string-upcase!", 1, 0, 0,
254 "@deffnx primitive string-downcase! str
255 Upcase or downcase every character in @code{str}, respectively.")
256 #define FUNC_NAME s_scm_string_upcase_x
259 register unsigned char *cs
;
260 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
268 cs
[k
] = scm_upcase(cs
[k
]);
271 badarg1
:SCM_WTA (1,v
);
277 GUILE_PROC(scm_string_upcase
, "string-upcase", 1, 0, 0,
280 #define FUNC_NAME s_scm_string_upcase
282 return scm_string_upcase_x(scm_string_copy(str
));
286 GUILE_PROC(scm_string_downcase_x
, "string-downcase!", 1, 0, 0,
289 #define FUNC_NAME s_scm_string_downcase_x
292 register unsigned char *cs
;
293 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
300 cs
[k
] = scm_downcase(cs
[k
]);
303 badarg1
:SCM_WTA (1,v
);
309 GUILE_PROC(scm_string_downcase
, "string-downcase", 1, 0, 0,
312 #define FUNC_NAME s_scm_string_downcase
314 SCM_VALIDATE_STRING(1,str
);
315 return scm_string_downcase_x(scm_string_copy(str
));
319 GUILE_PROC(scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
322 #define FUNC_NAME s_scm_string_capitalize_x
325 int i
, len
, in_word
=0;
326 SCM_VALIDATE_STRING(1,s
);
329 for(i
=0; i
<len
; i
++) {
330 if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKICHR(str
[i
])))) {
332 str
[i
] = scm_upcase(str
[i
]);
335 str
[i
] = scm_downcase(str
[i
]);
344 GUILE_PROC(scm_string_capitalize
, "string-capitalize", 1, 0, 0,
347 #define FUNC_NAME s_scm_string_capitalize
349 SCM_VALIDATE_STRING(1,s
);
350 return scm_string_capitalize_x(scm_string_copy(s
));
354 GUILE_PROC(scm_string_ci_to_symbol
, "string-ci->symbol", 1, 0, 0,
357 #define FUNC_NAME s_scm_string_ci_to_symbol
359 return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
360 ? scm_string_downcase(str
)