1 /* classes: src_files */
3 /* Copyright (C) 1994, 1996, 1997 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
27 #include "read.h" /*For SCM_CASE_INSENSITIVE_P*/
31 /* implements index if direction > 0 otherwise rindex. */
33 scm_i_index (SCM
*str
, SCM chr
, int direction
, SCM sub_start
,
34 SCM sub_end
, const char *why
)
43 SCM_ASSERT (SCM_NIMP (*str
) && SCM_ROSTRINGP (*str
), *str
, SCM_ARG1
, why
);
44 SCM_ASSERT (SCM_ICHRP (chr
), chr
, SCM_ARG2
, why
);
46 if (sub_start
== SCM_BOOL_F
)
47 sub_start
= SCM_MAKINUM (0);
49 SCM_ASSERT (SCM_INUMP (sub_start
), sub_start
, SCM_ARG3
, why
);
50 lower
= SCM_INUM (sub_start
);
52 || lower
> SCM_ROLENGTH (*str
))
53 scm_out_of_range (why
, sub_start
);
55 if (sub_end
== SCM_BOOL_F
)
56 sub_end
= SCM_MAKINUM (SCM_ROLENGTH (*str
));
58 SCM_ASSERT (SCM_INUMP (sub_end
), sub_end
, SCM_ARG4
, why
);
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
);
66 p
= (unsigned char *)SCM_ROCHARS (*str
) + lower
;
69 for (x
= SCM_INUM (sub_start
); x
< upper
; ++x
, ++p
)
75 p
= upper
- 1 + (unsigned char *)SCM_ROCHARS (*str
);
77 for (x
= upper
- 1; x
>= lower
; --x
, --p
)
85 SCM_PROC(s_string_index
, "string-index", 2, 2, 0, scm_string_index
);
88 scm_string_index (SCM str
, SCM chr
, SCM frm
, SCM to
)
92 if (frm
== SCM_UNDEFINED
)
94 if (to
== SCM_UNDEFINED
)
96 pos
= scm_i_index (&str
, chr
, 1, frm
, to
, s_string_index
);
102 SCM_PROC(s_string_rindex
, "string-rindex", 2, 2, 0, scm_string_rindex
);
105 scm_string_rindex (SCM str
, SCM chr
, SCM frm
, SCM to
)
109 if (frm
== SCM_UNDEFINED
)
111 if (to
== SCM_UNDEFINED
)
113 pos
= scm_i_index (&str
, chr
, -1, frm
, to
, s_string_rindex
);
116 : SCM_MAKINUM (pos
));
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
);
125 scm_substring_move_x (SCM str1
, SCM start1
, SCM end1
,
126 SCM str2
, SCM start2
)
131 SCM_ASSERT (SCM_NIMP (str1
) && SCM_STRINGP (str1
), str1
,
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
);
135 SCM_ASSERT (SCM_NIMP (str2
) && SCM_STRINGP (str2
), str2
,
136 SCM_ARG4
, s_substring_move_x
);
137 SCM_ASSERT (SCM_INUMP (start2
), start2
, SCM_ARG5
, s_substring_move_x
);
139 s1
= SCM_INUM (start1
), s2
= SCM_INUM (start2
), e
= SCM_INUM (end1
);
141 SCM_ASSERT (s1
<= SCM_LENGTH (str1
) && s1
>= 0, start1
,
142 SCM_OUTOFRANGE
, s_substring_move_x
);
143 SCM_ASSERT (s2
<= SCM_LENGTH (str2
) && s2
>= 0, start2
,
144 SCM_OUTOFRANGE
, s_substring_move_x
);
145 SCM_ASSERT (e
<= SCM_LENGTH (str1
) && e
>= 0, end1
,
146 SCM_OUTOFRANGE
, s_substring_move_x
);
147 SCM_ASSERT (len
+s2
<= SCM_LENGTH (str2
), start2
,
148 SCM_OUTOFRANGE
, s_substring_move_x
);
150 SCM_SYSCALL(memmove((void *)(&(SCM_CHARS(str2
)[s2
])),
151 (void *)(&(SCM_CHARS(str1
)[s1
])),
154 return scm_return_first(SCM_UNSPECIFIED
, str1
, str2
);
158 SCM_PROC(s_substring_fill_x
, "substring-fill!", 4, 0, 0, scm_substring_fill_x
);
161 scm_substring_fill_x (SCM str
, SCM start
, SCM end
, SCM fill
)
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
);
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
);
175 while (i
<e
) SCM_CHARS (str
)[i
++] = c
;
176 return SCM_UNSPECIFIED
;
180 SCM_PROC(s_string_null_p
, "string-null?", 1, 0, 0, scm_string_null_p
);
183 scm_string_null_p (str
)
186 SCM_ASSERT (SCM_NIMP (str
) && SCM_ROSTRINGP (str
), str
, SCM_ARG1
, s_string_null_p
);
187 return (SCM_ROLENGTH (str
)
193 SCM_PROC(s_string_to_list
, "string->list", 1, 0, 0, scm_string_to_list
);
196 scm_string_to_list (str
)
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
);
210 SCM_PROC(s_string_copy
, "string-copy", 1, 0, 0, scm_string_copy
);
213 scm_string_copy (str
)
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);
222 SCM_PROC(s_string_fill_x
, "string-fill!", 2, 0, 0, scm_string_fill_x
);
225 scm_string_fill_x (str
, chr
)
229 register char *dst
, c
;
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
);
234 dst
= SCM_CHARS (str
);
235 for (k
= SCM_LENGTH (str
)-1;k
>= 0;k
--) dst
[k
] = c
;
236 return SCM_UNSPECIFIED
;
239 SCM_PROC(s_string_upcase_x
, "string-upcase!", 1, 0, 0, scm_string_upcase_x
);
242 scm_string_upcase_x (v
)
246 register unsigned char *cs
;
247 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
255 cs
[k
] = scm_upcase(cs
[k
]);
258 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_string_upcase_x
);
263 SCM_PROC(s_string_upcase
, "string-upcase", 1, 0, 0, scm_string_upcase
);
266 scm_string_upcase(SCM str
)
268 return scm_string_upcase_x(scm_string_copy(str
));
271 SCM_PROC(s_string_downcase_x
, "string-downcase!", 1, 0, 0, scm_string_downcase_x
);
274 scm_string_downcase_x (v
)
278 register unsigned char *cs
;
279 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
286 cs
[k
] = scm_downcase(cs
[k
]);
289 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_string_downcase_x
);
294 SCM_PROC(s_string_downcase
, "string-downcase", 1, 0, 0, scm_string_downcase
);
297 scm_string_downcase(SCM str
)
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
));
303 SCM_PROC(s_string_capitalize_x
, "string-capitalize!", 1, 0, 0, scm_string_capitalize_x
);
306 scm_string_capitalize_x (SCM s
)
309 int i
, len
, in_word
=0;
310 SCM_ASSERT(SCM_NIMP(s
) && SCM_STRINGP(s
), s
, SCM_ARG1
, s_string_capitalize_x
);
313 for(i
=0; i
<len
; i
++) {
314 if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKICHR(str
[i
])))) {
316 str
[i
] = scm_upcase(str
[i
]);
319 str
[i
] = scm_downcase(str
[i
]);
327 SCM_PROC(s_string_capitalize
, "string-capitalize", 1, 0, 0, scm_string_capitalize
);
330 scm_string_capitalize(SCM s
)
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
));
336 SCM_PROC(s_string_ci_to_symbol
, "string-ci->symbol", 1, 0, 0, scm_string_ci_to_symbol
);
339 scm_string_ci_to_symbol(SCM str
)
341 return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
342 ? scm_string_downcase(str
)