/* srfi-13.c --- SRFI-13 procedures for Guile
*
- * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009 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
#include "libguile.h"
+#include <libguile/deprecation.h>
#include "libguile/srfi-13.h"
#include "libguile/srfi-14.h"
}
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,
+ res = scm_call_1 (char_pred,
SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res))
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,
+ res = scm_call_1 (char_pred,
SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
break;
size_t clen, i;
SCM res;
SCM ch;
- 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);
i = 0;
while (i < clen)
{
- ch = proc_tramp (proc, scm_from_size_t (i));
+ 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 (wide)
{
scm_t_wchar *wbuf = NULL;
- res = scm_i_make_wide_string (clen, &wbuf);
+ 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);
+ res = scm_i_make_string (clen, &nbuf, 0);
for (i = 0; i < clen; i ++)
nbuf[i] = (unsigned char) buf[i];
free (buf);
if (i < 0)
SCM_WRONG_TYPE_ARG (1, chrs);
- result = scm_i_make_string (i, &data);
+ result = scm_i_make_string (i, &data, 0);
{
SCM rest;
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"
"@item infix\n"
"Insert the separator between list elements. An empty string\n"
"will produce an empty list.\n"
- "@item string-infix\n"
+ "@item strict-infix\n"
"Like @code{infix}, but will raise an error if given the empty\n"
"list.\n"
"@item suffix\n"
"@end table")
#define FUNC_NAME s_scm_string_join
{
-#define GRAM_INFIX 0
-#define GRAM_STRICT_INFIX 1
-#define GRAM_SUFFIX 2
-#define GRAM_PREFIX 3
- SCM tmp;
- SCM result;
- int gram = GRAM_INFIX;
- size_t del_len = 0;
- long strings = scm_ilength (ls);
+ SCM append_list = SCM_EOL;
+ long list_len = scm_ilength (ls);
+ size_t delimiter_len = 0;
/* Validate the string list. */
- if (strings < 0)
+ if (list_len < 0)
SCM_WRONG_TYPE_ARG (1, ls);
/* Validate the delimiter and record its length. */
if (SCM_UNBNDP (delimiter))
{
delimiter = scm_from_locale_string (" ");
- del_len = 1;
+ delimiter_len = 1;
}
else
{
SCM_VALIDATE_STRING (2, delimiter);
- del_len = scm_i_string_length (delimiter);
+ delimiter_len = scm_i_string_length (delimiter);
}
- /* Validate the grammar symbol and remember the grammar. */
+ /* Validate the grammar symbol. */
if (SCM_UNBNDP (grammar))
- gram = GRAM_INFIX;
- else if (scm_is_eq (grammar, scm_sym_infix))
- gram = GRAM_INFIX;
- else if (scm_is_eq (grammar, scm_sym_strict_infix))
- gram = GRAM_STRICT_INFIX;
- else if (scm_is_eq (grammar, scm_sym_suffix))
- gram = GRAM_SUFFIX;
- else if (scm_is_eq (grammar, scm_sym_prefix))
- gram = GRAM_PREFIX;
- else
+ grammar = scm_sym_infix;
+ else if (!(scm_is_eq (grammar, scm_sym_infix)
+ || scm_is_eq (grammar, scm_sym_strict_infix)
+ || scm_is_eq (grammar, scm_sym_suffix)
+ || scm_is_eq (grammar, scm_sym_prefix)))
SCM_WRONG_TYPE_ARG (3, grammar);
- /* Check grammar constraints. */
- if (strings == 0 && gram == GRAM_STRICT_INFIX)
- SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
- SCM_EOL);
+ if (list_len == 0)
+ {
+ if (scm_is_eq (grammar, scm_sym_strict_infix))
+ SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
+ SCM_EOL);
+ else
+ /* Handle empty lists specially */
+ append_list = SCM_EOL;
+ }
+ else if (delimiter_len == 0)
+ /* Handle empty delimiters specially */
+ append_list = ls;
+ else
+ {
+ SCM *last_cdr_p = &append_list;
- result = scm_i_make_string (0, NULL);
+#define ADD_TO_APPEND_LIST(x) \
+ ((*last_cdr_p = scm_list_1 (x)), \
+ (last_cdr_p = SCM_CDRLOC (*last_cdr_p)))
- tmp = ls;
- switch (gram)
- {
- case GRAM_INFIX:
- case GRAM_STRICT_INFIX:
- while (scm_is_pair (tmp))
- {
- result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
- if (!scm_is_null (SCM_CDR (tmp)) && del_len > 0)
- result = scm_string_append (scm_list_2 (result, delimiter));
- tmp = SCM_CDR (tmp);
- }
- break;
- case GRAM_SUFFIX:
- while (scm_is_pair (tmp))
- {
- result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
- if (del_len > 0)
- result = scm_string_append (scm_list_2 (result, delimiter));
- tmp = SCM_CDR (tmp);
- }
- break;
- case GRAM_PREFIX:
- while (scm_is_pair (tmp))
- {
- if (del_len > 0)
- 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;
+ /* Build a list of strings to pass to 'string-append'.
+ Here we assume that 'ls' has at least one element. */
+
+ /* If using the 'prefix' grammar, start with the delimiter. */
+ if (scm_is_eq (grammar, scm_sym_prefix))
+ ADD_TO_APPEND_LIST (delimiter);
+
+ /* Handle the first element of 'ls' specially, so that in the loop
+ that follows we can unconditionally insert the delimiter before
+ every remaining element. */
+ ADD_TO_APPEND_LIST (SCM_CAR (ls));
+ ls = SCM_CDR (ls);
+
+ /* Insert the delimiter before every remaining element. */
+ while (scm_is_pair (ls))
+ {
+ ADD_TO_APPEND_LIST (delimiter);
+ ADD_TO_APPEND_LIST (SCM_CAR (ls));
+ ls = SCM_CDR (ls);
+ }
+
+ /* If using the 'suffix' grammar, add the delimiter to the end. */
+ if (scm_is_eq (grammar, scm_sym_suffix))
+ ADD_TO_APPEND_LIST (delimiter);
+
+#undef ADD_TO_APPEND_LIST
}
- return result;
-#undef GRAM_INFIX
-#undef GRAM_STRICT_INFIX
-#undef GRAM_SUFFIX
-#undef GRAM_PREFIX
+ /* Construct the final result. */
+ return scm_string_append (append_list);
}
#undef FUNC_NAME
MY_VALIDATE_SUBSTRING_SPEC (3, s,
4, start, cstart,
5, end, 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++)
+ if (cstart < cend)
{
- scm_i_string_set_x (target, ctstart + i,
- scm_i_string_ref (s, cstart + i));
+ len = cend - cstart;
+ SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
+
+ target = scm_i_string_start_writing (target);
+ if (ctstart < cstart)
+ {
+ for (i = 0; i < len; i++)
+ scm_i_string_set_x (target, ctstart + i,
+ scm_i_string_ref (s, cstart + i));
+ }
+ else
+ {
+ for (i = len; 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);
}
- scm_i_string_stop_writing ();
- scm_remember_upto_here_1 (target);
return SCM_UNSPECIFIED;
}
MY_VALIDATE_SUBSTRING_SPEC (1, s,
3, start, cstart,
4, end, cend);
- if (SCM_UNBNDP (char_pred))
+ if (SCM_UNBNDP (char_pred)
+ || scm_is_eq (char_pred, scm_char_set_whitespace))
{
while (cstart < 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 (scm_i_string_ref (s, cstart)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
break;
cstart++;
MY_VALIDATE_SUBSTRING_SPEC (1, s,
3, start, cstart,
4, end, cend);
- if (SCM_UNBNDP (char_pred))
+ if (SCM_UNBNDP (char_pred)
+ || scm_is_eq (char_pred, scm_char_set_whitespace))
{
while (cstart < 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 (scm_i_string_ref (s, cend - 1)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
if (scm_is_false (res))
break;
cend--;
MY_VALIDATE_SUBSTRING_SPEC (1, s,
3, start, cstart,
4, end, cend);
- if (SCM_UNBNDP (char_pred))
+ if (SCM_UNBNDP (char_pred)
+ || scm_is_eq (char_pred, scm_char_set_whitespace))
{
while (cstart < 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 (scm_i_string_ref (s, cstart)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
break;
cstart++;
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
if (scm_is_false (res))
break;
cend--;
4, end, cend);
SCM_VALIDATE_CHAR (2, chr);
-
- 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 ();
+ 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;
}
/* 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, LONGER, SHORTER, or
- EQUAL depending if S1 is less than S2, greater than S2, longer,
- shorter, or equal. */
+ 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 longer, SCM shorter, SCM equal)
+ SCM lessthan, SCM greaterthan, SCM shorter, SCM longer, SCM equal)
{
size_t cstart1, cend1, cstart2, cend2;
SCM ret;
"value otherwise.")
#define FUNC_NAME s_scm_string_eq
{
+ 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;
+
+ len1 = scm_i_string_length (s1);
+ len2 = scm_i_string_length (s2);
+
+ 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);
+ }
+ }
+
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);
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 "
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
{
size_t cstart, 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 (scm_i_string_ref (s, cstart)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res))
goto found;
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
{
size_t cstart, 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;
cend--;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
if (scm_is_true (res))
goto found;
}
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"
}
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 (scm_i_string_ref (s, cstart)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
goto found;
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"
}
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 (scm_i_string_ref (s, cend)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
if (scm_is_false (res))
goto found;
}
"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"
}
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 (scm_i_string_ref (s, cstart)));
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res))
count++;
cstart++;
{
size_t k;
- 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);
+ 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;
}
{
size_t k;
- 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);
+ 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;
}
size_t i;
int in_word = 0;
- str = scm_i_string_start_writing (str);
- for(i = start; i < end; i++)
+ if (start < end)
{
- 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_toupper (SCM_CHAR (ch)));
- in_word = 1;
- }
- else
- {
- scm_i_string_set_x (str, i, uc_tolower (SCM_CHAR (ch)));
- }
- }
- 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;
}
static void
string_reverse_x (SCM str, size_t cstart, size_t cend)
{
- SCM tmp;
-
- str = scm_i_string_start_writing (str);
- if (cend > 0)
+ if (cstart < cend)
{
- 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--;
- }
+ 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 ();
}
- scm_i_string_stop_writing ();
}
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. */
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, NULL);
+ 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++;
#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));
s = scm_i_string_start_writing (s);
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);
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, NULL);
+ 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 ();
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);
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, NULL);
+ 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 ();
#define FUNC_NAME s_scm_string_for_each
{
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_MAKE_CHAR (scm_i_string_ref (s, cstart)));
+ 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++;
}
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, NULL);
+ result = scm_i_make_string (cto - cfrom, NULL, 0);
result = scm_i_string_start_writing (result);
p = 0;
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 = 0;
- target = scm_i_string_start_writing (target);
- while (csfrom < csto)
+ if (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 ();
+ 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
#undef FUNC_NAME
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"
- "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"
+ (SCM str, SCM char_pred),
+ "Split the string @var{str} into a list of the substrings delimited\n"
+ "by appearances of characters that\n"
+ "\n"
+ "@itemize @bullet\n"
+ "@item\n"
+ "equal @var{char_pred}, if it is a character,\n"
+ "\n"
+ "@item\n"
+ "satisfy the predicate @var{char_pred}, if it is a procedure,\n"
+ "\n"
+ "@item\n"
+ "are in the set @var{char_pred}, if it is a character set.\n"
+ "@end itemize\n\n"
+ "Note that an empty substring between separator characters\n"
+ "will result in an empty string in the result list.\n"
"\n"
"@lisp\n"
"(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
"@end lisp")
#define FUNC_NAME s_scm_string_split
{
- long idx, last_idx;
- 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);
- narrow = scm_i_is_narrow_string (str);
- if (narrow)
+ if (SCM_CHARP (char_pred))
{
- const char *buf = scm_i_string_chars (str);
- while (idx >= 0)
+ long idx, last_idx;
+ int narrow;
+
+ /* This is explicit wide/narrow logic (instead of using
+ scm_i_string_ref) is a speed optimization. */
+ idx = scm_i_string_length (str);
+ narrow = scm_i_is_narrow_string (str);
+ if (narrow)
{
- last_idx = idx;
- while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(chr))
- idx--;
- if (idx >= 0)
+ const char *buf = scm_i_string_chars (str);
+ while (idx >= 0)
{
- res = scm_cons (scm_i_substring (str, idx, last_idx), res);
- idx--;
+ last_idx = idx;
+ while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(char_pred))
+ 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(char_pred))
+ 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)
+ SCM sidx, slast_idx;
+
+ if (!SCM_CHARSETP (char_pred))
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
+
+ /* Supporting predicates and character sets involves handling SCM
+ values so there is less chance to optimize. */
+ slast_idx = scm_string_length (str);
+ for (;;)
{
- 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--;
- }
+ sidx = scm_string_index_right (str, char_pred, SCM_INUM0, slast_idx);
+ if (scm_is_false (sidx))
+ break;
+ res = scm_cons (scm_substring (str, scm_oneplus (sidx), slast_idx), res);
+ slast_idx = sidx;
}
+
+ res = scm_cons (scm_substring (str, SCM_INUM0, slast_idx), res);
}
+
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"
SCM result;
size_t idx;
- MY_VALIDATE_SUBSTRING_SPEC (1, s,
+#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);
else
{
size_t dst = 0;
- result = scm_i_make_string (count, NULL);
+ 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
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 (scm_i_string_ref (s, idx));
- res = pred_tramp (char_pred, ch);
+ res = scm_call_1 (char_pred, ch);
if (scm_is_true (res))
ls = scm_cons (ch, ls);
idx++;
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"
SCM result;
size_t idx;
- MY_VALIDATE_SUBSTRING_SPEC (1, s,
+#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);
{
int i = 0;
/* new string for retained portion */
- result = scm_i_make_string (count, NULL);
+ 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
{
size_t i = 0;
/* new string for retained portion */
- result = scm_i_make_string (count, NULL);
+ 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
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 (scm_i_string_ref (s, idx));
- res = pred_tramp (char_pred, ch);
+ res = scm_call_1 (char_pred, ch);
if (scm_is_false (res))
ls = scm_cons (ch, ls);
idx++;
HCoop / bpt / guile.git / blobdiff