1 /* classes: src_files */
3 /* Copyright (C) 1994, 1996, 1997 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
30 static int scm_i_index
SCM_P ((SCM
* str
, SCM chr
, int direction
, SCM sub_start
, SCM sub_end
, int pos
, int pos2
, int pos3
, int pos4
, char * why
));
32 /* implements index if direction > 0 otherwise rindex. */
34 scm_i_index (str
, chr
, direction
, sub_start
, sub_end
, pos
, pos2
, pos3
, pos4
,
53 SCM_ASSERT (SCM_NIMP (*str
) && SCM_ROSTRINGP (*str
), *str
, pos
, why
);
54 SCM_ASSERT (SCM_ICHRP (chr
), chr
, pos2
, why
);
56 if (sub_start
== SCM_BOOL_F
)
57 sub_start
= SCM_MAKINUM (0);
59 SCM_ASSERT (SCM_INUMP (sub_start
), sub_start
, pos3
, why
);
60 lower
= SCM_INUM (sub_start
);
62 || lower
> SCM_ROLENGTH (*str
))
63 scm_out_of_range (why
, sub_start
);
65 if (sub_end
== SCM_BOOL_F
)
66 sub_end
= SCM_MAKINUM (SCM_ROLENGTH (*str
));
68 SCM_ASSERT (SCM_INUMP (sub_end
), sub_end
, pos4
, why
);
69 upper
= SCM_INUM (sub_end
);
70 if (upper
< SCM_INUM (sub_start
)
71 || upper
> SCM_ROLENGTH (*str
))
72 scm_out_of_range (why
, sub_end
);
76 p
= (unsigned char *)SCM_ROCHARS (*str
) + lower
;
79 for (x
= SCM_INUM (sub_start
); x
< upper
; ++x
, ++p
)
85 p
= upper
- 1 + (unsigned char *)SCM_ROCHARS (*str
);
87 for (x
= upper
- 1; x
>= lower
; --x
, --p
)
95 SCM_PROC(s_string_index
, "string-index", 2, 2, 0, scm_string_index
);
98 scm_string_index (str
, chr
, frm
, to
)
106 if (frm
== SCM_UNDEFINED
)
108 if (to
== SCM_UNDEFINED
)
110 pos
= scm_i_index (&str
, chr
, 1, frm
, to
, SCM_ARG1
, SCM_ARG2
, SCM_ARG3
, SCM_ARG4
, s_string_index
);
113 : SCM_MAKINUM (pos
));
116 SCM_PROC(s_string_rindex
, "string-rindex", 2, 2, 0, scm_string_rindex
);
119 scm_string_rindex (str
, chr
, frm
, to
)
127 if (frm
== SCM_UNDEFINED
)
129 if (to
== SCM_UNDEFINED
)
131 pos
= scm_i_index (&str
, chr
, -1, frm
, to
, SCM_ARG1
, SCM_ARG2
, SCM_ARG3
, SCM_ARG4
, s_string_index
);
134 : SCM_MAKINUM (pos
));
142 SCM_PROC(s_substring_move_left_x
, "substring-move-left!", 2, 0, 1, scm_substring_move_left_x
);
145 scm_substring_move_left_x (str1
, start1
, args
)
150 SCM end1
, str2
, start2
;
152 SCM_ASSERT (3==scm_ilength (args
), scm_makfrom0str (s_substring_move_left_x
),
154 end1
= SCM_CAR (args
); args
= SCM_CDR (args
);
155 str2
= SCM_CAR (args
); args
= SCM_CDR (args
);
156 start2
= SCM_CAR (args
);
157 SCM_ASSERT (SCM_NIMP (str1
) && SCM_STRINGP (str1
), str1
, SCM_ARG1
, s_substring_move_left_x
);
158 SCM_ASSERT (SCM_INUMP (start1
), start1
, SCM_ARG2
, s_substring_move_left_x
);
159 SCM_ASSERT (SCM_INUMP (end1
), end1
, SCM_ARG3
, s_substring_move_left_x
);
160 SCM_ASSERT (SCM_NIMP (str2
) && SCM_STRINGP (str2
), str2
, SCM_ARG4
, s_substring_move_left_x
);
161 SCM_ASSERT (SCM_INUMP (start2
), start2
, SCM_ARG5
, s_substring_move_left_x
);
162 i
= SCM_INUM (start1
), j
= SCM_INUM (start2
), e
= SCM_INUM (end1
);
163 SCM_ASSERT (i
<= SCM_LENGTH (str1
) && i
>= 0, start1
, SCM_OUTOFRANGE
, s_substring_move_left_x
);
164 SCM_ASSERT (j
<= SCM_LENGTH (str2
) && j
>= 0, start2
, SCM_OUTOFRANGE
, s_substring_move_left_x
);
165 SCM_ASSERT (e
<= SCM_LENGTH (str1
) && e
>= 0, end1
, SCM_OUTOFRANGE
, s_substring_move_left_x
);
166 SCM_ASSERT (e
-i
+j
<= SCM_LENGTH (str2
), start2
, SCM_OUTOFRANGE
, s_substring_move_left_x
);
167 while (i
<e
) SCM_CHARS (str2
)[j
++] = SCM_CHARS (str1
)[i
++];
168 return SCM_UNSPECIFIED
;
172 SCM_PROC(s_substring_move_right_x
, "substring-move-right!", 2, 0, 1, scm_substring_move_right_x
);
175 scm_substring_move_right_x (str1
, start1
, args
)
180 SCM end1
, str2
, start2
;
182 SCM_ASSERT (3==scm_ilength (args
),
183 scm_makfrom0str (s_substring_move_right_x
), SCM_WNA
, NULL
);
184 end1
= SCM_CAR (args
); args
= SCM_CDR (args
);
185 str2
= SCM_CAR (args
); args
= SCM_CDR (args
);
186 start2
= SCM_CAR (args
);
187 SCM_ASSERT (SCM_NIMP (str1
) && SCM_STRINGP (str1
), str1
, SCM_ARG1
, s_substring_move_right_x
);
188 SCM_ASSERT (SCM_INUMP (start1
), start1
, SCM_ARG2
, s_substring_move_right_x
);
189 SCM_ASSERT (SCM_INUMP (end1
), end1
, SCM_ARG3
, s_substring_move_right_x
);
190 SCM_ASSERT (SCM_NIMP (str2
) && SCM_STRINGP (str2
), str2
, SCM_ARG4
, s_substring_move_right_x
);
191 SCM_ASSERT (SCM_INUMP (start2
), start2
, SCM_ARG5
, s_substring_move_right_x
);
192 i
= SCM_INUM (start1
), j
= SCM_INUM (start2
), e
= SCM_INUM (end1
);
193 SCM_ASSERT (i
<= SCM_LENGTH (str1
) && i
>= 0, start1
, SCM_OUTOFRANGE
, s_substring_move_right_x
);
194 SCM_ASSERT (j
<= SCM_LENGTH (str2
) && j
>= 0, start2
, SCM_OUTOFRANGE
, s_substring_move_right_x
);
195 SCM_ASSERT (e
<= SCM_LENGTH (str1
) && e
>= 0, end1
, SCM_OUTOFRANGE
, s_substring_move_right_x
);
196 SCM_ASSERT ((j
= e
-i
+j
) <= SCM_LENGTH (str2
), start2
, SCM_OUTOFRANGE
, s_substring_move_right_x
);
197 while (i
<e
) SCM_CHARS (str2
)[--j
] = SCM_CHARS (str1
)[--e
];
198 return SCM_UNSPECIFIED
;
202 SCM_PROC(s_substring_fill_x
, "substring-fill!", 2, 0, 1, scm_substring_fill_x
);
205 scm_substring_fill_x (str
, start
, args
)
213 SCM_ASSERT (2==scm_ilength (args
), scm_makfrom0str (s_substring_fill_x
),
215 end
= SCM_CAR (args
); args
= SCM_CDR (args
);
216 fill
= SCM_CAR (args
);
217 SCM_ASSERT (SCM_NIMP (str
) && SCM_STRINGP (str
), str
, SCM_ARG1
, s_substring_fill_x
);
218 SCM_ASSERT (SCM_INUMP (start
), start
, SCM_ARG2
, s_substring_fill_x
);
219 SCM_ASSERT (SCM_INUMP (end
), end
, SCM_ARG3
, s_substring_fill_x
);
220 SCM_ASSERT (SCM_ICHRP (fill
), fill
, SCM_ARG4
, s_substring_fill_x
);
221 i
= SCM_INUM (start
), e
= SCM_INUM (end
);c
= SCM_ICHR (fill
);
222 SCM_ASSERT (i
<= SCM_LENGTH (str
) && i
>= 0, start
, SCM_OUTOFRANGE
, s_substring_fill_x
);
223 SCM_ASSERT (e
<= SCM_LENGTH (str
) && e
>= 0, end
, SCM_OUTOFRANGE
, s_substring_fill_x
);
224 while (i
<e
) SCM_CHARS (str
)[i
++] = c
;
225 return SCM_UNSPECIFIED
;
229 SCM_PROC(s_string_null_p
, "string-null?", 1, 0, 0, scm_string_null_p
);
232 scm_string_null_p (str
)
235 SCM_ASSERT (SCM_NIMP (str
) && SCM_ROSTRINGP (str
), str
, SCM_ARG1
, s_string_null_p
);
236 return (SCM_ROLENGTH (str
)
242 SCM_PROC(s_string_to_list
, "string->list", 1, 0, 0, scm_string_to_list
);
245 scm_string_to_list (str
)
251 SCM_ASSERT (SCM_NIMP (str
) && SCM_ROSTRINGP (str
), str
, SCM_ARG1
, s_string_to_list
);
252 src
= SCM_ROUCHARS (str
);
253 for (i
= SCM_ROLENGTH (str
)-1;i
>= 0;i
--) res
= scm_cons ((SCM
)SCM_MAKICHR (src
[i
]), res
);
259 SCM_PROC(s_string_copy
, "string-copy", 1, 0, 0, scm_string_copy
);
262 scm_string_copy (str
)
265 /* doesn't handle multibyte strings. */
266 SCM_ASSERT (SCM_NIMP (str
) && (SCM_STRINGP (str
) || SCM_SUBSTRP (str
)),
267 str
, SCM_ARG1
, s_string_copy
);
268 return scm_makfromstr (SCM_ROCHARS (str
), (scm_sizet
)SCM_ROLENGTH (str
), 0);
272 SCM_PROC(s_string_fill_x
, "string-fill!", 2, 0, 0, scm_string_fill_x
);
275 scm_string_fill_x (str
, chr
)
279 register char *dst
, c
;
281 SCM_ASSERT (SCM_NIMP (str
) && SCM_STRINGP (str
), str
, SCM_ARG1
, s_string_fill_x
);
282 SCM_ASSERT (SCM_ICHRP (chr
), chr
, SCM_ARG2
, s_string_fill_x
);
284 dst
= SCM_CHARS (str
);
285 for (k
= SCM_LENGTH (str
)-1;k
>= 0;k
--) dst
[k
] = c
;
286 return SCM_UNSPECIFIED
;
289 SCM_PROC(s_string_upcase_x
, "string-upcase!", 1, 0, 0, scm_string_upcase_x
);
292 scm_string_upcase_x (v
)
296 register unsigned char *cs
;
297 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
305 cs
[k
] = scm_upcase(cs
[k
]);
308 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_string_upcase_x
);
313 SCM_PROC(s_string_downcase_x
, "string-downcase!", 1, 0, 0, scm_string_downcase_x
);
316 scm_string_downcase_x (v
)
320 register unsigned char *cs
;
321 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
329 cs
[k
] = scm_downcase(cs
[k
]);
332 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_string_downcase_x
);