/* srfi-13.c --- SRFI-13 procedures for Guile
*
- * Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License as
- * published by the Free Software Foundation; either version 2, or (at
- * your option) any later version.
- *
- * This program 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
- * General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives
- * permission for additional uses of the text contained in its release
- * of GUILE.
+ * Copyright (C) 2001 Free Software Foundation, Inc.
*
- * The exception is that, if you link the GUILE library with other
- * files to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public
- * License. Your use of that executable is in no way restricted on
- * account of linking the GUILE library code into it.
+ * 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.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public
- * License.
- *
- * This exception applies only to the code released by the Free
- * Software Foundation under the name GUILE. If you copy code from
- * other Free Software Foundation releases into a copy of GUILE, as
- * the General Public License permits, the exception does not apply to
- * the code that you add in this way. To avoid misleading anyone as
- * to the status of such modified files, you must delete this
- * exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
#include <string.h>
#include "srfi-13.h"
#include "srfi-14.h"
-SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0,
+SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0,
(SCM pred, SCM s, SCM start, SCM end),
"Check if the predicate @var{pred} is true for any character in\n"
"the string @var{s}, proceeding from left (index @var{start}) to\n"
cstr += cstart;
while (cstart < cend)
{
- res = scm_apply (pred, SCM_MAKE_CHAR (*cstr), scm_listofnull);
+ res = scm_call_1 (pred, SCM_MAKE_CHAR (*cstr));
if (!SCM_FALSEP (res))
return res;
cstr++;
#undef FUNC_NAME
-SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0,
+SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0,
(SCM pred, SCM s, SCM start, SCM end),
"Check if the predicate @var{pred} is true for every character\n"
"in the string @var{s}, proceeding from left (index @var{start})\n"
cstr += cstart;
while (cstart < cend)
{
- res = scm_apply (pred, SCM_MAKE_CHAR (*cstr), scm_listofnull);
+ res = scm_call_1 (pred, SCM_MAKE_CHAR (*cstr));
if (SCM_FALSEP (res))
return res;
cstr++;
#undef FUNC_NAME
-SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0,
+SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0,
(SCM proc, SCM len),
"@var{proc} is an integer->char procedure. Construct a string\n"
"of size @var{len} by applying @var{proc} to each index to\n"
i = 0;
while (i < clen)
{
- ch = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull);
+ ch = scm_call_1 (proc, SCM_MAKINUM (i));
if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc));
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
*p++ = SCM_CHAR (ch);
i++;
}
}
#undef FUNC_NAME
-SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0,
+SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0,
(SCM chrs),
"An efficient implementation of @code{(compose string->list\n"
"reverse)}:\n"
{
SCM result;
long i = scm_ilength (chrs);
-
+
if (i < 0)
SCM_WRONG_TYPE_ARG (1, chrs);
result = scm_allocate_string (i);
{
unsigned char *data = SCM_STRING_UCHARS (result) + i;
- while (SCM_NNULLP (chrs))
+ while (!SCM_NULLP (chrs))
{
SCM elt = SCM_CAR (chrs);
SCM_SYMBOL (scm_sym_suffix, "suffix");
SCM_SYMBOL (scm_sym_prefix, "prefix");
-SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
+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"
break;
}
return result;
-#undef GRAM_INFIX
-#undef GRAM_STRICT_INFIX
-#undef GRAM_SUFFIX
-#undef GRAM_PREFIX
+#undef GRAM_INFIX
+#undef GRAM_STRICT_INFIX
+#undef GRAM_SUFFIX
+#undef GRAM_PREFIX
}
#undef FUNC_NAME
SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
2, start, cstart,
3, end, cend);
- return scm_makfromstr (cstr + cstart, cend - cstart, 0);
-
+ return scm_mem2string (cstr + cstart, cend - cstart);
+
}
#undef FUNC_NAME
-SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
+SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
(SCM str, SCM start, SCM end),
"Like @code{substring}, but the result may share memory with the\n"
"argument @var{str}.")
#undef FUNC_NAME
-SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
+SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
(SCM target, SCM tstart, SCM s, SCM start, SCM end),
"Copy the sequence of characters from index range [@var{start},\n"
"@var{end}) in string @var{s} to string @var{target}, beginning\n"
#undef FUNC_NAME
-SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0,
+SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0,
(SCM s, SCM n),
"Return the @var{n} first characters of @var{s}.")
#define FUNC_NAME s_scm_string_take
SCM_VALIDATE_STRING_COPY (1, s, cstr);
SCM_VALIDATE_INUM_COPY (2, n, cn);
SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s));
-
- return scm_makfromstr (cstr, cn, 0);
+
+ return scm_mem2string (cstr, cn);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0,
+SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0,
(SCM s, SCM n),
"Return all but the first @var{n} characters of @var{s}.")
#define FUNC_NAME s_scm_string_drop
SCM_VALIDATE_STRING_COPY (1, s, cstr);
SCM_VALIDATE_INUM_COPY (2, n, cn);
SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s));
-
- return scm_makfromstr (cstr + cn, SCM_STRING_LENGTH (s) - cn, 0);
+
+ return scm_mem2string (cstr + cn, SCM_STRING_LENGTH (s) - cn);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0,
+SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0,
(SCM s, SCM n),
"Return the @var{n} last characters of @var{s}.")
#define FUNC_NAME s_scm_string_take_right
SCM_VALIDATE_STRING_COPY (1, s, cstr);
SCM_VALIDATE_INUM_COPY (2, n, cn);
SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s));
-
- return scm_makfromstr (cstr + SCM_STRING_LENGTH (s) - cn, cn, 0);
+
+ return scm_mem2string (cstr + SCM_STRING_LENGTH (s) - cn, cn);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0,
+SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0,
(SCM s, SCM n),
"Return all but the last @var{n} characters of @var{s}.")
#define FUNC_NAME s_scm_string_drop_right
SCM_VALIDATE_STRING_COPY (1, s, cstr);
SCM_VALIDATE_INUM_COPY (2, n, cn);
SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s));
-
- return scm_makfromstr (cstr, SCM_STRING_LENGTH (s) - cn, 0);
+
+ return scm_mem2string (cstr, SCM_STRING_LENGTH (s) - cn);
}
#undef FUNC_NAME
{
SCM res;
- res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]),
- scm_listofnull);
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
if (SCM_FALSEP (res))
break;
cstart++;
}
}
- return scm_makfromstr (cstr + cstart, cend - cstart, 0);
+ return scm_mem2string (cstr + cstart, cend - cstart);
}
#undef FUNC_NAME
{
SCM res;
- res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]),
- scm_listofnull);
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
if (SCM_FALSEP (res))
break;
cend--;
}
}
- return scm_makfromstr (cstr + cstart, cend - cstart, 0);
+ return scm_mem2string (cstr + cstart, cend - cstart);
}
#undef FUNC_NAME
{
SCM res;
- res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]),
- scm_listofnull);
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
if (SCM_FALSEP (res))
break;
cstart++;
{
SCM res;
- res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]),
- scm_listofnull);
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
if (SCM_FALSEP (res))
break;
cend--;
}
}
- return scm_makfromstr (cstr + cstart, cend - cstart, 0);
+ return scm_mem2string (cstr + cstart, cend - cstart);
}
#undef FUNC_NAME
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])
- return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull);
+ return scm_call_1 (proc_lt, SCM_MAKINUM (cstart1));
else if (cstr1[cstart1] > cstr2[cstart2])
- return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull);
+ return scm_call_1 (proc_gt, SCM_MAKINUM (cstart1));
cstart1++;
cstart2++;
}
if (cstart1 < cend1)
- return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull);
+ return scm_call_1 (proc_gt, SCM_MAKINUM (cstart1));
else if (cstart2 < cend2)
- return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull);
+ return scm_call_1 (proc_lt, SCM_MAKINUM (cstart1));
else
- return scm_apply (proc_eq, SCM_MAKINUM (cstart1), scm_listofnull);
+ return scm_call_1 (proc_eq, SCM_MAKINUM (cstart1));
}
#undef FUNC_NAME
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_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
- return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull);
+ return scm_call_1 (proc_lt, SCM_MAKINUM (cstart1));
else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2]))
- return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull);
+ return scm_call_1 (proc_gt, SCM_MAKINUM (cstart1));
cstart1++;
cstart2++;
}
if (cstart1 < cend1)
- return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull);
+ return scm_call_1 (proc_gt, SCM_MAKINUM (cstart1));
else if (cstart2 < cend2)
- return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull);
+ return scm_call_1 (proc_lt, SCM_MAKINUM (cstart1));
else
- return scm_apply (proc_eq, SCM_MAKINUM (cstart1), scm_listofnull);
+ return scm_call_1 (proc_eq, SCM_MAKINUM (cstart1));
}
#undef FUNC_NAME
SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
5, start2, cstart2,
6, end2, cend2);
-
+
while (cstart1 < cend1 && cstart2 < cend2)
{
if (cstr1[cstart1] < cstr2[cstart2])
SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
5, start2, cstart2,
6, end2, cend2);
-
+
while (cstart1 < cend1 && cstart2 < cend2)
{
if (cstr1[cstart1] < cstr2[cstart2])
SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
5, start2, cstart2,
6, end2, cend2);
-
+
while (cstart1 < cend1 && cstart2 < cend2)
{
if (cstr1[cstart1] < cstr2[cstart2])
SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
5, start2, cstart2,
6, end2, cend2);
-
+
while (cstart1 < cend1 && cstart2 < cend2)
{
if (cstr1[cstart1] < cstr2[cstart2])
SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
5, start2, cstart2,
6, end2, cend2);
-
+
while (cstart1 < cend1 && cstart2 < cend2)
{
if (cstr1[cstart1] < cstr2[cstart2])
SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
5, start2, cstart2,
6, end2, cend2);
-
+
while (cstart1 < cend1 && cstart2 < cend2)
{
if (cstr1[cstart1] < cstr2[cstart2])
SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
5, start2, cstart2,
6, end2, cend2);
-
+
while (cstart1 < cend1 && cstart2 < cend2)
{
if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
5, start2, cstart2,
6, end2, cend2);
-
+
while (cstart1 < cend1 && cstart2 < cend2)
{
if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
5, start2, cstart2,
6, end2, cend2);
-
+
while (cstart1 < cend1 && cstart2 < cend2)
{
if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
5, start2, cstart2,
6, end2, cend2);
-
+
while (cstart1 < cend1 && cstart2 < cend2)
{
if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
5, start2, cstart2,
6, end2, cend2);
-
+
while (cstart1 < cend1 && cstart2 < cend2)
{
if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
5, start2, cstart2,
6, end2, cend2);
-
+
while (cstart1 < cend1 && cstart2 < cend2)
{
if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
while (cstart < cend)
{
SCM res;
- res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]),
- scm_listofnull);
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
if (!SCM_FALSEP (res))
return SCM_MAKINUM (cstart);
cstart++;
{
SCM res;
cend--;
- res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend]),
- scm_listofnull);
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend]));
if (!SCM_FALSEP (res))
return SCM_MAKINUM (cend);
}
}
- return SCM_BOOL_F;
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
while (cstart < cend)
{
SCM res;
- res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]),
- scm_listofnull);
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
if (SCM_FALSEP (res))
return SCM_MAKINUM (cstart);
cstart++;
{
SCM res;
cend--;
- res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend]),
- scm_listofnull);
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend]));
if (SCM_FALSEP (res))
return SCM_MAKINUM (cend);
}
}
- return SCM_BOOL_F;
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
while (cstart < cend)
{
SCM res;
- res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]),
- scm_listofnull);
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
if (!SCM_FALSEP (res))
count++;
cstart++;
#undef FUNC_NAME
-/* Helper function for the string uppercase conversion functions.
+/* Helper function for the string uppercase conversion functions.
* No argument checking is performed. */
static SCM
string_upcase_x (SCM v, int start, int end)
/* FIXME::martin: The `S' is to avoid a name clash with the procedure
in the core, which does not accept start/end indices */
-SCM_DEFINE (scm_string_upcase_xS, "string-upcase!", 1, 2, 0,
+SCM_DEFINE (scm_string_upcase_xS, "string-upcase!", 1, 2, 0,
(SCM str, SCM start, SCM end),
"Destructively upcase every character in @code{str}.\n"
"\n"
/* FIXME::martin: The `S' is to avoid a name clash with the procedure
in the core, which does not accept start/end indices */
-SCM_DEFINE (scm_string_upcaseS, "string-upcase", 1, 2, 0,
+SCM_DEFINE (scm_string_upcaseS, "string-upcase", 1, 2, 0,
(SCM str, SCM start, SCM end),
"Upcase every character in @code{str}.")
#define FUNC_NAME s_scm_string_upcaseS
#undef FUNC_NAME
-/* Helper function for the string lowercase conversion functions.
+/* Helper function for the string lowercase conversion functions.
* No argument checking is performed. */
static SCM
string_downcase_x (SCM v, int start, int end)
/* FIXME::martin: The `S' is to avoid a name clash with the procedure
in the core, which does not accept start/end indices */
-SCM_DEFINE (scm_string_downcase_xS, "string-downcase!", 1, 2, 0,
+SCM_DEFINE (scm_string_downcase_xS, "string-downcase!", 1, 2, 0,
(SCM str, SCM start, SCM end),
"Destructively downcase every character in @var{str}.\n"
"\n"
/* FIXME::martin: The `S' is to avoid a name clash with the procedure
in the core, which does not accept start/end indices */
-SCM_DEFINE (scm_string_downcaseS, "string-downcase", 1, 2, 0,
+SCM_DEFINE (scm_string_downcaseS, "string-downcase", 1, 2, 0,
(SCM str, SCM start, SCM end),
"Downcase every character in @var{str}.")
#define FUNC_NAME s_scm_string_downcaseS
#undef FUNC_NAME
-/* Helper function for the string capitalization functions.
+/* Helper function for the string capitalization functions.
* No argument checking is performed. */
static SCM
string_titlecase_x (SCM str, int start, int end)
{
- char * sz;
+ unsigned char * sz;
int i, in_word = 0;
- sz = SCM_STRING_CHARS (str);
+ sz = SCM_STRING_UCHARS (str);
for(i = start; i < end; i++)
{
- if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKE_CHAR(sz[i]))))
+ if (!SCM_FALSEP (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i]))))
{
if (!in_word)
{
}
-SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0,
+SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0,
(SCM str, SCM start, SCM end),
"Destructively titlecase every first character in a word in\n"
"@var{str}.")
#undef FUNC_NAME
-SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0,
+SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0,
(SCM str, SCM start, SCM end),
"Titlecase every first character in a word in @var{str}.")
#define FUNC_NAME s_scm_string_titlecase
}
-SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0,
+SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0,
(SCM str, SCM start, SCM end),
"Reverse the string @var{str}. The optional arguments\n"
"@var{start} and @var{end} delimit the region of @var{str} to\n"
#undef FUNC_NAME
-SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0,
+SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0,
(SCM str, SCM start, SCM end),
"Reverse the string @var{str} in-place. The optional arguments\n"
"@var{start} and @var{end} delimit the region of @var{str} to\n"
#undef FUNC_NAME
-SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1,
+SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1,
(SCM ls),
"Like @code{string-append}, but the result may share memory\n"
"with the argument strings.")
#undef FUNC_NAME
-SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0,
+SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0,
(SCM ls),
"Append the elements of @var{ls} (which must be strings)\n"
"together into a single string. Guaranteed to return a freshly\n"
#undef FUNC_NAME
-SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, 0,
+SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, 0,
(SCM ls, SCM final_string, SCM end),
"Without optional arguments, this procedure is equivalent to\n"
"\n"
if (!SCM_UNBNDP (end))
{
SCM_VALIDATE_INUM_COPY (3, end, cend);
- SCM_ASSERT_RANGE (3, end,
+ SCM_ASSERT_RANGE (3, end,
(cend >= 0) &&
(cend <= SCM_STRING_LENGTH (final_string)));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_string_concatenate_shared, "string-concatenate/shared", 1, 0, 0,
+SCM_DEFINE (scm_string_concatenate_shared, "string-concatenate/shared", 1, 0, 0,
(SCM ls),
"Like @code{string-concatenate}, but the result may share memory\n"
"with the strings in the list @var{ls}.")
#undef FUNC_NAME
-SCM_DEFINE (scm_string_concatenate_reverse_shared, "string-concatenate-reverse/shared", 1, 2, 0,
+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.")
SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
- (SCM s, SCM proc, SCM start, SCM end),
+ (SCM proc, SCM s, SCM start, SCM end),
"@var{proc} is a char->char procedure, it is mapped over\n"
"@var{s}. The order in which the procedure is applied to the\n"
"string elements is not specified.")
int cstart, cend;
SCM result;
- SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ SCM_VALIDATE_PROC (1, proc);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
3, start, cstart,
4, end, cend);
- SCM_VALIDATE_PROC (2, proc);
result = scm_allocate_string (cend - cstart);
p = SCM_STRING_CHARS (result);
while (cstart < cend)
{
- SCM ch = scm_apply (proc, SCM_MAKE_CHAR (cstr[cstart]),
- scm_listofnull);
+ SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (cstr[cstart]));
if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc));
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
cstart++;
*p++ = SCM_CHAR (ch);
}
SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0,
- (SCM s, SCM proc, SCM start, SCM end),
+ (SCM proc, SCM s, SCM start, SCM end),
"@var{proc} is a char->char procedure, it is mapped over\n"
"@var{s}. The order in which the procedure is applied to the\n"
"string elements is not specified. The string @var{s} is\n"
char * cstr, *p;
int cstart, cend;
- SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ SCM_VALIDATE_PROC (1, proc);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
3, start, cstart,
4, end, cend);
- SCM_VALIDATE_PROC (2, proc);
p = SCM_STRING_CHARS (s) + cstart;
while (cstart < cend)
{
- SCM ch = scm_apply (proc, SCM_MAKE_CHAR (cstr[cstart]),
- scm_listofnull);
+ SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (cstr[cstart]));
if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc));
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
cstart++;
*p++ = SCM_CHAR (ch);
}
result = knil;
while (cstart < cend)
{
- result = scm_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (cstr[cstart]),
- result), SCM_EOL);
+ result = scm_call_2 (kons, SCM_MAKE_CHAR (cstr[cstart]), result);
cstart++;
}
return result;
result = knil;
while (cstart < cend)
{
- result = scm_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (cstr[cend - 1]),
- result), SCM_EOL);
+ result = scm_call_2 (kons, SCM_MAKE_CHAR (cstr[cend - 1]), result);
cend--;
}
return result;
"@dots{}\n"
"@item @var{p} tells us when to stop -- when it returns true\n"
"when applied to one of these seed values.\n"
- "@item @var{f} maps each seed value to the corresponding \n"
+ "@item @var{f} maps each seed value to the corresponding\n"
"character in the result string. These chars are assembled\n"
"into the string in a left-to-right order.\n"
"@item @var{base} is the optional initial/leftmost portion\n"
if (!SCM_UNBNDP (make_final))
SCM_VALIDATE_PROC (6, make_final);
- res = scm_apply (p, seed, scm_listofnull);
+ res = scm_call_1 (p, seed);
while (SCM_FALSEP (res))
{
SCM str;
- SCM ch = scm_apply (f, seed, scm_listofnull);
+ SCM ch = scm_call_1 (f, seed);
if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f));
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
str = scm_allocate_string (1);
*SCM_STRING_CHARS (str) = SCM_CHAR (ch);
- ans = scm_string_append (SCM_LIST2 (ans, str));
- seed = scm_apply (g, seed, scm_listofnull);
- res = scm_apply (p, seed, scm_listofnull);
+ ans = scm_string_append (scm_list_2 (ans, str));
+ seed = scm_call_1 (g, seed);
+ res = scm_call_1 (p, seed);
}
if (!SCM_UNBNDP (make_final))
{
- res = scm_apply (make_final, seed, scm_listofnull);
- return scm_string_append (SCM_LIST2 (ans, res));
+ res = scm_call_1 (make_final, seed);
+ return scm_string_append (scm_list_2 (ans, res));
}
else
return ans;
"@dots{}\n"
"@item @var{p} tells us when to stop -- when it returns true\n"
"when applied to one of these seed values.\n"
- "@item @var{f} maps each seed value to the corresponding \n"
+ "@item @var{f} maps each seed value to the corresponding\n"
"character in the result string. These chars are assembled\n"
"into the string in a right-to-left order.\n"
"@item @var{base} is the optional initial/rightmost portion\n"
if (!SCM_UNBNDP (make_final))
SCM_VALIDATE_PROC (6, make_final);
- res = scm_apply (p, seed, scm_listofnull);
+ res = scm_call_1 (p, seed);
while (SCM_FALSEP (res))
{
SCM str;
- SCM ch = scm_apply (f, seed, scm_listofnull);
+ SCM ch = scm_call_1 (f, seed);
if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f));
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
str = scm_allocate_string (1);
*SCM_STRING_CHARS (str) = SCM_CHAR (ch);
- ans = scm_string_append (SCM_LIST2 (str, ans));
- seed = scm_apply (g, seed, scm_listofnull);
- res = scm_apply (p, seed, scm_listofnull);
+ ans = scm_string_append (scm_list_2 (str, ans));
+ seed = scm_call_1 (g, seed);
+ res = scm_call_1 (p, seed);
}
if (!SCM_UNBNDP (make_final))
{
- res = scm_apply (make_final, seed, scm_listofnull);
- return scm_string_append (SCM_LIST2 (res, ans));
+ res = scm_call_1 (make_final, seed);
+ return scm_string_append (scm_list_2 (res, ans));
}
else
return ans;
SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0,
- (SCM s, SCM proc, SCM start, SCM end),
+ (SCM proc, SCM s, SCM start, SCM end),
"@var{proc} is mapped over @var{s} in left-to-right order. The\n"
"return value is not specified.")
#define FUNC_NAME s_scm_string_for_each
char * cstr;
int cstart, cend;
- SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ SCM_VALIDATE_PROC (1, proc);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ while (cstart < cend)
+ {
+ scm_call_1 (proc, SCM_MAKE_CHAR (cstr[cstart]));
+ cstart++;
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0,
+ (SCM proc, SCM s, SCM start, SCM end),
+ "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
+ "return value is not specified.")
+#define FUNC_NAME s_scm_string_for_each
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_VALIDATE_PROC (1, proc);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
3, start, cstart,
4, end, cend);
- SCM_VALIDATE_PROC (2, proc);
while (cstart < cend)
{
- scm_apply (proc, SCM_MAKE_CHAR (cstr[cstart]), scm_listofnull);
+ scm_call_1 (proc, SCM_MAKINUM (cstart));
cstart++;
}
return SCM_UNSPECIFIED;
SCM_VALIDATE_INUM_DEF_COPY (3, to, cfrom + (cend - cstart), cto);
if (cstart == cend && cfrom != cto)
SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
-
+
result = scm_allocate_string (cto - cfrom);
-
+
p = SCM_STRING_CHARS (result);
while (cfrom < cto)
{
SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
- (SCM s, SCM token_char, SCM start, SCM end),
+ (SCM s, SCM token_set, SCM start, SCM end),
"Split the string @var{s} into a list of substrings, where each\n"
"substring is a maximal non-empty contiguous sequence of\n"
- "characters equal to the character @var{token_char}, or\n"
- "whitespace, if @var{token_char} is not given. If\n"
- "@var{token_char} is a character set, it is used for finding the\n"
- "token borders.")
+ "characters from the character set @var{token_set}, which\n"
+ "defaults to @code{char-set:graphic} from module (srfi srfi-14).\n"
+ "If @var{start} or @var{end} indices are provided, they restrict\n"
+ "@code{string-tokenize} to operating on the indicated substring\n"
+ "of @var{s}.")
#define FUNC_NAME s_scm_string_tokenize
{
char * cstr;
int cstart, cend;
SCM result = SCM_EOL;
+ static SCM charset_graphic = SCM_BOOL_F;
+
SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
3, start, cstart,
4, end, cend);
- if (SCM_UNBNDP (token_char))
- {
- int idx;
- while (cstart < cend)
- {
- while (cstart < cend)
- {
- if (!isspace (cstr[cend - 1]))
- break;
- cend--;
- }
- if (cstart >= cend)
- break;
- idx = cend;
- while (cstart < cend)
- {
- if (isspace (cstr[cend - 1]))
- break;
- cend--;
- }
- result = scm_cons (scm_makfromstr (cstr + cend, idx - cend,
- 0), result);
- }
- }
- else if (SCM_CHARSETP (token_char))
+ if (SCM_UNBNDP (token_set))
{
- int idx;
-
- while (cstart < cend)
+ if (charset_graphic == SCM_BOOL_F)
{
- while (cstart < cend)
- {
- if (!SCM_CHARSET_GET (token_char, cstr[cend - 1]))
- break;
- cend--;
- }
- if (cstart >= cend)
- break;
- idx = cend;
- while (cstart < cend)
- {
- if (SCM_CHARSET_GET (token_char, cstr[cend - 1]))
- break;
- cend--;
- }
- result = scm_cons (scm_makfromstr (cstr + cend, idx - cend,
- 0), result);
+ SCM srfi_14_module = scm_c_resolve_module ("srfi srfi-14");
+ SCM charset_graphic_var = scm_c_module_lookup (srfi_14_module,
+ "char-set:graphic");
+ charset_graphic =
+ scm_permanent_object (SCM_VARIABLE_REF (charset_graphic_var));
}
+ token_set = charset_graphic;
}
- else
+
+ if (SCM_CHARSETP (token_set))
{
int idx;
- char chr;
-
- SCM_VALIDATE_CHAR (2, token_char);
- chr = SCM_CHAR (token_char);
while (cstart < cend)
{
while (cstart < cend)
{
- if (cstr[cend - 1] != chr)
+ if (SCM_CHARSET_GET (token_set, cstr[cend - 1]))
break;
cend--;
}
idx = cend;
while (cstart < cend)
{
- if (cstr[cend - 1] == chr)
+ if (!SCM_CHARSET_GET (token_set, cstr[cend - 1]))
break;
cend--;
}
- result = scm_cons (scm_makfromstr (cstr + cend, idx - cend,
- 0), result);
+ result = scm_cons (scm_mem2string (cstr + cend, idx - cend), result);
}
}
+ else SCM_WRONG_TYPE_ARG (2, token_set);
return result;
}
#undef FUNC_NAME
{
SCM ls = SCM_EOL;
char chr;
-
+
chr = SCM_CHAR (char_pred);
idx = cstart;
while (idx < cend)
else if (SCM_CHARSETP (char_pred))
{
SCM ls = SCM_EOL;
-
+
idx = cstart;
while (idx < cend)
{
while (idx < cend)
{
SCM res;
- res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[idx]),
- scm_listofnull);
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx]));
if (!SCM_FALSEP (res))
ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
idx++;
{
SCM ls = SCM_EOL;
char chr;
-
+
chr = SCM_CHAR (char_pred);
idx = cstart;
while (idx < cend)
else if (SCM_CHARSETP (char_pred))
{
SCM ls = SCM_EOL;
-
+
idx = cstart;
while (idx < cend)
{
while (idx < cend)
{
SCM res;
- res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[idx]),
- scm_listofnull);
+ res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx]));
if (SCM_FALSEP (res))
ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
idx++;
#undef FUNC_NAME
+/* Initialize the SRFI-13 module. This function will be called by the
+ loading Scheme module. */
void
scm_init_srfi_13 (void)
{
-#ifndef SCM_MAGIC_SNARFER
+ /* We initialize the SRFI-14 module here, because the string
+ primitives need the charset smob type created by that module. */
+ scm_c_init_srfi_14 ();
+
+ /* Install the string primitives. */
#include "srfi/srfi-13.x"
-#endif
}
-
-void
-scm_init_srfi_13_14 (void)
-{
- static int initialized = 0;
-
- if (!initialized)
- {
- SCM srfi_13_module = scm_make_module (scm_read_0str ("(srfi srfi-13)"));
- SCM srfi_14_module = scm_make_module (scm_read_0str ("(srfi srfi-14)"));
- SCM old_module;
-
- initialized = 1;
-
- old_module = scm_set_current_module (srfi_13_module);
- scm_init_srfi_13 ();
- scm_set_current_module (srfi_14_module);
- scm_init_srfi_14 ();
-
- scm_set_current_module (old_module);
- }
-}
+/* End of srfi-13.c. */
HCoop / bpt / guile.git / blobdiff