/* srfi-13.c --- SRFI-13 procedures for Guile
*
- * Copyright (C) 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#endif
#include <string.h>
-#include <ctype.h>
+#include <unicase.h>
+#include <unictype.h>
#include "libguile.h"
+#include <libguile/deprecation.h>
#include "libguile/srfi-13.h"
#include "libguile/srfi-14.h"
-/* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages
- messing with the internal representation of strings. We define our
- own version since we use it so much and are messing with Guile
- internals anyway.
-*/
-
-#define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \
- pos_start, start, c_start, \
- pos_end, end, c_end) \
- do { \
- SCM_VALIDATE_STRING (pos_str, str); \
- c_str = scm_i_string_chars (str); \
- scm_i_get_substring_spec (scm_i_string_length (str), \
- start, &c_start, end, &c_end); \
- } while (0)
-
-/* Expecting "unsigned char *c_str" */
-#define MY_VALIDATE_SUBSTRING_SPEC_UCOPY(pos_str, str, c_str, \
- pos_start, start, c_start, \
- pos_end, end, c_end) \
- do { \
- const char *signed_c_str; \
- MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, signed_c_str, \
- pos_start, start, c_start, \
- pos_end, end, c_end); \
- c_str = (unsigned char *) signed_c_str; \
- } while (0)
-
#define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
pos_start, start, c_start, \
pos_end, end, c_end) \
start, &c_start, end, &c_end); \
} while (0)
+#define MY_SUBF_VALIDATE_SUBSTRING_SPEC(fname, pos_str, str, \
+ pos_start, start, c_start, \
+ pos_end, end, c_end) \
+ do { \
+ SCM_ASSERT_TYPE (scm_is_string (str), str, pos_str, fname, "string"); \
+ scm_i_get_substring_spec (scm_i_string_length (str), \
+ start, &c_start, end, &c_end); \
+ } while (0)
+
+#define REF_IN_CHARSET(s, i, cs) \
+ (scm_is_true (scm_char_set_contains_p ((cs), SCM_MAKE_CHAR (scm_i_string_ref (s, i)))))
+
SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0,
(SCM str),
"Return @code{#t} if @var{str}'s length is zero, and\n"
"@var{end}) then the return is @code{#f}.\n")
#define FUNC_NAME s_scm_string_any
{
- const char *cstr;
size_t cstart, cend;
SCM res = SCM_BOOL_F;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- res = (memchr (cstr+cstart, (int) SCM_CHAR (char_pred),
- cend-cstart) == NULL
- ? SCM_BOOL_F : SCM_BOOL_T);
+ size_t i;
+ for (i = cstart; i < cend; i ++)
+ if (scm_i_string_ref (s, i) == SCM_CHAR (char_pred))
+ {
+ res = SCM_BOOL_T;
+ break;
+ }
}
else if (SCM_CHARSETP (char_pred))
{
size_t i;
for (i = cstart; i < cend; i++)
- if (SCM_CHARSET_GET (char_pred, cstr[i]))
+ if (REF_IN_CHARSET (s, i, char_pred))
{
res = SCM_BOOL_T;
break;
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG1, FUNC_NAME);
while (cstart < cend)
{
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = scm_call_1 (char_pred,
+ SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res))
break;
- cstr = scm_i_string_chars (s);
cstart++;
}
}
"@var{end}) then the return is @code{#t}.\n")
#define FUNC_NAME s_scm_string_every
{
- const char *cstr;
size_t cstart, cend;
SCM res = SCM_BOOL_T;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- char cchr = SCM_CHAR (char_pred);
size_t i;
for (i = cstart; i < cend; i++)
- if (cstr[i] != cchr)
+ if (scm_i_string_ref (s, i) != SCM_CHAR (char_pred))
{
res = SCM_BOOL_F;
break;
{
size_t i;
for (i = cstart; i < cend; i++)
- if (!SCM_CHARSET_GET (char_pred, cstr[i]))
+ if (!REF_IN_CHARSET (s, i, char_pred))
{
res = SCM_BOOL_F;
break;
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG1, FUNC_NAME);
while (cstart < cend)
{
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = scm_call_1 (char_pred,
+ SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
break;
- cstr = scm_i_string_chars (s);
cstart++;
}
}
size_t clen, i;
SCM res;
SCM ch;
- char *p;
- scm_t_trampoline_1 proc_tramp;
- proc_tramp = scm_trampoline_1 (proc);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT_RANGE (2, len, scm_to_int (len) >= 0);
clen = scm_to_size_t (len);
- SCM_ASSERT_RANGE (2, len, clen >= 0);
- res = scm_i_make_string (clen, &p);
- i = 0;
- while (i < clen)
- {
- /* The RES string remains untouched since nobody knows about it
- yet. No need to refetch P.
- */
- ch = proc_tramp (proc, scm_from_size_t (i));
- if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
- *p++ = SCM_CHAR (ch);
- i++;
- }
+ {
+ /* This function is more complicated than necessary for the sake
+ of speed. */
+ scm_t_wchar *buf = scm_malloc (clen * sizeof (scm_t_wchar));
+ int wide = 0;
+ i = 0;
+ while (i < clen)
+ {
+ ch = scm_call_1 (proc, scm_from_size_t (i));
+ if (!SCM_CHARP (ch))
+ {
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
+ }
+ if (SCM_CHAR (ch) > 255)
+ wide = 1;
+ buf[i] = SCM_CHAR (ch);
+ i++;
+ }
+ if (wide)
+ {
+ scm_t_wchar *wbuf = NULL;
+ res = scm_i_make_wide_string (clen, &wbuf, 0);
+ memcpy (wbuf, buf, clen * sizeof (scm_t_wchar));
+ free (buf);
+ }
+ else
+ {
+ char *nbuf = NULL;
+ res = scm_i_make_string (clen, &nbuf, 0);
+ for (i = 0; i < clen; i ++)
+ nbuf[i] = (unsigned char) buf[i];
+ free (buf);
+ }
+ }
+
return res;
}
#undef FUNC_NAME
"Convert the string @var{str} into a list of characters.")
#define FUNC_NAME s_scm_substring_to_list
{
- const char *cstr;
size_t cstart, cend;
+ int narrow;
SCM result = SCM_EOL;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
- while (cstart < cend)
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
+
+ /* This explicit narrow/wide logic (instead of just using
+ scm_i_string_ref) is for speed optimizaion. */
+ narrow = scm_i_is_narrow_string (str);
+ if (narrow)
{
- cend--;
- result = scm_cons (SCM_MAKE_CHAR (cstr[cend]), result);
- cstr = scm_i_string_chars (str);
+ const char *buf = scm_i_string_chars (str);
+ while (cstart < cend)
+ {
+ cend--;
+ result = scm_cons (SCM_MAKE_CHAR (buf[cend]), result);
+ }
+ }
+ else
+ {
+ const scm_t_wchar *buf = scm_i_string_wide_chars (str);
+ while (cstart < cend)
+ {
+ cend--;
+ result = scm_cons (SCM_MAKE_CHAR (buf[cend]), result);
+ }
}
scm_remember_upto_here_1 (str);
return result;
#define FUNC_NAME s_scm_reverse_list_to_string
{
SCM result;
- long i = scm_ilength (chrs);
+ long i = scm_ilength (chrs), j;
char *data;
if (i < 0)
SCM_WRONG_TYPE_ARG (1, chrs);
- result = scm_i_make_string (i, &data);
+ result = scm_i_make_string (i, &data, 0);
{
-
- data += i;
- while (i > 0 && scm_is_pair (chrs))
+ SCM rest;
+ rest = chrs;
+ j = 0;
+ while (j < i && scm_is_pair (rest))
{
- SCM elt = SCM_CAR (chrs);
-
- SCM_VALIDATE_CHAR (SCM_ARGn, elt);
- data--;
- *data = SCM_CHAR (elt);
- chrs = SCM_CDR (chrs);
- i--;
+ SCM elt = SCM_CAR (rest);
+ SCM_VALIDATE_CHAR (SCM_ARGn, elt);
+ j++;
+ rest = SCM_CDR (rest);
}
+ rest = chrs;
+ j = i;
+ result = scm_i_string_start_writing (result);
+ while (j > 0 && scm_is_pair (rest))
+ {
+ SCM elt = SCM_CAR (rest);
+ scm_i_string_set_x (result, j-1, SCM_CHAR (elt));
+ rest = SCM_CDR (rest);
+ j--;
+ }
+ scm_i_string_stop_writing ();
}
return result;
SCM_SYMBOL (scm_sym_suffix, "suffix");
SCM_SYMBOL (scm_sym_prefix, "prefix");
-static void
-append_string (char **sp, size_t *lp, SCM str)
-{
- size_t len;
- len = scm_c_string_length (str);
- if (len > *lp)
- len = *lp;
- memcpy (*sp, scm_i_string_chars (str), len);
- *lp -= len;
- *sp += len;
-}
-
SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
(SCM ls, SCM delimiter, SCM grammar),
"Append the string in the string list @var{ls}, using the string\n"
- "@var{delim} as a delimiter between the elements of @var{ls}.\n"
+ "@var{delimiter} as a delimiter between the elements of @var{ls}.\n"
"@var{grammar} is a symbol which specifies how the delimiter is\n"
"placed between the strings, and defaults to the symbol\n"
"@code{infix}.\n"
SCM result;
int gram = GRAM_INFIX;
size_t del_len = 0;
- size_t len = 0;
- char *p;
long strings = scm_ilength (ls);
/* Validate the string list. */
del_len = 1;
}
else
- del_len = scm_c_string_length (delimiter);
+ {
+ SCM_VALIDATE_STRING (2, delimiter);
+ del_len = scm_i_string_length (delimiter);
+ }
/* Validate the grammar symbol and remember the grammar. */
if (SCM_UNBNDP (grammar))
else
SCM_WRONG_TYPE_ARG (3, grammar);
- /* Check grammar constraints and calculate the space required for
- the delimiter(s). */
- switch (gram)
- {
- case GRAM_INFIX:
- if (!scm_is_null (ls))
- len = (strings > 0) ? ((strings - 1) * del_len) : 0;
- break;
- case GRAM_STRICT_INFIX:
- if (strings == 0)
- SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
- SCM_EOL);
- len = (strings - 1) * del_len;
- break;
- default:
- len = strings * del_len;
- break;
- }
+ /* Check grammar constraints. */
+ if (strings == 0 && gram == GRAM_STRICT_INFIX)
+ SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
+ SCM_EOL);
- tmp = ls;
- while (scm_is_pair (tmp))
- {
- len += scm_c_string_length (SCM_CAR (tmp));
- tmp = SCM_CDR (tmp);
- }
-
- result = scm_i_make_string (len, &p);
+ result = scm_i_make_string (0, NULL, 0);
tmp = ls;
switch (gram)
case GRAM_STRICT_INFIX:
while (scm_is_pair (tmp))
{
- append_string (&p, &len, SCM_CAR (tmp));
+ result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
if (!scm_is_null (SCM_CDR (tmp)) && del_len > 0)
- append_string (&p, &len, delimiter);
+ result = scm_string_append (scm_list_2 (result, delimiter));
tmp = SCM_CDR (tmp);
}
break;
case GRAM_SUFFIX:
while (scm_is_pair (tmp))
{
- append_string (&p, &len, SCM_CAR (tmp));
+ result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
if (del_len > 0)
- append_string (&p, &len, delimiter);
+ result = scm_string_append (scm_list_2 (result, delimiter));
tmp = SCM_CDR (tmp);
}
break;
while (scm_is_pair (tmp))
{
if (del_len > 0)
- append_string (&p, &len, delimiter);
- append_string (&p, &len, SCM_CAR (tmp));
+ result = scm_string_append (scm_list_2 (result, delimiter));
+ result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
tmp = SCM_CDR (tmp);
}
break;
"@var{str} which is copied.")
#define FUNC_NAME s_scm_srfi13_substring_copy
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
- return scm_c_substring_copy (str, cstart, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
+ return scm_i_substring_copy (str, cstart, cend);
}
#undef FUNC_NAME
SCM
scm_string_copy (SCM str)
{
- return scm_c_substring (str, 0, scm_c_string_length (str));
+ if (!scm_is_string (str))
+ scm_wrong_type_arg ("scm_string_copy", 0, str);
+
+ return scm_i_substring (str, 0, scm_i_string_length (str));
}
SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
"string.")
#define FUNC_NAME s_scm_string_copy_x
{
- const char *cstr;
- char *ctarget;
- size_t cstart, cend, ctstart, dummy, len;
+ size_t cstart, cend, ctstart, dummy, len, i;
SCM sdummy = SCM_UNDEFINED;
MY_VALIDATE_SUBSTRING_SPEC (1, target,
2, tstart, ctstart,
2, sdummy, dummy);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
- 4, start, cstart,
- 5, end, cend);
- len = cend - cstart;
- SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
-
- ctarget = scm_i_string_writable_chars (target);
- memmove (ctarget + ctstart, cstr + cstart, len);
- scm_i_string_stop_writing ();
- scm_remember_upto_here_1 (target);
+ MY_VALIDATE_SUBSTRING_SPEC (3, s,
+ 4, start, cstart,
+ 5, end, cend);
+ if (cstart < cend)
+ {
+ len = cend - cstart;
+ SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
+
+ target = scm_i_string_start_writing (target);
+ for (i = 0; i < cend - cstart; i++)
+ {
+ scm_i_string_set_x (target, ctstart + i,
+ scm_i_string_ref (s, cstart + i));
+ }
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (target);
+ }
return SCM_UNSPECIFIED;
}
"string is longer than @var{len}, it is truncated on the right.")
#define FUNC_NAME s_scm_string_pad
{
- char cchr;
size_t cstart, cend, clen;
MY_VALIDATE_SUBSTRING_SPEC (1, s,
clen = scm_to_size_t (len);
if (SCM_UNBNDP (chr))
- cchr = ' ';
+ chr = SCM_MAKE_CHAR (' ');
else
{
SCM_VALIDATE_CHAR (3, chr);
- cchr = SCM_CHAR (chr);
}
if (clen < (cend - cstart))
- return scm_c_substring (s, cend - clen, cend);
+ return scm_i_substring (s, cend - clen, cend);
else
{
SCM result;
- char *dst;
-
- result = scm_i_make_string (clen, &dst);
- memset (dst, cchr, (clen - (cend - cstart)));
- memmove (dst + clen - (cend - cstart),
- scm_i_string_chars (s) + cstart, cend - cstart);
+ result = (scm_string_append
+ (scm_list_2 (scm_c_make_string (clen - (cend - cstart), chr),
+ scm_i_substring (s, cstart, cend))));
return result;
}
}
"string is longer than @var{len}, it is truncated on the left.")
#define FUNC_NAME s_scm_string_pad_right
{
- char cchr;
size_t cstart, cend, clen;
MY_VALIDATE_SUBSTRING_SPEC (1, s,
clen = scm_to_size_t (len);
if (SCM_UNBNDP (chr))
- cchr = ' ';
+ chr = SCM_MAKE_CHAR (' ');
else
{
SCM_VALIDATE_CHAR (3, chr);
- cchr = SCM_CHAR (chr);
}
if (clen < (cend - cstart))
- return scm_c_substring (s, cstart, cstart + clen);
+ return scm_i_substring (s, cstart, cstart + clen);
else
{
SCM result;
- char *dst;
- result = scm_i_make_string (clen, &dst);
- memset (dst + (cend - cstart), cchr, clen - (cend - cstart));
- memmove (dst, scm_i_string_chars (s) + cstart, cend - cstart);
+ result = (scm_string_append
+ (scm_list_2 (scm_i_substring (s, cstart, cend),
+ scm_c_make_string (clen - (cend - cstart), chr))));
+
return result;
}
}
"trimmed.")
#define FUNC_NAME s_scm_string_trim
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
- if (SCM_UNBNDP (char_pred))
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_UNBNDP (char_pred)
+ || scm_is_eq (char_pred, scm_char_set_whitespace))
{
while (cstart < cend)
{
- if (!isspace((int) (unsigned char) cstr[cstart]))
+ if (!uc_is_c_whitespace (scm_i_string_ref (s, cstart)))
break;
cstart++;
}
}
else if (SCM_CHARP (char_pred))
{
- char chr = SCM_CHAR (char_pred);
while (cstart < cend)
{
- if (chr != cstr[cstart])
+ if (scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred))
break;
cstart++;
}
{
while (cstart < cend)
{
- if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ if (!REF_IN_CHARSET (s, cstart, char_pred))
break;
cstart++;
}
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
break;
- cstr = scm_i_string_chars (s);
cstart++;
}
}
- return scm_c_substring (s, cstart, cend);
+ return scm_i_substring (s, cstart, cend);
}
#undef FUNC_NAME
SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0,
(SCM s, SCM char_pred, SCM start, SCM end),
- "Trim @var{s} by skipping over all characters on the rightt\n"
+ "Trim @var{s} by skipping over all characters on the right\n"
"that satisfy the parameter @var{char_pred}:\n"
"\n"
"@itemize @bullet\n"
"trimmed.")
#define FUNC_NAME s_scm_string_trim_right
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
- if (SCM_UNBNDP (char_pred))
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_UNBNDP (char_pred)
+ || scm_is_eq (char_pred, scm_char_set_whitespace))
{
while (cstart < cend)
{
- if (!isspace((int) (unsigned char) cstr[cend - 1]))
+ if (!uc_is_c_whitespace (scm_i_string_ref (s, cend - 1)))
break;
cend--;
}
}
else if (SCM_CHARP (char_pred))
{
- char chr = SCM_CHAR (char_pred);
while (cstart < cend)
{
- if (chr != cstr[cend - 1])
+ if (scm_i_string_ref (s, cend - 1) != SCM_CHAR (char_pred))
break;
cend--;
}
{
while (cstart < cend)
{
- if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1]))
+ if (!REF_IN_CHARSET (s, cend-1, char_pred))
break;
cend--;
}
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
if (scm_is_false (res))
break;
- cstr = scm_i_string_chars (s);
cend--;
}
}
- return scm_c_substring (s, cstart, cend);
+ return scm_i_substring (s, cstart, cend);
}
#undef FUNC_NAME
"trimmed.")
#define FUNC_NAME s_scm_string_trim_both
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
- if (SCM_UNBNDP (char_pred))
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_UNBNDP (char_pred)
+ || scm_is_eq (char_pred, scm_char_set_whitespace))
{
while (cstart < cend)
{
- if (!isspace((int) (unsigned char) cstr[cstart]))
+ if (!uc_is_c_whitespace (scm_i_string_ref (s, cstart)))
break;
cstart++;
}
while (cstart < cend)
{
- if (!isspace((int) (unsigned char) cstr[cend - 1]))
+ if (!uc_is_c_whitespace (scm_i_string_ref (s, cend - 1)))
break;
cend--;
}
}
else if (SCM_CHARP (char_pred))
{
- char chr = SCM_CHAR (char_pred);
while (cstart < cend)
{
- if (chr != cstr[cstart])
+ if (scm_i_string_ref (s, cstart) != SCM_CHAR(char_pred))
break;
cstart++;
}
while (cstart < cend)
{
- if (chr != cstr[cend - 1])
+ if (scm_i_string_ref (s, cend - 1) != SCM_CHAR (char_pred))
break;
cend--;
}
{
while (cstart < cend)
{
- if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ if (!REF_IN_CHARSET (s, cstart, char_pred))
break;
cstart++;
}
while (cstart < cend)
{
- if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1]))
+ if (!REF_IN_CHARSET (s, cend-1, char_pred))
break;
cend--;
}
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
break;
- cstr = scm_i_string_chars (s);
cstart++;
}
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
if (scm_is_false (res))
break;
- cstr = scm_i_string_chars (s);
cend--;
}
}
- return scm_c_substring (s, cstart, cend);
+ return scm_i_substring (s, cstart, cend);
}
#undef FUNC_NAME
"returns an unspecified value.")
#define FUNC_NAME s_scm_substring_fill_x
{
- char *cstr;
size_t cstart, cend;
- int c;
size_t k;
/* Older versions of Guile provided the function
MY_VALIDATE_SUBSTRING_SPEC (1, str,
3, start, cstart,
4, end, cend);
- SCM_VALIDATE_CHAR_COPY (2, chr, c);
+ SCM_VALIDATE_CHAR (2, chr);
- cstr = scm_i_string_writable_chars (str);
- for (k = cstart; k < cend; k++)
- cstr[k] = c;
- scm_i_string_stop_writing ();
- scm_remember_upto_here_1 (str);
+ if (cstart < cend)
+ {
+ str = scm_i_string_start_writing (str);
+ for (k = cstart; k < cend; k++)
+ scm_i_string_set_x (str, k, SCM_CHAR (chr));
+ scm_i_string_stop_writing ();
+ }
return SCM_UNSPECIFIED;
}
"@var{i} is the first position that does not match.")
#define FUNC_NAME s_scm_string_compare
{
- const unsigned char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
SCM proc;
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 6, start1, cstart1,
- 7, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 8, start2, cstart2,
- 9, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 6, start1, cstart1,
+ 7, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 8, start2, cstart2,
+ 9, end2, cend2);
SCM_VALIDATE_PROC (3, proc_lt);
SCM_VALIDATE_PROC (4, proc_eq);
SCM_VALIDATE_PROC (5, proc_gt);
while (cstart1 < cend1 && cstart2 < cend2)
{
- if (cstr1[cstart1] < cstr2[cstart2])
+ if (scm_i_string_ref (s1, cstart1)
+ < scm_i_string_ref (s2, cstart2))
{
proc = proc_lt;
goto ret;
}
- else if (cstr1[cstart1] > cstr2[cstart2])
+ else if (scm_i_string_ref (s1, cstart1)
+ > scm_i_string_ref (s2, cstart2))
{
proc = proc_gt;
goto ret;
"equal to, or greater than @var{s2}. The mismatch index is the\n"
"largest index @var{i} such that for every 0 <= @var{j} <\n"
"@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
- "@var{i} is the first position that does not match. The\n"
- "character comparison is done case-insensitively.")
+ "@var{i} is the first position where the lowercased letters \n"
+ "do not match.\n")
#define FUNC_NAME s_scm_string_compare_ci
{
- const unsigned char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
SCM proc;
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 6, start1, cstart1,
- 7, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 8, start2, cstart2,
- 9, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 6, start1, cstart1,
+ 7, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 8, start2, cstart2,
+ 9, end2, cend2);
SCM_VALIDATE_PROC (3, proc_lt);
SCM_VALIDATE_PROC (4, proc_eq);
SCM_VALIDATE_PROC (5, proc_gt);
while (cstart1 < cend1 && cstart2 < cend2)
{
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
+ if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)))
+ < uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))))
{
proc = proc_lt;
goto ret;
}
- else if (scm_c_downcase (cstr1[cstart1])
- > scm_c_downcase (cstr2[cstart2]))
+ else if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)))
+ > uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))))
{
proc = proc_gt;
goto ret;
}
#undef FUNC_NAME
-
-SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
- "value otherwise.")
-#define FUNC_NAME s_scm_string_eq
+/* This function compares two substrings, S1 from START1 to END1 and
+ S2 from START2 to END2, possibly case insensitively, and returns
+ one of the parameters LESSTHAN, GREATERTHAN, SHORTER, LONGER, or
+ EQUAL depending if S1 is less than S2, greater than S2, shorter,
+ longer, or equal. */
+static SCM
+compare_strings (const char *fname, int case_insensitive,
+ SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2,
+ SCM lessthan, SCM greaterthan, SCM shorter, SCM longer, SCM equal)
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
+ SCM ret;
+ scm_t_wchar a, b;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname, 1, s1,
3, start1, cstart1,
4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname, 2, s2,
5, start2, cstart2,
6, end2, cend2);
- if ((cend1 - cstart1) != (cend2 - cstart2))
- goto false;
-
- while (cstart1 < cend1)
+ while (cstart1 < cend1 && cstart2 < cend2)
{
- if (cstr1[cstart1] < cstr2[cstart2])
- goto false;
- else if (cstr1[cstart1] > cstr2[cstart2])
- goto false;
+ if (case_insensitive)
+ {
+ a = uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)));
+ b = uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2)));
+ }
+ else
+ {
+ a = scm_i_string_ref (s1, cstart1);
+ b = scm_i_string_ref (s2, cstart2);
+ }
+ if (a < b)
+ {
+ ret = lessthan;
+ goto done;
+ }
+ else if (a > b)
+ {
+ ret = greaterthan;
+ goto done;
+ }
cstart1++;
cstart2++;
}
-
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
+ if (cstart1 < cend1)
+ {
+ ret = longer;
+ goto done;
+ }
+ else if (cstart2 < cend2)
+ {
+ ret = shorter;
+ goto done;
+ }
+ else
+ {
+ ret = equal;
+ goto done;
+ }
- false:
+ done:
scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return ret;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0,
+SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0,
(SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
+ "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
"value otherwise.")
-#define FUNC_NAME s_scm_string_neq
+#define FUNC_NAME s_scm_string_eq
{
- const char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
+ if (SCM_LIKELY (scm_is_string (s1) && scm_is_string (s2) &&
+ scm_i_is_narrow_string (s1) == scm_i_is_narrow_string (s2)
+ && SCM_UNBNDP (start1) && SCM_UNBNDP (end1)
+ && SCM_UNBNDP (start2) && SCM_UNBNDP (end2)))
+ {
+ /* Fast path for this common case, which avoids the repeated calls to
+ `scm_i_string_ref'. */
+ size_t len1, len2;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ len1 = scm_i_string_length (s1);
+ len2 = scm_i_string_length (s2);
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (cstr1[cstart1] < cstr2[cstart2])
- goto true;
- else if (cstr1[cstart1] > cstr2[cstart2])
- goto true;
- cstart1++;
- cstart2++;
+ if (len1 != len2)
+ return SCM_BOOL_F;
+ else
+ {
+ if (!scm_i_is_narrow_string (s1))
+ len1 *= 4;
+
+ return scm_from_bool (memcmp (scm_i_string_data (s1),
+ scm_i_string_data (s2),
+ len1) == 0);
+ }
}
- if (cstart1 < cend1)
- goto true;
- else if (cstart2 < cend2)
- goto true;
- else
- goto false;
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
+ return compare_strings (FUNC_NAME, 0,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_T);
+}
+#undef FUNC_NAME
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+
+SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
+ "value otherwise.")
+#define FUNC_NAME s_scm_string_neq
+{
+ return compare_strings (FUNC_NAME, 0,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_F);
}
#undef FUNC_NAME
"true value otherwise.")
#define FUNC_NAME s_scm_string_lt
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (cstr1[cstart1] < cstr2[cstart2])
- goto true;
- else if (cstr1[cstart1] > cstr2[cstart2])
- goto false;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto false;
- else if (cstart2 < cend2)
- goto true;
- else
- goto false;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 0,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_F);
}
#undef FUNC_NAME
"true value otherwise.")
#define FUNC_NAME s_scm_string_gt
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (cstr1[cstart1] < cstr2[cstart2])
- goto false;
- else if (cstr1[cstart1] > cstr2[cstart2])
- goto true;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto true;
- else if (cstart2 < cend2)
- goto false;
- else
- goto false;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 0,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F);
}
#undef FUNC_NAME
"value otherwise.")
#define FUNC_NAME s_scm_string_le
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (cstr1[cstart1] < cstr2[cstart2])
- goto true;
- else if (cstr1[cstart1] > cstr2[cstart2])
- goto false;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto false;
- else if (cstart2 < cend2)
- goto true;
- else
- goto true;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 0,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T);
}
#undef FUNC_NAME
"otherwise.")
#define FUNC_NAME s_scm_string_ge
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (cstr1[cstart1] < cstr2[cstart2])
- goto false;
- else if (cstr1[cstart1] > cstr2[cstart2])
- goto true;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto true;
- else if (cstart2 < cend2)
- goto false;
- else
- goto true;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 0,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_T);
}
#undef FUNC_NAME
"case-insensitively.")
#define FUNC_NAME s_scm_string_ci_eq
{
- const char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
- goto false;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- goto false;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto false;
- else if (cstart2 < cend2)
- goto false;
- else
- goto true;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 1,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_T);
}
#undef FUNC_NAME
"case-insensitively.")
#define FUNC_NAME s_scm_string_ci_neq
{
- const char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
- goto true;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- goto true;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto true;
- else if (cstart2 < cend2)
- goto true;
- else
- goto false;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 1,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_F);
}
#undef FUNC_NAME
"case-insensitively.")
#define FUNC_NAME s_scm_string_ci_lt
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
- goto true;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- goto false;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto false;
- else if (cstart2 < cend2)
- goto true;
- else
- goto false;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 1,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_F);
}
#undef FUNC_NAME
"case-insensitively.")
#define FUNC_NAME s_scm_string_ci_gt
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
- goto false;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- goto true;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto true;
- else if (cstart2 < cend2)
- goto false;
- else
- goto false;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 1,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F);
}
#undef FUNC_NAME
"case-insensitively.")
#define FUNC_NAME s_scm_string_ci_le
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
- goto true;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- goto false;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto false;
- else if (cstart2 < cend2)
- goto true;
- else
- goto true;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 1,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
- "otherwise. The character comparison is done\n"
- "case-insensitively.")
-#define FUNC_NAME s_scm_string_ci_ge
-{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
- goto false;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- goto true;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto true;
- else if (cstart2 < cend2)
- goto false;
- else
- goto true;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
+ "otherwise. The character comparison is done\n"
+ "case-insensitively.")
+#define FUNC_NAME s_scm_string_ci_ge
+{
+ return compare_strings (FUNC_NAME, 1,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_T);
}
#undef FUNC_NAME
SCM_DEFINE (scm_substring_hash, "string-hash", 1, 3, 0,
(SCM s, SCM bound, SCM start, SCM end),
- "Compute a hash value for @var{S}. the optional argument "
+ "Compute a hash value for @var{s}. the optional argument "
"@var{bound} is a non-negative exact "
"integer specifying the range of the hash function. "
"A positive value restricts the return value to the "
SCM_DEFINE (scm_substring_hash_ci, "string-hash-ci", 1, 3, 0,
(SCM s, SCM bound, SCM start, SCM end),
- "Compute a hash value for @var{S}. the optional argument "
+ "Compute a hash value for @var{s}. the optional argument "
"@var{bound} is a non-negative exact "
"integer specifying the range of the hash function. "
"A positive value restricts the return value to the "
"strings.")
#define FUNC_NAME s_scm_string_prefix_length
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
while (cstart1 < cend1 && cstart2 < cend2)
{
- if (cstr1[cstart1] != cstr2[cstart2])
+ if (scm_i_string_ref (s1, cstart1)
+ != scm_i_string_ref (s2, cstart2))
goto ret;
len++;
cstart1++;
"strings, ignoring character case.")
#define FUNC_NAME s_scm_string_prefix_length_ci
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
while (cstart1 < cend1 && cstart2 < cend2)
{
- if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2]))
+ if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)))
+ != uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))))
goto ret;
len++;
cstart1++;
"strings.")
#define FUNC_NAME s_scm_string_suffix_length
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
while (cstart1 < cend1 && cstart2 < cend2)
{
cend1--;
cend2--;
- if (cstr1[cend1] != cstr2[cend2])
+ if (scm_i_string_ref (s1, cend1)
+ != scm_i_string_ref (s2, cend2))
goto ret;
len++;
}
"strings, ignoring character case.")
#define FUNC_NAME s_scm_string_suffix_length_ci
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
while (cstart1 < cend1 && cstart2 < cend2)
{
cend1--;
cend2--;
- if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2]))
+ if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cend1)))
+ != uc_tolower (uc_toupper (scm_i_string_ref (s2, cend2))))
goto ret;
len++;
}
"Is @var{s1} a prefix of @var{s2}?")
#define FUNC_NAME s_scm_string_prefix_p
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0, len1;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
len1 = cend1 - cstart1;
while (cstart1 < cend1 && cstart2 < cend2)
{
- if (cstr1[cstart1] != cstr2[cstart2])
+ if (scm_i_string_ref (s1, cstart1)
+ != scm_i_string_ref (s2, cstart2))
goto ret;
len++;
cstart1++;
"Is @var{s1} a prefix of @var{s2}, ignoring character case?")
#define FUNC_NAME s_scm_string_prefix_ci_p
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0, len1;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
len1 = cend1 - cstart1;
while (cstart1 < cend1 && cstart2 < cend2)
{
- if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2]))
+ scm_t_wchar a = uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)));
+ scm_t_wchar b = uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2)));
+ if (a != b)
goto ret;
len++;
cstart1++;
"Is @var{s1} a suffix of @var{s2}?")
#define FUNC_NAME s_scm_string_suffix_p
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0, len1;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
len1 = cend1 - cstart1;
while (cstart1 < cend1 && cstart2 < cend2)
{
cend1--;
cend2--;
- if (cstr1[cend1] != cstr2[cend2])
+ if (scm_i_string_ref (s1, cend1)
+ != scm_i_string_ref (s2, cend2))
goto ret;
len++;
}
"Is @var{s1} a suffix of @var{s2}, ignoring character case?")
#define FUNC_NAME s_scm_string_suffix_ci_p
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0, len1;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
len1 = cend1 - cstart1;
while (cstart1 < cend1 && cstart2 < cend2)
{
cend1--;
cend2--;
- if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2]))
+ if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cend1)))
+ != uc_tolower (uc_toupper (scm_i_string_ref (s2, cend2))))
goto ret;
len++;
}
SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0,
(SCM s, SCM char_pred, SCM start, SCM end),
"Search through the string @var{s} from left to right, returning\n"
- "the index of the first occurence of a character which\n"
+ "the index of the first occurrence of a character which\n"
"\n"
"@itemize @bullet\n"
"@item\n"
"equals @var{char_pred}, if it is character,\n"
"\n"
"@item\n"
- "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
+ "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
"\n"
"@item\n"
"is in the set @var{char_pred}, if it is a character set.\n"
- "@end itemize")
+ "@end itemize\n\n"
+ "Return @code{#f} if no match is found.")
#define FUNC_NAME s_scm_string_index
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- char cchr = SCM_CHAR (char_pred);
while (cstart < cend)
{
- if (cchr == cstr[cstart])
+ if (scm_i_string_ref (s, cstart) == SCM_CHAR (char_pred))
goto found;
cstart++;
}
{
while (cstart < cend)
{
- if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ if (REF_IN_CHARSET (s, cstart, char_pred))
goto found;
cstart++;
}
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res))
goto found;
- cstr = scm_i_string_chars (s);
cstart++;
}
}
SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0,
(SCM s, SCM char_pred, SCM start, SCM end),
"Search through the string @var{s} from right to left, returning\n"
- "the index of the last occurence of a character which\n"
+ "the index of the last occurrence of a character which\n"
"\n"
"@itemize @bullet\n"
"@item\n"
"equals @var{char_pred}, if it is character,\n"
"\n"
"@item\n"
- "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
+ "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
"\n"
"@item\n"
"is in the set if @var{char_pred} is a character set.\n"
- "@end itemize")
+ "@end itemize\n\n"
+ "Return @code{#f} if no match is found.")
#define FUNC_NAME s_scm_string_index_right
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- char cchr = SCM_CHAR (char_pred);
while (cstart < cend)
{
cend--;
- if (cchr == cstr[cend])
+ if (scm_i_string_ref (s, cend) == SCM_CHAR (char_pred))
goto found;
}
}
while (cstart < cend)
{
cend--;
- if (SCM_CHARSET_GET (char_pred, cstr[cend]))
+ if (REF_IN_CHARSET (s, cend, char_pred))
goto found;
}
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
cend--;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend]));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
if (scm_is_true (res))
goto found;
- cstr = scm_i_string_chars (s);
}
}
SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0,
(SCM s, SCM char_pred, SCM start, SCM end),
"Search through the string @var{s} from right to left, returning\n"
- "the index of the last occurence of a character which\n"
+ "the index of the last occurrence of a character which\n"
"\n"
"@itemize @bullet\n"
"@item\n"
"equals @var{char_pred}, if it is character,\n"
"\n"
"@item\n"
- "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
+ "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
"\n"
"@item\n"
"is in the set if @var{char_pred} is a character set.\n"
- "@end itemize")
+ "@end itemize\n\n"
+ "Return @code{#f} if no match is found.")
#define FUNC_NAME s_scm_string_rindex
{
return scm_string_index_right (s, char_pred, start, end);
SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0,
(SCM s, SCM char_pred, SCM start, SCM end),
"Search through the string @var{s} from left to right, returning\n"
- "the index of the first occurence of a character which\n"
+ "the index of the first occurrence of a character which\n"
"\n"
"@itemize @bullet\n"
"@item\n"
"does not equal @var{char_pred}, if it is character,\n"
"\n"
"@item\n"
- "does not satisify the predicate @var{char_pred}, if it is a\n"
+ "does not satisfy the predicate @var{char_pred}, if it is a\n"
"procedure,\n"
"\n"
"@item\n"
"@end itemize")
#define FUNC_NAME s_scm_string_skip
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- char cchr = SCM_CHAR (char_pred);
while (cstart < cend)
{
- if (cchr != cstr[cstart])
+ if (scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred))
goto found;
cstart++;
}
{
while (cstart < cend)
{
- if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ if (!REF_IN_CHARSET (s, cstart, char_pred))
goto found;
cstart++;
}
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
goto found;
- cstr = scm_i_string_chars (s);
cstart++;
}
}
SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0,
(SCM s, SCM char_pred, SCM start, SCM end),
"Search through the string @var{s} from right to left, returning\n"
- "the index of the last occurence of a character which\n"
+ "the index of the last occurrence of a character which\n"
"\n"
"@itemize @bullet\n"
"@item\n"
"@end itemize")
#define FUNC_NAME s_scm_string_skip_right
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- char cchr = SCM_CHAR (char_pred);
while (cstart < cend)
{
cend--;
- if (cchr != cstr[cend])
+ if (scm_i_string_ref (s, cend) != SCM_CHAR (char_pred))
goto found;
}
}
while (cstart < cend)
{
cend--;
- if (!SCM_CHARSET_GET (char_pred, cstr[cend]))
+ if (!REF_IN_CHARSET (s, cend, char_pred))
goto found;
}
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
cend--;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend]));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
if (scm_is_false (res))
goto found;
- cstr = scm_i_string_chars (s);
}
}
"equals @var{char_pred}, if it is character,\n"
"\n"
"@item\n"
- "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
+ "satisfies the predicate @var{char_pred}, if it is a procedure.\n"
"\n"
"@item\n"
"is in the set @var{char_pred}, if it is a character set.\n"
"@end itemize")
#define FUNC_NAME s_scm_string_count
{
- const char *cstr;
size_t cstart, cend;
size_t count = 0;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- char cchr = SCM_CHAR (char_pred);
while (cstart < cend)
{
- if (cchr == cstr[cstart])
+ if (scm_i_string_ref (s, cstart) == SCM_CHAR(char_pred))
count++;
cstart++;
}
{
while (cstart < cend)
{
- if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ if (REF_IN_CHARSET (s, cstart, char_pred))
count++;
cstart++;
}
}
else
{
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res))
count++;
- cstr = scm_i_string_chars (s);
cstart++;
}
}
"indicated substrings.")
#define FUNC_NAME s_scm_string_contains
{
- const char *cs1, * cs2;
size_t cstart1, cend1, cstart2, cend2;
size_t len2, i, j;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
len2 = cend2 - cstart2;
if (cend1 - cstart1 >= len2)
while (cstart1 <= cend1 - len2)
{
i = cstart1;
j = cstart2;
- while (i < cend1 && j < cend2 && cs1[i] == cs2[j])
+ while (i < cend1
+ && j < cend2
+ && (scm_i_string_ref (s1, i)
+ == scm_i_string_ref (s2, j)))
{
i++;
j++;
"case-insensitively.")
#define FUNC_NAME s_scm_string_contains_ci
{
- const char *cs1, * cs2;
size_t cstart1, cend1, cstart2, cend2;
size_t len2, i, j;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
len2 = cend2 - cstart2;
if (cend1 - cstart1 >= len2)
while (cstart1 <= cend1 - len2)
{
i = cstart1;
j = cstart2;
- while (i < cend1 && j < cend2 &&
- scm_c_downcase (cs1[i]) == scm_c_downcase (cs2[j]))
+ while (i < cend1
+ && j < cend2
+ && (uc_tolower (uc_toupper (scm_i_string_ref (s1, i)))
+ == uc_tolower (uc_toupper (scm_i_string_ref (s2, j)))))
{
i++;
j++;
#undef FUNC_NAME
-/* Helper function for the string uppercase conversion functions.
- * No argument checking is performed. */
+/* Helper function for the string uppercase conversion functions. */
static SCM
string_upcase_x (SCM v, size_t start, size_t end)
{
size_t k;
- char *dst;
- dst = scm_i_string_writable_chars (v);
- for (k = start; k < end; ++k)
- dst[k] = scm_c_upcase (dst[k]);
- scm_i_string_stop_writing ();
- scm_remember_upto_here_1 (v);
+ if (start < end)
+ {
+ v = scm_i_string_start_writing (v);
+ for (k = start; k < end; ++k)
+ scm_i_string_set_x (v, k, uc_toupper (scm_i_string_ref (v, k)));
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (v);
+ }
return v;
}
"@end lisp")
#define FUNC_NAME s_scm_substring_upcase_x
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
return string_upcase_x (str, cstart, cend);
}
#undef FUNC_NAME
"Upcase every character in @code{str}.")
#define FUNC_NAME s_scm_substring_upcase
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
return string_upcase_x (scm_string_copy (str), cstart, cend);
}
#undef FUNC_NAME
string_downcase_x (SCM v, size_t start, size_t end)
{
size_t k;
- char *dst;
- dst = scm_i_string_writable_chars (v);
- for (k = start; k < end; ++k)
- dst[k] = scm_c_downcase (dst[k]);
- scm_i_string_stop_writing ();
- scm_remember_upto_here_1 (v);
+ if (start < end)
+ {
+ v = scm_i_string_start_writing (v);
+ for (k = start; k < end; ++k)
+ scm_i_string_set_x (v, k, uc_tolower (scm_i_string_ref (v, k)));
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (v);
+ }
return v;
}
"@end lisp")
#define FUNC_NAME s_scm_substring_downcase_x
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
return string_downcase_x (str, cstart, cend);
}
#undef FUNC_NAME
"Downcase every character in @var{str}.")
#define FUNC_NAME s_scm_substring_downcase
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
return string_downcase_x (scm_string_copy (str), cstart, cend);
}
#undef FUNC_NAME
static SCM
string_titlecase_x (SCM str, size_t start, size_t end)
{
- unsigned char *sz;
+ SCM ch;
size_t i;
int in_word = 0;
- sz = (unsigned char *) scm_i_string_writable_chars (str);
- for(i = start; i < end; i++)
+ if (start < end)
{
- if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i]))))
- {
- if (!in_word)
- {
- sz[i] = scm_c_upcase(sz[i]);
- in_word = 1;
- }
- else
- {
- sz[i] = scm_c_downcase(sz[i]);
- }
- }
- else
- in_word = 0;
+ str = scm_i_string_start_writing (str);
+ for(i = start; i < end; i++)
+ {
+ ch = SCM_MAKE_CHAR (scm_i_string_ref (str, i));
+ if (scm_is_true (scm_char_alphabetic_p (ch)))
+ {
+ if (!in_word)
+ {
+ scm_i_string_set_x (str, i, uc_totitle (SCM_CHAR (ch)));
+ in_word = 1;
+ }
+ else
+ {
+ scm_i_string_set_x (str, i, uc_tolower (SCM_CHAR (ch)));
+ }
+ }
+ else
+ in_word = 0;
+ }
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (str);
}
- scm_i_string_stop_writing ();
- scm_remember_upto_here_1 (str);
return str;
}
"@var{str}.")
#define FUNC_NAME s_scm_string_titlecase_x
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
return string_titlecase_x (str, cstart, cend);
}
#undef FUNC_NAME
"Titlecase every first character in a word in @var{str}.")
#define FUNC_NAME s_scm_string_titlecase
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
return string_titlecase_x (scm_string_copy (str), cstart, cend);
}
#undef FUNC_NAME
/* Reverse the portion of @var{str} between str[cstart] (including)
and str[cend] excluding. */
static void
-string_reverse_x (char * str, size_t cstart, size_t cend)
+string_reverse_x (SCM str, size_t cstart, size_t cend)
{
- char tmp;
-
- if (cend > 0)
+ if (cstart < cend)
{
- cend--;
- while (cstart < cend)
- {
- tmp = str[cstart];
- str[cstart] = str[cend];
- str[cend] = tmp;
- cstart++;
- cend--;
- }
+ str = scm_i_string_start_writing (str);
+ if (cend > 0)
+ {
+ SCM tmp;
+
+ cend--;
+ while (cstart < cend)
+ {
+ tmp = SCM_MAKE_CHAR (scm_i_string_ref (str, cstart));
+ scm_i_string_set_x (str, cstart, scm_i_string_ref (str, cend));
+ scm_i_string_set_x (str, cend, SCM_CHAR (tmp));
+ cstart++;
+ cend--;
+ }
+ }
+ scm_i_string_stop_writing ();
}
}
"operate on.")
#define FUNC_NAME s_scm_string_reverse
{
- const char *cstr;
- char *ctarget;
size_t cstart, cend;
SCM result;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
result = scm_string_copy (str);
- ctarget = scm_i_string_writable_chars (result);
- string_reverse_x (ctarget, cstart, cend);
- scm_i_string_stop_writing ();
+ string_reverse_x (result, cstart, cend);
scm_remember_upto_here_1 (str);
return result;
}
"operate on. The return value is unspecified.")
#define FUNC_NAME s_scm_string_reverse_x
{
- char *cstr;
size_t cstart, cend;
MY_VALIDATE_SUBSTRING_SPEC (1, str,
2, start, cstart,
3, end, cend);
- cstr = scm_i_string_writable_chars (str);
- string_reverse_x (cstr, cstart, cend);
- scm_i_string_stop_writing ();
+ string_reverse_x (str, cstart, cend);
scm_remember_upto_here_1 (str);
return SCM_UNSPECIFIED;
}
for (l = rest; scm_is_pair (l); l = SCM_CDR (l))
{
s = SCM_CAR (l);
- if (scm_c_string_length (s) != 0)
+ if (!scm_is_string (s))
+ scm_wrong_type_arg (FUNC_NAME, 0, s);
+ if (scm_i_string_length (s) != 0)
{
if (seen_nonempty)
/* two or more non-empty strings, need full concat */
SCM_DEFINE (scm_string_concatenate_reverse_shared, "string-concatenate-reverse/shared", 1, 2, 0,
(SCM ls, SCM final_string, SCM end),
"Like @code{string-concatenate-reverse}, but the result may\n"
- "share memory with the the strings in the @var{ls} arguments.")
+ "share memory with the strings in the @var{ls} arguments.")
#define FUNC_NAME s_scm_string_concatenate_reverse_shared
{
/* Just call the non-sharing version. */
"string elements is not specified.")
#define FUNC_NAME s_scm_string_map
{
- char *p;
+ size_t p;
size_t cstart, cend;
SCM result;
- scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
MY_VALIDATE_SUBSTRING_SPEC (2, s,
3, start, cstart,
4, end, cend);
- result = scm_i_make_string (cend - cstart, &p);
+ result = scm_i_make_string (cend - cstart, NULL, 0);
+ p = 0;
while (cstart < cend)
{
- SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart));
+ SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart));
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
cstart++;
- *p++ = SCM_CHAR (ch);
+ result = scm_i_string_start_writing (result);
+ scm_i_string_set_x (result, p, SCM_CHAR (ch));
+ scm_i_string_stop_writing ();
+ p++;
}
+
return result;
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_string_map_x
{
size_t cstart, cend;
- scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
MY_VALIDATE_SUBSTRING_SPEC (2, s,
3, start, cstart,
4, end, cend);
while (cstart < cend)
{
- SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart));
+ SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart));
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
- scm_c_string_set_x (s, cstart, ch);
+ s = scm_i_string_start_writing (s);
+ scm_i_string_set_x (s, cstart, SCM_CHAR (ch));
+ scm_i_string_stop_writing ();
cstart++;
}
return SCM_UNSPECIFIED;
"result of @var{kons}' application.")
#define FUNC_NAME s_scm_string_fold
{
- const char *cstr;
size_t cstart, cend;
SCM result;
SCM_VALIDATE_PROC (1, kons);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
- 4, start, cstart,
- 5, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (3, s,
+ 4, start, cstart,
+ 5, end, cend);
result = knil;
while (cstart < cend)
{
- unsigned int c = (unsigned char) cstr[cstart];
- result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result);
- cstr = scm_i_string_chars (s);
+ result = scm_call_2 (kons, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)), result);
cstart++;
}
"result of @var{kons}' application.")
#define FUNC_NAME s_scm_string_fold_right
{
- const char *cstr;
size_t cstart, cend;
SCM result;
SCM_VALIDATE_PROC (1, kons);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
- 4, start, cstart,
- 5, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (3, s,
+ 4, start, cstart,
+ 5, end, cend);
result = knil;
while (cstart < cend)
{
- unsigned int c = (unsigned char) cstr[cend - 1];
- result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result);
- cstr = scm_i_string_chars (s);
+ result = scm_call_2 (kons, SCM_MAKE_CHAR (scm_i_string_ref (s, cend-1)), result);
cend--;
}
ans = base;
}
else
- ans = scm_i_make_string (0, NULL);
+ ans = scm_i_make_string (0, NULL, 0);
if (!SCM_UNBNDP (make_final))
SCM_VALIDATE_PROC (6, make_final);
while (scm_is_false (res))
{
SCM str;
- char *ptr;
+ size_t i = 0;
SCM ch = scm_call_1 (f, seed);
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
- str = scm_i_make_string (1, &ptr);
- *ptr = SCM_CHAR (ch);
+ str = scm_i_make_string (1, NULL, 0);
+ str = scm_i_string_start_writing (str);
+ scm_i_string_set_x (str, i, SCM_CHAR (ch));
+ scm_i_string_stop_writing ();
+ i++;
ans = scm_string_append (scm_list_2 (ans, str));
seed = scm_call_1 (g, seed);
ans = base;
}
else
- ans = scm_i_make_string (0, NULL);
+ ans = scm_i_make_string (0, NULL, 0);
if (!SCM_UNBNDP (make_final))
SCM_VALIDATE_PROC (6, make_final);
while (scm_is_false (res))
{
SCM str;
- char *ptr;
+ size_t i = 0;
SCM ch = scm_call_1 (f, seed);
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
- str = scm_i_make_string (1, &ptr);
- *ptr = SCM_CHAR (ch);
+ str = scm_i_make_string (1, NULL, 0);
+ str = scm_i_string_start_writing (str);
+ scm_i_string_set_x (str, i, SCM_CHAR (ch));
+ scm_i_string_stop_writing ();
+ i++;
ans = scm_string_append (scm_list_2 (str, ans));
seed = scm_call_1 (g, seed);
"return value is not specified.")
#define FUNC_NAME s_scm_string_for_each
{
- const char *cstr;
size_t cstart, cend;
- scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s,
+ 3, start, cstart,
+ 4, end, cend);
while (cstart < cend)
{
- unsigned int c = (unsigned char) cstr[cstart];
- proc_tramp (proc, SCM_MAKE_CHAR (c));
- cstr = scm_i_string_chars (s);
+ scm_call_1 (proc, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
cstart++;
}
#define FUNC_NAME s_scm_string_for_each_index
{
size_t cstart, cend;
- scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
- SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
MY_VALIDATE_SUBSTRING_SPEC (2, s,
3, start, cstart,
4, end, cend);
while (cstart < cend)
{
- proc_tramp (proc, scm_from_size_t (cstart));
+ scm_call_1 (proc, scm_from_size_t (cstart));
cstart++;
}
"defaults to @var{from} + (@var{end} - @var{start}).")
#define FUNC_NAME s_scm_xsubstring
{
- const char *cs;
- char *p;
+ size_t p;
size_t cstart, cend;
int cfrom, cto;
SCM result;
if (cstart == cend && cfrom != cto)
SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
- result = scm_i_make_string (cto - cfrom, &p);
+ result = scm_i_make_string (cto - cfrom, NULL, 0);
+ result = scm_i_string_start_writing (result);
- cs = scm_i_string_chars (s);
+ p = 0;
while (cfrom < cto)
{
size_t t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart);
if (cfrom < 0)
- *p = cs[(cend - cstart) - t];
+ scm_i_string_set_x (result, p,
+ scm_i_string_ref (s, (cend - cstart) - t));
else
- *p = cs[t];
+ scm_i_string_set_x (result, p, scm_i_string_ref (s, t));
cfrom++;
p++;
}
+ scm_i_string_stop_writing ();
scm_remember_upto_here_1 (s);
return result;
"cannot copy a string on top of itself.")
#define FUNC_NAME s_scm_string_xcopy_x
{
- char *p;
- const char *cs;
+ size_t p;
size_t ctstart, cstart, cend;
int csfrom, csto;
SCM dummy = SCM_UNDEFINED;
csto = csfrom + (cend - cstart);
else
csto = scm_to_int (sto);
- if (cstart == cend && csfrom != csto)
- SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
- SCM_ASSERT_RANGE (1, tstart,
- ctstart + (csto - csfrom) <= scm_i_string_length (target));
-
- p = scm_i_string_writable_chars (target) + ctstart;
- cs = scm_i_string_chars (s);
- while (csfrom < csto)
+ if (csfrom < csto)
{
- size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart);
- if (csfrom < 0)
- *p = cs[(cend - cstart) - t];
- else
- *p = cs[t];
- csfrom++;
- p++;
- }
- scm_i_string_stop_writing ();
+ if (cstart == cend)
+ SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
+ SCM_ASSERT_RANGE (1, tstart,
+ ctstart + (csto - csfrom) <= scm_i_string_length (target));
+
+ p = 0;
+ target = scm_i_string_start_writing (target);
+ while (csfrom < csto)
+ {
+ size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart);
+ if (csfrom < 0)
+ scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, (cend - cstart) - t));
+ else
+ scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, t));
+ csfrom++;
+ p++;
+ }
+ scm_i_string_stop_writing ();
- scm_remember_upto_here_2 (target, s);
+ scm_remember_upto_here_2 (target, s);
+ }
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
"@var{start2} @dots{} @var{end2} from @var{s2}.")
#define FUNC_NAME s_scm_string_replace
{
- const char *cstr1, *cstr2;
- char *p;
size_t cstart1, cend1, cstart2, cend2;
SCM result;
MY_VALIDATE_SUBSTRING_SPEC (2, s2,
5, start2, cstart2,
6, end2, cend2);
- result = scm_i_make_string (cstart1 + (cend2 - cstart2) +
- scm_i_string_length (s1) - cend1, &p);
- cstr1 = scm_i_string_chars (s1);
- cstr2 = scm_i_string_chars (s2);
- memmove (p, cstr1, cstart1 * sizeof (char));
- memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2) * sizeof (char));
- memmove (p + cstart1 + (cend2 - cstart2),
- cstr1 + cend1,
- (scm_i_string_length (s1) - cend1) * sizeof (char));
- scm_remember_upto_here_2 (s1, s2);
+ return (scm_string_append
+ (scm_list_3 (scm_i_substring (s1, 0, cstart1),
+ scm_i_substring (s2, cstart2, cend2),
+ scm_i_substring (s1, cend1, scm_i_string_length (s1)))));
return result;
}
#undef FUNC_NAME
"of @var{s}.")
#define FUNC_NAME s_scm_string_tokenize
{
- const char *cstr;
size_t cstart, cend;
SCM result = SCM_EOL;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_UNBNDP (token_set))
token_set = scm_char_set_graphic;
{
while (cstart < cend)
{
- if (SCM_CHARSET_GET (token_set, cstr[cend - 1]))
+ if (REF_IN_CHARSET (s, cend-1, token_set))
break;
cend--;
}
idx = cend;
while (cstart < cend)
{
- if (!SCM_CHARSET_GET (token_set, cstr[cend - 1]))
+ if (!REF_IN_CHARSET (s, cend-1, token_set))
break;
cend--;
}
- result = scm_cons (scm_c_substring (s, cend, idx), result);
- cstr = scm_i_string_chars (s);
+ result = scm_cons (scm_i_substring (s, cend, idx), result);
}
}
else
SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
(SCM str, SCM chr),
- "Split the string @var{str} into the a list of the substrings delimited\n"
+ "Split the string @var{str} into a list of the substrings delimited\n"
"by appearances of the character @var{chr}. Note that an empty substring\n"
"between separator characters will result in an empty string in the\n"
"result list.\n"
#define FUNC_NAME s_scm_string_split
{
long idx, last_idx;
- const char * p;
- char ch;
+ int narrow;
SCM res = SCM_EOL;
SCM_VALIDATE_STRING (1, str);
SCM_VALIDATE_CHAR (2, chr);
-
+
+ /* This is explicit wide/narrow logic (instead of using
+ scm_i_string_ref) is a speed optimization. */
idx = scm_i_string_length (str);
- p = scm_i_string_chars (str);
- ch = SCM_CHAR (chr);
- while (idx >= 0)
- {
- last_idx = idx;
- while (idx > 0 && p[idx - 1] != ch)
- idx--;
- if (idx >= 0)
- {
- res = scm_cons (scm_c_substring (str, idx, last_idx), res);
- p = scm_i_string_chars (str);
- idx--;
- }
+ narrow = scm_i_is_narrow_string (str);
+ if (narrow)
+ {
+ const char *buf = scm_i_string_chars (str);
+ while (idx >= 0)
+ {
+ last_idx = idx;
+ while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(chr))
+ idx--;
+ if (idx >= 0)
+ {
+ res = scm_cons (scm_i_substring (str, idx, last_idx), res);
+ idx--;
+ }
+ }
+ }
+ else
+ {
+ const scm_t_wchar *buf = scm_i_string_wide_chars (str);
+ while (idx >= 0)
+ {
+ last_idx = idx;
+ while (idx > 0 && buf[idx-1] != SCM_CHAR(chr))
+ idx--;
+ if (idx >= 0)
+ {
+ res = scm_cons (scm_i_substring (str, idx, last_idx), res);
+ idx--;
+ }
+ }
}
scm_remember_upto_here_1 (str);
return res;
SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
- (SCM s, SCM char_pred, SCM start, SCM end),
+ (SCM char_pred, SCM s, SCM start, SCM end),
"Filter the string @var{s}, retaining only those characters\n"
"which satisfy @var{char_pred}.\n"
"\n"
"membership.")
#define FUNC_NAME s_scm_string_filter
{
- const char *cstr;
size_t cstart, cend;
SCM result;
size_t idx;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+#if SCM_ENABLE_DEPRECATED == 1
+ if (scm_is_string (char_pred))
+ {
+ SCM tmp;
+
+ scm_c_issue_deprecation_warning
+ ("Guile used to use the wrong argument order for string-filter.\n"
+ "This call to string-filter had the arguments in the wrong order.\n"
+ "See SRFI-13 for more details. At some point we will remove this hack.");
+
+ tmp = char_pred;
+ char_pred = s;
+ s = tmp;
+ }
+#endif
+
+ MY_VALIDATE_SUBSTRING_SPEC (2, s,
+ 3, start, cstart,
+ 4, end, cend);
/* The explicit loops below stripping leading and trailing non-matches
mean we can return a substring if those are the only deletions, making
if (SCM_CHARP (char_pred))
{
size_t count;
- char chr;
-
- chr = SCM_CHAR (char_pred);
/* strip leading non-matches by incrementing cstart */
- while (cstart < cend && cstr[cstart] != chr)
+ while (cstart < cend && scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred))
cstart++;
/* strip trailing non-matches by decrementing cend */
- while (cend > cstart && cstr[cend-1] != chr)
+ while (cend > cstart && scm_i_string_ref (s, cend-1) != SCM_CHAR (char_pred))
cend--;
/* count chars to keep */
count = 0;
for (idx = cstart; idx < cend; idx++)
- if (cstr[idx] == chr)
+ if (scm_i_string_ref (s, idx) == SCM_CHAR (char_pred))
count++;
if (count == cend - cstart)
size_t count;
/* strip leading non-matches by incrementing cstart */
- while (cstart < cend && ! SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ while (cstart < cend && ! REF_IN_CHARSET (s, cstart, char_pred))
cstart++;
/* strip trailing non-matches by decrementing cend */
- while (cend > cstart && ! SCM_CHARSET_GET (char_pred, cstr[cend-1]))
+ while (cend > cstart && ! REF_IN_CHARSET (s, cend-1, char_pred))
cend--;
/* count chars to be kept */
count = 0;
for (idx = cstart; idx < cend; idx++)
- if (SCM_CHARSET_GET (char_pred, cstr[idx]))
+ if (REF_IN_CHARSET (s, idx, char_pred))
count++;
/* if whole of start to end kept then return substring */
goto result_substring;
else
{
- char *dst;
- result = scm_i_make_string (count, &dst);
- cstr = scm_i_string_chars (s);
+ size_t dst = 0;
+ result = scm_i_make_string (count, NULL, 0);
+ result = scm_i_string_start_writing (result);
/* decrement "count" in this loop as well as using idx, so that if
another thread is simultaneously changing "s" there's no chance
it'll make us copy more than count characters */
for (idx = cstart; idx < cend && count != 0; idx++)
{
- if (SCM_CHARSET_GET (char_pred, cstr[idx]))
+ if (REF_IN_CHARSET (s, idx, char_pred))
{
- *dst++ = cstr[idx];
+ scm_i_string_set_x (result, dst, scm_i_string_ref (s, idx));
+ dst ++;
count--;
}
}
+ scm_i_string_stop_writing ();
}
}
else
{
SCM ls = SCM_EOL;
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG1, FUNC_NAME);
idx = cstart;
while (idx < cend)
{
SCM res, ch;
- ch = SCM_MAKE_CHAR (cstr[idx]);
- res = pred_tramp (char_pred, ch);
+ ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx));
+ res = scm_call_1 (char_pred, ch);
if (scm_is_true (res))
ls = scm_cons (ch, ls);
- cstr = scm_i_string_chars (s);
idx++;
}
result = scm_reverse_list_to_string (ls);
SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
- (SCM s, SCM char_pred, SCM start, SCM end),
+ (SCM char_pred, SCM s, SCM start, SCM end),
"Delete characters satisfying @var{char_pred} from @var{s}.\n"
"\n"
"If @var{char_pred} is a procedure, it is applied to each\n"
"membership.")
#define FUNC_NAME s_scm_string_delete
{
- const char *cstr;
size_t cstart, cend;
SCM result;
size_t idx;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+#if SCM_ENABLE_DEPRECATED == 1
+ if (scm_is_string (char_pred))
+ {
+ SCM tmp;
+
+ scm_c_issue_deprecation_warning
+ ("Guile used to use the wrong argument order for string-delete.\n"
+ "This call to string-filter had the arguments in the wrong order.\n"
+ "See SRFI-13 for more details. At some point we will remove this hack.");
+
+ tmp = char_pred;
+ char_pred = s;
+ s = tmp;
+ }
+#endif
+
+ MY_VALIDATE_SUBSTRING_SPEC (2, s,
+ 3, start, cstart,
+ 4, end, cend);
/* The explicit loops below stripping leading and trailing matches mean we
can return a substring if those are the only deletions, making
if (SCM_CHARP (char_pred))
{
size_t count;
- char chr;
-
- chr = SCM_CHAR (char_pred);
/* strip leading matches by incrementing cstart */
- while (cstart < cend && cstr[cstart] == chr)
+ while (cstart < cend && scm_i_string_ref (s, cstart) == SCM_CHAR(char_pred))
cstart++;
/* strip trailing matches by decrementing cend */
- while (cend > cstart && cstr[cend-1] == chr)
+ while (cend > cstart && scm_i_string_ref (s, cend-1) == SCM_CHAR (char_pred))
cend--;
/* count chars to be kept */
count = 0;
for (idx = cstart; idx < cend; idx++)
- if (cstr[idx] != chr)
+ if (scm_i_string_ref (s, idx) != SCM_CHAR (char_pred))
count++;
if (count == cend - cstart)
}
else
{
+ int i = 0;
/* new string for retained portion */
- char *dst;
- result = scm_i_make_string (count, &dst);
- cstr = scm_i_string_chars (s);
-
+ result = scm_i_make_string (count, NULL, 0);
+ result = scm_i_string_start_writing (result);
/* decrement "count" in this loop as well as using idx, so that if
another thread is simultaneously changing "s" there's no chance
it'll make us copy more than count characters */
for (idx = cstart; idx < cend && count != 0; idx++)
{
- if (cstr[idx] != chr)
+ scm_t_wchar c = scm_i_string_ref (s, idx);
+ if (c != SCM_CHAR (char_pred))
{
- *dst++ = cstr[idx];
+ scm_i_string_set_x (result, i, c);
+ i++;
count--;
}
}
+ scm_i_string_stop_writing ();
}
}
else if (SCM_CHARSETP (char_pred))
size_t count;
/* strip leading matches by incrementing cstart */
- while (cstart < cend && SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ while (cstart < cend && REF_IN_CHARSET (s, cstart, char_pred))
cstart++;
/* strip trailing matches by decrementing cend */
- while (cend > cstart && SCM_CHARSET_GET (char_pred, cstr[cend-1]))
+ while (cend > cstart && REF_IN_CHARSET (s, cend-1, char_pred))
cend--;
/* count chars to be kept */
count = 0;
for (idx = cstart; idx < cend; idx++)
- if (! SCM_CHARSET_GET (char_pred, cstr[idx]))
+ if (!REF_IN_CHARSET (s, idx, char_pred))
count++;
if (count == cend - cstart)
goto result_substring;
else
{
+ size_t i = 0;
/* new string for retained portion */
- char *dst;
- result = scm_i_make_string (count, &dst);
- cstr = scm_i_string_chars (s);
+ result = scm_i_make_string (count, NULL, 0);
+ result = scm_i_string_start_writing (result);
/* decrement "count" in this loop as well as using idx, so that if
another thread is simultaneously changing "s" there's no chance
it'll make us copy more than count characters */
for (idx = cstart; idx < cend && count != 0; idx++)
{
- if (! SCM_CHARSET_GET (char_pred, cstr[idx]))
+ if (!REF_IN_CHARSET (s, idx, char_pred))
{
- *dst++ = cstr[idx];
+ scm_i_string_set_x (result, i, scm_i_string_ref (s, idx));
+ i++;
count--;
}
}
+ scm_i_string_stop_writing ();
}
}
else
{
SCM ls = SCM_EOL;
- scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
- SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG1, FUNC_NAME);
idx = cstart;
while (idx < cend)
{
- SCM res, ch = SCM_MAKE_CHAR (cstr[idx]);
- res = pred_tramp (char_pred, ch);
+ SCM res, ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx));
+ res = scm_call_1 (char_pred, ch);
if (scm_is_false (res))
ls = scm_cons (ch, ls);
- cstr = scm_i_string_chars (s);
idx++;
}
result = scm_reverse_list_to_string (ls);
HCoop / bpt / guile.git / blobdiff