summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMarius Vollmer <mvo@zagadka.de>2004-08-24 22:19:21 +0000
committerMarius Vollmer <mvo@zagadka.de>2004-08-24 22:19:21 +0000
commit0081b349c8de1f5c577e7135266b61b9d1f3584c (patch)
tree03fc93f38b44eb8c81726a52931cd5ecb22179c7
parent7aa29a87f98cfbbb59bd4ba4329f24fcc54353f7 (diff)
downloadguile-0081b349c8de1f5c577e7135266b61b9d1f3584c.tar.gz
* srfi-13.scm, srfi-14.scm: Simply re-export the relevant
bindings. * srfi-13.h, srfi-13.c, srfi-14.h, srfi-14.c: Removed all real content except for the init functions.
-rw-r--r--srfi/srfi-13.c3075
-rw-r--r--srfi/srfi-13.h94
-rw-r--r--srfi/srfi-13.scm89
-rw-r--r--srfi/srfi-14.c1400
-rw-r--r--srfi/srfi-14.h66
-rw-r--r--srfi/srfi-14.scm61
6 files changed, 69 insertions, 4716 deletions
diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c
index e362b8fad..5814f8092 100644
--- a/srfi/srfi-13.c
+++ b/srfi/srfi-13.c
@@ -1,4 +1,4 @@
-/* srfi-13.c --- SRFI-13 procedures for Guile
+/* srfi-13.c --- old place of SRFI-13 procedures for Guile
*
* Copyright (C) 2001, 2004 Free Software Foundation, Inc.
*
@@ -18,3078 +18,19 @@
*/
-#include <string.h>
-#include <ctype.h>
-
-#include <libguile.h>
-
-#include "srfi-13.h"
-#include "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.
+/* This file is now empty since all its procedures are now in the
+ core. We keep the libguile-srfi-srfi-13.so library around anyway
+ since people might still be linking with it.
*/
-#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)
-
-#define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
- pos_start, start, c_start, \
- pos_end, end, c_end) \
- do { \
- SCM_VALIDATE_STRING (pos_str, str); \
- scm_i_get_substring_spec (scm_i_string_length (str), \
- start, &c_start, end, &c_end); \
- } while (0)
-
-/* Likewise for SCM_VALIDATE_STRING_COPY. */
-
-#define MY_VALIDATE_STRING_COPY(pos, str, cvar) \
- do { \
- scm_validate_string (pos, str); \
- cvar = scm_i_string_chars (str); \
- } while (0)
-
-
-SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0,
- (SCM char_pred, SCM s, SCM start, SCM end),
- "Check if the predicate @var{pred} is true for any character in\n"
- "the string @var{s}.\n"
- "\n"
- "Calls to @var{pred} are made from left to right across @var{s}.\n"
- "When it returns true (ie.@: non-@code{#f}), that return value\n"
- "is the return from @code{string-any}.\n"
- "\n"
- "The SRFI-13 specification requires that the call to @var{pred}\n"
- "on the last character of @var{s} (assuming that point is\n"
- "reached) be a tail call, but currently in Guile this is not the\n"
- "case.")
-#define FUNC_NAME s_scm_string_any
-{
- const char *cstr;
- int cstart, cend;
- SCM res;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
- 3, start, cstart,
- 4, end, cend);
-
- if (SCM_CHARP (char_pred))
- {
- return (memchr (cstr+cstart, (int) SCM_CHAR (char_pred),
- cend-cstart) == NULL
- ? SCM_BOOL_F : SCM_BOOL_T);
- }
- else if (SCM_CHARSETP (char_pred))
- {
- int i;
- for (i = cstart; i < cend; i++)
- if (SCM_CHARSET_GET (char_pred, cstr[i]))
- return SCM_BOOL_T;
- }
- else
- {
- SCM_VALIDATE_PROC (1, char_pred);
-
- cstr += cstart;
- while (cstart < cend)
- {
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (*cstr));
- if (scm_is_true (res))
- return res;
- cstr++;
- cstart++;
- }
- }
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0,
- (SCM char_pred, SCM s, SCM start, SCM end),
- "Check if the predicate @var{pred} is true for every character\n"
- "in the string @var{s}.\n"
- "\n"
- "Calls to @var{pred} are made from left to right across @var{s}.\n"
- "If the predicate is true for every character then the return\n"
- "value from the last @var{pred} call is the return from\n"
- "@code{string-every}.\n"
- "\n"
- "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
- "@var{end}) then the return is @code{#t}.\n"
- "\n"
- "The SRFI-13 specification requires that the call to @var{pred}\n"
- "on the last character of @var{s} (assuming that point is\n"
- "reached) be a tail call, but currently in Guile this is not the\n"
- "case.")
-#define FUNC_NAME s_scm_string_every
-{
- const char *cstr;
- int cstart, cend;
- SCM res;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
- 3, start, cstart,
- 4, end, cend);
- if (SCM_CHARP (char_pred))
- {
- char cchr = SCM_CHAR (char_pred);
- int i;
- for (i = cstart; i < cend; i++)
- if (cstr[i] != cchr)
- return SCM_BOOL_F;
- return SCM_BOOL_T;
- }
- else if (SCM_CHARSETP (char_pred))
- {
- int i;
- for (i = cstart; i < cend; i++)
- if (! SCM_CHARSET_GET (char_pred, cstr[i]))
- return SCM_BOOL_F;
- return SCM_BOOL_T;
- }
- else
- {
- SCM_VALIDATE_PROC (1, char_pred);
-
- res = SCM_BOOL_T;
- cstr += cstart;
- while (cstart < cend)
- {
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (*cstr));
- if (scm_is_false (res))
- return res;
- cstr++;
- cstart++;
- }
- return res;
- }
-}
-#undef FUNC_NAME
-
-
-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"
- "produce the corresponding string element. The order in which\n"
- "@var{proc} is applied to the indices is not specified.")
-#define FUNC_NAME s_scm_string_tabulate
-{
- size_t clen, i;
- SCM res;
- SCM ch;
- char *p;
-
- SCM_VALIDATE_PROC (1, proc);
- 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 = scm_call_1 (proc, scm_from_int (i));
- if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
- *p++ = SCM_CHAR (ch);
- i++;
- }
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_to_listS, "string->list", 1, 2, 0,
- (SCM str, SCM start, SCM end),
- "Convert the string @var{str} into a list of characters.")
-#define FUNC_NAME s_scm_string_to_listS
-{
- const char *cstr;
- int cstart, cend;
- SCM result = SCM_EOL;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
- while (cstart < cend)
- {
- cend--;
- result = scm_cons (SCM_MAKE_CHAR (cstr[cend]), result);
- }
- return result;
-}
-#undef FUNC_NAME
-
-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"
- "\n"
- "@smalllisp\n"
- "(reverse-list->string '(#\a #\B #\c)) @result{} \"cBa\"\n"
- "@end smalllisp")
-#define FUNC_NAME s_scm_reverse_list_to_string
-{
- SCM result;
- long i = scm_ilength (chrs);
- char *data;
-
- if (i < 0)
- SCM_WRONG_TYPE_ARG (1, chrs);
- result = scm_i_make_string (i, &data);
-
- {
-
- data += i;
- while (!SCM_NULLP (chrs))
- {
- SCM elt = SCM_CAR (chrs);
-
- SCM_VALIDATE_CHAR (SCM_ARGn, elt);
- data--;
- *data = SCM_CHAR (elt);
- chrs = SCM_CDR (chrs);
- }
- }
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_SYMBOL (scm_sym_infix, "infix");
-SCM_SYMBOL (scm_sym_strict_infix, "strict-infix");
-SCM_SYMBOL (scm_sym_suffix, "suffix");
-SCM_SYMBOL (scm_sym_prefix, "prefix");
-
-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{grammar} is a symbol which specifies how the delimiter is\n"
- "placed between the strings, and defaults to the symbol\n"
- "@code{infix}.\n"
- "\n"
- "@table @code\n"
- "@item infix\n"
- "Insert the separator between list elements. An empty string\n"
- "will produce an empty list.\n"
- "@item string-infix\n"
- "Like @code{infix}, but will raise an error if given the empty\n"
- "list.\n"
- "@item suffix\n"
- "Insert the separator after every list element.\n"
- "@item prefix\n"
- "Insert the separator before each list element.\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;
- int del_len = 0, extra_len = 0;
- int len = 0;
- char * p;
- long strings = scm_ilength (ls);
-
- /* Validate the string list. */
- if (strings < 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;
- }
- else
- {
- SCM_VALIDATE_STRING (2, delimiter);
- del_len = scm_i_string_length (delimiter);
- }
-
- /* Validate the grammar symbol and remember the grammar. */
- 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
- 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_NULLP (ls))
- extra_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);
- extra_len = (strings - 1) * del_len;
- break;
- default:
- extra_len = strings * del_len;
- break;
- }
-
- tmp = ls;
- while (SCM_CONSP (tmp))
- {
- SCM elt = SCM_CAR (tmp);
- SCM_VALIDATE_STRING (1, elt);
- len += scm_i_string_length (elt);
- tmp = SCM_CDR (tmp);
- }
-
- result = scm_i_make_string (len + extra_len, &p);
-
- tmp = ls;
- switch (gram)
- {
- case GRAM_INFIX:
- case GRAM_STRICT_INFIX:
- while (!SCM_NULLP (tmp))
- {
- SCM elt = SCM_CAR (tmp);
- memmove (p, scm_i_string_chars (elt),
- scm_i_string_length (elt));
- p += scm_i_string_length (elt);
- if (!SCM_NULLP (SCM_CDR (tmp)) && del_len > 0)
- {
- memmove (p, scm_i_string_chars (delimiter), del_len);
- p += del_len;
- }
- tmp = SCM_CDR (tmp);
- }
- break;
- case GRAM_SUFFIX:
- while (!SCM_NULLP (tmp))
- {
- SCM elt = SCM_CAR (tmp);
- memmove (p, scm_i_string_chars (elt),
- scm_i_string_length (elt));
- p += scm_i_string_length (elt);
- if (del_len > 0)
- {
- memmove (p, scm_i_string_chars (delimiter), del_len);
- p += del_len;
- }
- tmp = SCM_CDR (tmp);
- }
- break;
- case GRAM_PREFIX:
- while (!SCM_NULLP (tmp))
- {
- SCM elt = SCM_CAR (tmp);
- if (del_len > 0)
- {
- memmove (p, scm_i_string_chars (delimiter), del_len);
- p += del_len;
- }
- memmove (p, scm_i_string_chars (elt),
- scm_i_string_length (elt));
- p += scm_i_string_length (elt);
- tmp = SCM_CDR (tmp);
- }
- break;
- }
- return result;
-#undef GRAM_INFIX
-#undef GRAM_STRICT_INFIX
-#undef GRAM_SUFFIX
-#undef GRAM_PREFIX
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_copyS, "string-copy", 1, 2, 0,
- (SCM str, SCM start, SCM end),
- "Return a freshly allocated copy of the string @var{str}. If\n"
- "given, @var{start} and @var{end} delimit the portion of\n"
- "@var{str} which is copied.")
-#define FUNC_NAME s_scm_string_copyS
-{
- 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);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_substring_sharedS, "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}.")
-#define FUNC_NAME s_scm_substring_sharedS
-{
- 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_shared (str, cstart, cend);
-}
-#undef FUNC_NAME
-
-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"
- "at index @var{tstart}. The characters are copied left-to-right\n"
- "or right-to-left as needed -- the copy is guaranteed to work,\n"
- "even if @var{target} and @var{s} are the same string. It is an\n"
- "error if the copy operation runs off the end of the target\n"
- "string.")
-#define FUNC_NAME s_scm_string_copy_x
-{
- const char *cstr;
- char *ctarget;
- size_t cstart, cend, ctstart, dummy, len;
- 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 ();
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-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
-{
- return scm_substring (s, SCM_INUM0, n);
-}
-#undef FUNC_NAME
-
-
-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
-{
- return scm_substring (s, n, SCM_UNDEFINED);
-}
-#undef FUNC_NAME
-
-
-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
-{
- return scm_substring (s,
- scm_difference (scm_string_length (s), n),
- SCM_UNDEFINED);
-}
-#undef FUNC_NAME
-
-
-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
-{
- return scm_substring (s,
- SCM_INUM0,
- scm_difference (scm_string_length (s), n));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0,
- (SCM s, SCM len, SCM chr, SCM start, SCM end),
- "Take that characters from @var{start} to @var{end} from the\n"
- "string @var{s} and return a new string, right-padded by the\n"
- "character @var{chr} to length @var{len}. If the resulting\n"
- "string is longer than @var{len}, it is truncated on the right.")
-#define FUNC_NAME s_scm_string_pad
-{
- char cchr;
- const char *cstr;
- size_t cstart, cend, clen;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 4, start, cstart,
- 5, end, cend);
- clen = scm_to_size_t (len);
-
- if (SCM_UNBNDP (chr))
- cchr = ' ';
- else
- {
- SCM_VALIDATE_CHAR (3, chr);
- cchr = SCM_CHAR (chr);
- }
- if (clen < (cend - cstart))
- return scm_c_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), cstr + cstart, cend - cstart);
- return result;
- }
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0,
- (SCM s, SCM len, SCM chr, SCM start, SCM end),
- "Take that characters from @var{start} to @var{end} from the\n"
- "string @var{s} and return a new string, left-padded by the\n"
- "character @var{chr} to length @var{len}. If the resulting\n"
- "string is longer than @var{len}, it is truncated on the left.")
-#define FUNC_NAME s_scm_string_pad_right
-{
- char cchr;
- const char *cstr;
- size_t cstart, cend, clen;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 4, start, cstart,
- 5, end, cend);
- clen = scm_to_size_t (len);
-
- if (SCM_UNBNDP (chr))
- cchr = ' ';
- else
- {
- SCM_VALIDATE_CHAR (3, chr);
- cchr = SCM_CHAR (chr);
- }
- if (clen < (cend - cstart))
- return scm_c_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, cstr + cstart, cend - cstart);
- return result;
- }
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0,
- (SCM s, SCM char_pred, SCM start, SCM end),
- "Trim @var{s} by skipping over all characters on the left\n"
- "that satisfy the parameter @var{char_pred}:\n"
- "\n"
- "@itemize @bullet\n"
- "@item\n"
- "if it is the character @var{ch}, characters equal to\n"
- "@var{ch} are trimmed,\n"
- "\n"
- "@item\n"
- "if it is a procedure @var{pred} characters that\n"
- "satisfy @var{pred} are trimmed,\n"
- "\n"
- "@item\n"
- "if it is a character set, characters in that set are trimmed.\n"
- "@end itemize\n"
- "\n"
- "If called without a @var{char_pred} argument, all whitespace is\n"
- "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))
- {
- while (cstart < cend)
- {
- if (!isspace((int) (unsigned char) cstr[cstart]))
- break;
- cstart++;
- }
- }
- else if (SCM_CHARP (char_pred))
- {
- char chr = SCM_CHAR (char_pred);
- while (cstart < cend)
- {
- if (chr != cstr[cstart])
- break;
- cstart++;
- }
- }
- else if (SCM_CHARSETP (char_pred))
- {
- while (cstart < cend)
- {
- if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
- break;
- cstart++;
- }
- }
- else
- {
- SCM_VALIDATE_PROC (2, char_pred);
- while (cstart < cend)
- {
- SCM res;
-
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
- if (scm_is_false (res))
- break;
- cstr = scm_i_string_chars (s);
- cstart++;
- }
- }
- return scm_c_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"
- "that satisfy the parameter @var{char_pred}:\n"
- "\n"
- "@itemize @bullet\n"
- "@item\n"
- "if it is the character @var{ch}, characters equal to @var{ch}\n"
- "are trimmed,\n"
- "\n"
- "@item\n"
- "if it is a procedure @var{pred} characters that satisfy\n"
- "@var{pred} are trimmed,\n"
- "\n"
- "@item\n"
- "if it is a character sets, all characters in that set are\n"
- "trimmed.\n"
- "@end itemize\n"
- "\n"
- "If called without a @var{char_pred} argument, all whitespace is\n"
- "trimmed.")
-#define FUNC_NAME s_scm_string_trim_right
-{
- const char *cstr;
- int cstart, cend;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
- if (SCM_UNBNDP (char_pred))
- {
- while (cstart < cend)
- {
- if (!isspace((int) (unsigned char) cstr[cend - 1]))
- break;
- cend--;
- }
- }
- else if (SCM_CHARP (char_pred))
- {
- char chr = SCM_CHAR (char_pred);
- while (cstart < cend)
- {
- if (chr != cstr[cend - 1])
- break;
- cend--;
- }
- }
- else if (SCM_CHARSETP (char_pred))
- {
- while (cstart < cend)
- {
- if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1]))
- break;
- cend--;
- }
- }
- else
- {
- SCM_VALIDATE_PROC (2, char_pred);
- while (cstart < cend)
- {
- SCM res;
-
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
- if (scm_is_false (res))
- break;
- cstr = scm_i_string_chars (s);
- cend--;
- }
- }
- return scm_c_substring (s, cstart, cend);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0,
- (SCM s, SCM char_pred, SCM start, SCM end),
- "Trim @var{s} by skipping over all characters on both sides of\n"
- "the string that satisfy the parameter @var{char_pred}:\n"
- "\n"
- "@itemize @bullet\n"
- "@item\n"
- "if it is the character @var{ch}, characters equal to @var{ch}\n"
- "are trimmed,\n"
- "\n"
- "@item\n"
- "if it is a procedure @var{pred} characters that satisfy\n"
- "@var{pred} are trimmed,\n"
- "\n"
- "@item\n"
- "if it is a character set, the characters in the set are\n"
- "trimmed.\n"
- "@end itemize\n"
- "\n"
- "If called without a @var{char_pred} argument, all whitespace is\n"
- "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))
- {
- while (cstart < cend)
- {
- if (!isspace((int) (unsigned char) cstr[cstart]))
- break;
- cstart++;
- }
- while (cstart < cend)
- {
- if (!isspace((int) (unsigned char) cstr[cend - 1]))
- break;
- cend--;
- }
- }
- else if (SCM_CHARP (char_pred))
- {
- char chr = SCM_CHAR (char_pred);
- while (cstart < cend)
- {
- if (chr != cstr[cstart])
- break;
- cstart++;
- }
- while (cstart < cend)
- {
- if (chr != cstr[cend - 1])
- break;
- cend--;
- }
- }
- else if (SCM_CHARSETP (char_pred))
- {
- while (cstart < cend)
- {
- if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
- break;
- cstart++;
- }
- while (cstart < cend)
- {
- if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1]))
- break;
- cend--;
- }
- }
- else
- {
- SCM_VALIDATE_PROC (2, char_pred);
- while (cstart < cend)
- {
- SCM res;
-
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
- if (scm_is_false (res))
- break;
- cstr = scm_i_string_chars (s);
- cstart++;
- }
- while (cstart < cend)
- {
- SCM res;
-
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
- if (scm_is_false (res))
- break;
- cstr = scm_i_string_chars (s);
- cend--;
- }
- }
- return scm_c_substring (s, cstart, cend);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_fill_xS, "string-fill!", 2, 2, 0,
- (SCM str, SCM chr, SCM start, SCM end),
- "Stores @var{chr} in every element of the given @var{str} and\n"
- "returns an unspecified value.")
-#define FUNC_NAME s_scm_string_fill_xS
-{
- char *cstr;
- size_t cstart, cend;
- int c;
- size_t k;
-
- MY_VALIDATE_SUBSTRING_SPEC (1, str,
- 3, start, cstart,
- 4, end, cend);
- SCM_VALIDATE_CHAR_COPY (2, chr, c);
+#include "srfi/srfi-13.h"
- cstr = scm_i_string_writable_chars (str);
- for (k = cstart; k < cend; k++)
- cstr[k] = c;
- scm_i_string_stop_writing ();
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0,
- (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2),
- "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
- "mismatch index, depending upon whether @var{s1} is less than,\n"
- "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.")
-#define FUNC_NAME s_scm_string_compare
-{
- const char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 6, start1, cstart1,
- 7, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 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])
- return scm_call_1 (proc_lt, scm_from_size_t (cstart1));
- else if (cstr1[cstart1] > cstr2[cstart2])
- return scm_call_1 (proc_gt, scm_from_size_t (cstart1));
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return scm_call_1 (proc_gt, scm_from_size_t (cstart1));
- else if (cstart2 < cend2)
- return scm_call_1 (proc_lt, scm_from_size_t (cstart1));
- else
- return scm_call_1 (proc_eq, scm_from_size_t (cstart1));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0,
- (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2),
- "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
- "mismatch index, depending upon whether @var{s1} is less than,\n"
- "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.")
-#define FUNC_NAME s_scm_string_compare_ci
-{
- const char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 6, start1, cstart1,
- 7, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 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]))
- return scm_call_1 (proc_lt, scm_from_size_t (cstart1));
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- return scm_call_1 (proc_gt, scm_from_size_t (cstart1));
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return scm_call_1 (proc_gt, scm_from_size_t (cstart1));
- else if (cstart2 < cend2)
- return scm_call_1 (proc_lt, scm_from_size_t (cstart1));
- else
- return scm_call_1 (proc_eq, scm_from_size_t (cstart1));
-}
-#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
-{
- 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 (cstr1[cstart1] < cstr2[cstart2])
- return SCM_BOOL_F;
- else if (cstr1[cstart1] > cstr2[cstart2])
- return SCM_BOOL_F;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return SCM_BOOL_F;
- else if (cstart2 < cend2)
- return SCM_BOOL_F;
- else
- return scm_from_size_t (cstart1);
-}
-#undef FUNC_NAME
-
-
-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
-{
- 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 (cstr1[cstart1] < cstr2[cstart2])
- return scm_from_size_t (cstart1);
- else if (cstr1[cstart1] > cstr2[cstart2])
- return scm_from_size_t (cstart1);
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return scm_from_size_t (cstart1);
- else if (cstart2 < cend2)
- return scm_from_size_t (cstart1);
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
- "true value otherwise.")
-#define FUNC_NAME s_scm_string_lt
-{
- 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 (cstr1[cstart1] < cstr2[cstart2])
- return scm_from_size_t (cstart1);
- else if (cstr1[cstart1] > cstr2[cstart2])
- return SCM_BOOL_F;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return SCM_BOOL_F;
- else if (cstart2 < cend2)
- return scm_from_size_t (cstart1);
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
- "true value otherwise.")
-#define FUNC_NAME s_scm_string_gt
-{
- 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 (cstr1[cstart1] < cstr2[cstart2])
- return SCM_BOOL_F;
- else if (cstr1[cstart1] > cstr2[cstart2])
- return scm_from_size_t (cstart1);
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return scm_from_size_t (cstart1);
- else if (cstart2 < cend2)
- return SCM_BOOL_F;
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
- "value otherwise.")
-#define FUNC_NAME s_scm_string_le
-{
- 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 (cstr1[cstart1] < cstr2[cstart2])
- return scm_from_size_t (cstart1);
- else if (cstr1[cstart1] > cstr2[cstart2])
- return SCM_BOOL_F;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return SCM_BOOL_F;
- else if (cstart2 < cend2)
- return scm_from_size_t (cstart1);
- else
- return scm_from_size_t (cstart1);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_ge, "string>=", 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.")
-#define FUNC_NAME s_scm_string_ge
-{
- 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 (cstr1[cstart1] < cstr2[cstart2])
- return SCM_BOOL_F;
- else if (cstr1[cstart1] > cstr2[cstart2])
- return scm_from_size_t (cstart1);
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return scm_from_size_t (cstart1);
- else if (cstart2 < cend2)
- return SCM_BOOL_F;
- else
- return scm_from_size_t (cstart1);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_ci_eq, "string-ci=", 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. The character comparison is done\n"
- "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]))
- return SCM_BOOL_F;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- return SCM_BOOL_F;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return SCM_BOOL_F;
- else if (cstart2 < cend2)
- return SCM_BOOL_F;
- else
- return scm_from_size_t (cstart1);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 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. The character comparison is done\n"
- "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]))
- return scm_from_size_t (cstart1);
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- return scm_from_size_t (cstart1);
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return scm_from_size_t (cstart1);
- else if (cstart2 < cend2)
- return scm_from_size_t (cstart1);
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
- "true value otherwise. The character comparison is done\n"
- "case-insensitively.")
-#define FUNC_NAME s_scm_string_ci_lt
-{
- 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]))
- return scm_from_size_t (cstart1);
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- return SCM_BOOL_F;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return SCM_BOOL_F;
- else if (cstart2 < cend2)
- return scm_from_size_t (cstart1);
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_ci_gt, "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 or equal to @var{s2}, a\n"
- "true value otherwise. The character comparison is done\n"
- "case-insensitively.")
-#define FUNC_NAME s_scm_string_ci_gt
-{
- 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]))
- return SCM_BOOL_F;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- return scm_from_size_t (cstart1);
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return scm_from_size_t (cstart1);
- else if (cstart2 < cend2)
- return SCM_BOOL_F;
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
- "value otherwise. The character comparison is done\n"
- "case-insensitively.")
-#define FUNC_NAME s_scm_string_ci_le
-{
- 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]))
- return scm_from_size_t (cstart1);
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- return SCM_BOOL_F;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return SCM_BOOL_F;
- else if (cstart2 < cend2)
- return scm_from_size_t (cstart1);
- else
- return scm_from_size_t (cstart1);
-}
-#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 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]))
- return SCM_BOOL_F;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- return scm_from_size_t (cstart1);
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- return scm_from_size_t (cstart1);
- else if (cstart2 < cend2)
- return SCM_BOOL_F;
- else
- return scm_from_size_t (cstart1);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return the length of the longest common prefix of the two\n"
- "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);
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (cstr1[cstart1] != cstr2[cstart2])
- return scm_from_size_t (len);
- len++;
- cstart1++;
- cstart2++;
- }
- return scm_from_size_t (len);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return the length of the longest common prefix of the two\n"
- "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);
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2]))
- return scm_from_size_t (len);
- len++;
- cstart1++;
- cstart2++;
- }
- return scm_from_size_t (len);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return the length of the longest common suffix of the two\n"
- "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);
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- cend1--;
- cend2--;
- if (cstr1[cend1] != cstr2[cend2])
- return scm_from_size_t (len);
- len++;
- }
- return scm_from_size_t (len);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return the length of the longest common suffix of the two\n"
- "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);
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- cend1--;
- cend2--;
- if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2]))
- return scm_from_size_t (len);
- len++;
- }
- return scm_from_size_t (len);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "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);
- len1 = cend1 - cstart1;
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (cstr1[cstart1] != cstr2[cstart2])
- return scm_from_bool (len == len1);
- len++;
- cstart1++;
- cstart2++;
- }
- return scm_from_bool (len == len1);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "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);
- len1 = cend1 - cstart1;
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2]))
- return scm_from_bool (len == len1);
- len++;
- cstart1++;
- cstart2++;
- }
- return scm_from_bool (len == len1);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "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);
- len1 = cend1 - cstart1;
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- cend1--;
- cend2--;
- if (cstr1[cend1] != cstr2[cend2])
- return scm_from_bool (len == len1);
- len++;
- }
- return scm_from_bool (len == len1);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "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);
- len1 = cend1 - cstart1;
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- cend1--;
- cend2--;
- if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2]))
- return scm_from_bool (len == len1);
- len++;
- }
- return scm_from_bool (len == len1);
-}
-#undef FUNC_NAME
-
-
-/* FIXME::martin: The `S' is to avoid a name clash with the procedure
- in the core, which does not accept a predicate. */
-SCM_DEFINE (scm_string_indexS, "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"
- "\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"
- "\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_indexS
-{
- const char *cstr;
- size_t cstart, cend;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
- if (SCM_CHARP (char_pred))
- {
- char cchr = SCM_CHAR (char_pred);
- while (cstart < cend)
- {
- if (cchr == cstr[cstart])
- return scm_from_size_t (cstart);
- cstart++;
- }
- }
- else if (SCM_CHARSETP (char_pred))
- {
- while (cstart < cend)
- {
- if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
- return scm_from_size_t (cstart);
- cstart++;
- }
- }
- else
- {
- SCM_VALIDATE_PROC (2, char_pred);
- while (cstart < cend)
- {
- SCM res;
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
- if (scm_is_true (res))
- return scm_from_size_t (cstart);
- cstr = scm_i_string_chars (s);
- cstart++;
- }
- }
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-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"
- "\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"
- "\n"
- "@item\n"
- "is in the set if @var{char_pred} is a character set.\n"
- "@end itemize")
-#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);
- if (SCM_CHARP (char_pred))
- {
- char cchr = SCM_CHAR (char_pred);
- while (cstart < cend)
- {
- cend--;
- if (cchr == cstr[cend])
- return scm_from_size_t (cend);
- }
- }
- else if (SCM_CHARSETP (char_pred))
- {
- while (cstart < cend)
- {
- cend--;
- if (SCM_CHARSET_GET (char_pred, cstr[cend]))
- return scm_from_size_t (cend);
- }
- }
- else
- {
- SCM_VALIDATE_PROC (2, char_pred);
- while (cstart < cend)
- {
- SCM res;
- cend--;
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend]));
- if (scm_is_true (res))
- return scm_from_size_t (cend);
- cstr = scm_i_string_chars (s);
- }
- }
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-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"
- "\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"
- "procedure,\n"
- "\n"
- "@item\n"
- "is not in the set if @var{char_pred} is a character set.\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);
- if (SCM_CHARP (char_pred))
- {
- char cchr = SCM_CHAR (char_pred);
- while (cstart < cend)
- {
- if (cchr != cstr[cstart])
- return scm_from_size_t (cstart);
- cstart++;
- }
- }
- else if (SCM_CHARSETP (char_pred))
- {
- while (cstart < cend)
- {
- if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
- return scm_from_size_t (cstart);
- cstart++;
- }
- }
- else
- {
- SCM_VALIDATE_PROC (2, char_pred);
- while (cstart < cend)
- {
- SCM res;
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
- if (scm_is_false (res))
- return scm_from_size_t (cstart);
- cstr = scm_i_string_chars (s);
- cstart++;
- }
- }
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-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"
- "\n"
- "@itemize @bullet\n"
- "@item\n"
- "does not equal @var{char_pred}, if it is character,\n"
- "\n"
- "@item\n"
- "does not satisfy the predicate @var{char_pred}, if it is a\n"
- "procedure,\n"
- "\n"
- "@item\n"
- "is not in the set if @var{char_pred} is a character set.\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);
- if (SCM_CHARP (char_pred))
- {
- char cchr = SCM_CHAR (char_pred);
- while (cstart < cend)
- {
- cend--;
- if (cchr != cstr[cend])
- return scm_from_size_t (cend);
- }
- }
- else if (SCM_CHARSETP (char_pred))
- {
- while (cstart < cend)
- {
- cend--;
- if (!SCM_CHARSET_GET (char_pred, cstr[cend]))
- return scm_from_size_t (cend);
- }
- }
- else
- {
- SCM_VALIDATE_PROC (2, char_pred);
- while (cstart < cend)
- {
- SCM res;
- cend--;
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend]));
- if (scm_is_false (res))
- return scm_from_size_t (cend);
- cstr = scm_i_string_chars (s);
- }
- }
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0,
- (SCM s, SCM char_pred, SCM start, SCM end),
- "Return the count of the number of characters in the string\n"
- "@var{s} 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"
- "\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);
- if (SCM_CHARP (char_pred))
- {
- char cchr = SCM_CHAR (char_pred);
- while (cstart < cend)
- {
- if (cchr == cstr[cstart])
- count++;
- cstart++;
- }
- }
- else if (SCM_CHARSETP (char_pred))
- {
- while (cstart < cend)
- {
- if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
- count++;
- cstart++;
- }
- }
- else
- {
- SCM_VALIDATE_PROC (2, char_pred);
- while (cstart < cend)
- {
- SCM res;
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
- if (scm_is_true (res))
- count++;
- cstr = scm_i_string_chars (s);
- cstart++;
- }
- }
- return scm_from_size_t (count);
-}
-#undef FUNC_NAME
-
-
-/* FIXME::martin: This should definitely get implemented more
- efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
- implementation. */
-SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Does string @var{s1} contain string @var{s2}? Return the index\n"
- "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
- "The optional start/end indices restrict the operation to the\n"
- "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);
- len2 = cend2 - cstart2;
- while (cstart1 <= cend1 - len2)
- {
- i = cstart1;
- j = cstart2;
- while (i < cend1 && j < cend2 && cs1[i] == cs2[j])
- {
- i++;
- j++;
- }
- if (j == cend2)
- return scm_from_size_t (cstart1);
- cstart1++;
- }
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-/* FIXME::martin: This should definitely get implemented more
- efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
- implementation. */
-SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Does string @var{s1} contain string @var{s2}? Return the index\n"
- "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
- "The optional start/end indices restrict the operation to the\n"
- "indicated substrings. Character comparison is done\n"
- "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);
- len2 = cend2 - cstart2;
- while (cstart1 <= cend1 - len2)
- {
- i = cstart1;
- j = cstart2;
- while (i < cend1 && j < cend2 &&
- scm_c_downcase (cs1[i]) == scm_c_downcase (cs2[j]))
- {
- i++;
- j++;
- }
- if (j == cend2)
- return scm_from_size_t (cstart1);
- cstart1++;
- }
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-/* Helper function for the string uppercase conversion functions.
- * No argument checking is performed. */
-static SCM
-string_upcase_x (SCM v, int start, int 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 ();
-
- return v;
-}
-
-
-/* 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 str, SCM start, SCM end),
- "Destructively upcase every character in @code{str}.\n"
- "\n"
- "@lisp\n"
- "(string-upcase! y)\n"
- "@result{} \"ARRDEFG\"\n"
- "y\n"
- "@result{} \"ARRDEFG\"\n"
- "@end lisp")
-#define FUNC_NAME s_scm_string_upcase_xS
-{
- const char *cstr;
- size_t cstart, cend;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
- return string_upcase_x (str, cstart, cend);
-}
-#undef FUNC_NAME
-
-
-/* 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 str, SCM start, SCM end),
- "Upcase every character in @code{str}.")
-#define FUNC_NAME s_scm_string_upcaseS
-{
- const char *cstr;
- size_t cstart, cend;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
- return string_upcase_x (scm_string_copy (str), cstart, cend);
-}
-#undef FUNC_NAME
-
-
-/* Helper function for the string lowercase conversion functions.
- * No argument checking is performed. */
-static SCM
-string_downcase_x (SCM v, int start, int 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 ();
-
- return v;
-}
-
-
-/* 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 str, SCM start, SCM end),
- "Destructively downcase every character in @var{str}.\n"
- "\n"
- "@lisp\n"
- "y\n"
- "@result{} \"ARRDEFG\"\n"
- "(string-downcase! y)\n"
- "@result{} \"arrdefg\"\n"
- "y\n"
- "@result{} \"arrdefg\"\n"
- "@end lisp")
-#define FUNC_NAME s_scm_string_downcase_xS
-{
- const char *cstr;
- size_t cstart, cend;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
- return string_downcase_x (str, cstart, cend);
-}
-#undef FUNC_NAME
-
-
-/* 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 str, SCM start, SCM end),
- "Downcase every character in @var{str}.")
-#define FUNC_NAME s_scm_string_downcaseS
-{
- const char *cstr;
- size_t cstart, cend;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
- return string_downcase_x (scm_string_copy (str), cstart, cend);
-}
-#undef FUNC_NAME
-
-
-/* Helper function for the string capitalization functions.
- * No argument checking is performed. */
-static SCM
-string_titlecase_x (SCM str, int start, int end)
-{
- unsigned char *sz;
- size_t i;
- int in_word = 0;
-
- sz = scm_i_string_writable_chars (str);
- for(i = start; i < end; i++)
- {
- 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;
- }
- scm_i_string_stop_writing ();
-
- return str;
-}
-
-
-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}.")
-#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);
- return string_titlecase_x (str, cstart, cend);
-}
-#undef FUNC_NAME
-
-
-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
-{
- const char *cstr;
- size_t cstart, cend;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 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, int cstart, int cend)
-{
- char tmp;
-
- cend--;
- while (cstart < cend)
- {
- tmp = str[cstart];
- str[cstart] = str[cend];
- str[cend] = tmp;
- cstart++;
- cend--;
- }
-}
-
-
-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"
- "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);
- result = scm_string_copy (str);
- ctarget = scm_i_string_writable_chars (result);
- string_reverse_x (ctarget, cstart, cend);
- scm_i_string_stop_writing ();
- return result;
-}
-#undef FUNC_NAME
-
-
-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"
- "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 ();
-
- scm_remember_upto_here_1 (str);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-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.")
-#define FUNC_NAME s_scm_string_append_shared
-{
- long i;
-
- SCM_VALIDATE_REST_ARGUMENT (ls);
-
- /* Optimize the one-argument case. */
- i = scm_ilength (ls);
- if (i == 1)
- return SCM_CAR (ls);
- else
- return scm_string_append (ls);
-}
-#undef FUNC_NAME
-
-
-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"
- "allocated string.")
-#define FUNC_NAME s_scm_string_concatenate
-{
- long strings = scm_ilength (ls);
- SCM tmp, result;
- size_t len = 0;
- char *p;
-
- /* Validate the string list. */
- if (strings < 0)
- SCM_WRONG_TYPE_ARG (1, ls);
-
- /* Calculate the size of the result string. */
- tmp = ls;
- while (!SCM_NULLP (tmp))
- {
- SCM elt = SCM_CAR (tmp);
- SCM_VALIDATE_STRING (1, elt);
- len += scm_i_string_length (elt);
- tmp = SCM_CDR (tmp);
- }
- result = scm_i_make_string (len, &p);
-
- /* Copy the list elements into the result. */
- tmp = ls;
- while (!SCM_NULLP (tmp))
- {
- SCM elt = SCM_CAR (tmp);
- memmove (p, scm_i_string_chars (elt),
- scm_i_string_length (elt));
- p += scm_i_string_length (elt);
- tmp = SCM_CDR (tmp);
- }
- return result;
-}
-#undef FUNC_NAME
-
-
-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"
- "@smalllisp\n"
- "(string-concatenate (reverse ls))\n"
- "@end smalllisp\n"
- "\n"
- "If the optional argument @var{final_string} is specified, it is\n"
- "consed onto the beginning to @var{ls} before performing the\n"
- "list-reverse and string-concatenate operations. If @var{end}\n"
- "is given, only the characters of @var{final_string} up to index\n"
- "@var{end} are used.\n"
- "\n"
- "Guaranteed to return a freshly allocated string.")
-#define FUNC_NAME s_scm_string_concatenate_reverse
-{
- long strings;
- SCM tmp, result;
- size_t len = 0;
- char * p;
- size_t cend = 0;
-
- /* Check the optional arguments and calculate the additional length
- of the result string. */
- if (!SCM_UNBNDP (final_string))
- {
- SCM_VALIDATE_STRING (2, final_string);
- if (!SCM_UNBNDP (end))
- {
- cend = scm_to_unsigned_integer (end,
- 0,
- scm_i_string_length (final_string));
- }
- else
- {
- cend = scm_i_string_length (final_string);
- }
- len += cend;
- }
- strings = scm_ilength (ls);
- /* Validate the string list. */
- if (strings < 0)
- SCM_WRONG_TYPE_ARG (1, ls);
-
- /* Calculate the length of the result string. */
- tmp = ls;
- while (!SCM_NULLP (tmp))
- {
- SCM elt = SCM_CAR (tmp);
- SCM_VALIDATE_STRING (1, elt);
- len += scm_i_string_length (elt);
- tmp = SCM_CDR (tmp);
- }
-
- result = scm_i_make_string (len, &p);
-
- p += len;
-
- /* Construct the result string, possibly by using the optional final
- string. */
- if (!SCM_UNBNDP (final_string))
- {
- p -= cend;
- memmove (p, scm_i_string_chars (final_string), cend);
- }
- tmp = ls;
- while (!SCM_NULLP (tmp))
- {
- SCM elt = SCM_CAR (tmp);
- p -= scm_i_string_length (elt);
- memmove (p, scm_i_string_chars (elt),
- scm_i_string_length (elt));
- tmp = SCM_CDR (tmp);
- }
- return result;
-}
-#undef FUNC_NAME
-
-
-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}.")
-#define FUNC_NAME s_scm_string_concatenate_shared
-{
- /* Optimize the one-string case. */
- long i = scm_ilength (ls);
- if (i == 1)
- {
- SCM_VALIDATE_STRING (1, SCM_CAR (ls));
- return SCM_CAR (ls);
- }
- return scm_string_concatenate (ls);
-}
-#undef FUNC_NAME
-
-
-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.")
-#define FUNC_NAME s_scm_string_concatenate_reverse_shared
-{
- /* Just call the non-sharing version. */
- return scm_string_concatenate_reverse (ls, final_string, end);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
- (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.")
-#define FUNC_NAME s_scm_string_map
-{
- const char *cstr;
- char *p;
- size_t cstart, cend;
- SCM result;
-
- SCM_VALIDATE_PROC (1, proc);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
- 3, start, cstart,
- 4, end, cend);
- result = scm_i_make_string (cend - cstart, &p);
- while (cstart < cend)
- {
- unsigned int c = (unsigned char) cstr[cstart];
- SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (c));
- if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
- cstr = scm_i_string_chars (s);
- cstart++;
- *p++ = SCM_CHAR (ch);
- }
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0,
- (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"
- "modified in-place, the return value is not specified.")
-#define FUNC_NAME s_scm_string_map_x
-{
- size_t cstart, cend;
-
- SCM_VALIDATE_PROC (1, proc);
- MY_VALIDATE_SUBSTRING_SPEC (2, s,
- 3, start, cstart,
- 4, end, cend);
- while (cstart < cend)
- {
- 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);
- cstart++;
- }
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0,
- (SCM kons, SCM knil, SCM s, SCM start, SCM end),
- "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
- "as the terminating element, from left to right. @var{kons}\n"
- "must expect two arguments: The actual character and the last\n"
- "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);
- 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);
- cstart++;
- }
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0,
- (SCM kons, SCM knil, SCM s, SCM start, SCM end),
- "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
- "as the terminating element, from right to left. @var{kons}\n"
- "must expect two arguments: The actual character and the last\n"
- "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);
- 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);
- cend--;
- }
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0,
- (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final),
- "@itemize @bullet\n"
- "@item @var{g} is used to generate a series of @emph{seed}\n"
- "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
- "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
- "@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"
- "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"
- "of the constructed string; it default to the empty\n"
- "string.\n"
- "@item @var{make_final} is applied to the terminal seed\n"
- "value (on which @var{p} returns true) to produce\n"
- "the final/rightmost portion of the constructed string.\n"
- "It defaults to @code{(lambda (x) "")}.\n"
- "@end itemize")
-#define FUNC_NAME s_scm_string_unfold
-{
- SCM res, ans;
-
- SCM_VALIDATE_PROC (1, p);
- SCM_VALIDATE_PROC (2, f);
- SCM_VALIDATE_PROC (3, g);
- if (!SCM_UNBNDP (base))
- {
- SCM_VALIDATE_STRING (5, base);
- ans = base;
- }
- else
- ans = scm_i_make_string (0, NULL);
- if (!SCM_UNBNDP (make_final))
- SCM_VALIDATE_PROC (6, make_final);
-
- res = scm_call_1 (p, seed);
- while (scm_is_false (res))
- {
- SCM str;
- char *ptr;
- 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);
-
- 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_call_1 (make_final, seed);
- return scm_string_append (scm_list_2 (ans, res));
- }
- else
- return ans;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0,
- (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final),
- "@itemize @bullet\n"
- "@item @var{g} is used to generate a series of @emph{seed}\n"
- "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
- "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
- "@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"
- "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"
- "of the constructed string; it default to the empty\n"
- "string.\n"
- "@item @var{make_final} is applied to the terminal seed\n"
- "value (on which @var{p} returns true) to produce\n"
- "the final/leftmost portion of the constructed string.\n"
- "It defaults to @code{(lambda (x) "")}.\n"
- "@end itemize")
-#define FUNC_NAME s_scm_string_unfold_right
-{
- SCM res, ans;
-
- SCM_VALIDATE_PROC (1, p);
- SCM_VALIDATE_PROC (2, f);
- SCM_VALIDATE_PROC (3, g);
- if (!SCM_UNBNDP (base))
- {
- SCM_VALIDATE_STRING (5, base);
- ans = base;
- }
- else
- ans = scm_i_make_string (0, NULL);
- if (!SCM_UNBNDP (make_final))
- SCM_VALIDATE_PROC (6, make_final);
-
- res = scm_call_1 (p, seed);
- while (scm_is_false (res))
- {
- SCM str;
- char *ptr;
- 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);
-
- 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_call_1 (make_final, seed);
- return scm_string_append (scm_list_2 (res, ans));
- }
- else
- return ans;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_for_each, "string-for-each", 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
-{
- const char *cstr;
- size_t cstart, cend;
-
- SCM_VALIDATE_PROC (1, proc);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
- 3, start, cstart,
- 4, end, cend);
- while (cstart < cend)
- {
- unsigned int c = (unsigned char) cstr[cstart];
- scm_call_1 (proc, SCM_MAKE_CHAR (c));
- cstr = scm_i_string_chars (s);
- 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
-{
- const char *cstr;
- size_t cstart, cend;
-
- SCM_VALIDATE_PROC (1, proc);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
- 3, start, cstart,
- 4, end, cend);
- while (cstart < cend)
- {
- scm_call_1 (proc, scm_from_size_t (cstart));
- cstart++;
- }
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0,
- (SCM s, SCM from, SCM to, SCM start, SCM end),
- "This is the @emph{extended substring} procedure that implements\n"
- "replicated copying of a substring of some string.\n"
- "\n"
- "@var{s} is a string, @var{start} and @var{end} are optional\n"
- "arguments that demarcate a substring of @var{s}, defaulting to\n"
- "0 and the length of @var{s}. Replicate this substring up and\n"
- "down index space, in both the positive and negative directions.\n"
- "@code{xsubstring} returns the substring of this string\n"
- "beginning at index @var{from}, and ending at @var{to}, which\n"
- "defaults to @var{from} + (@var{end} - @var{start}).")
-#define FUNC_NAME s_scm_xsubstring
-{
- const char *cs;
- char *p;
- size_t cstart, cend, cfrom, cto;
- SCM result;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cs,
- 4, start, cstart,
- 5, end, cend);
- cfrom = scm_to_size_t (from);
- if (SCM_UNBNDP (to))
- cto = cfrom + (cend - cstart);
- else
- cto = scm_to_size_t (to);
- 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);
-
- while (cfrom < cto)
- {
- int t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart);
- if (cfrom < 0)
- *p = cs[(cend - cstart) - t];
- else
- *p = cs[t];
- cfrom++;
- p++;
- }
- scm_remember_upto_here_1 (s);
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0,
- (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end),
- "Exactly the same as @code{xsubstring}, but the extracted text\n"
- "is written into the string @var{target} starting at index\n"
- "@var{tstart}. The operation is not defined if @code{(eq?\n"
- "@var{target} @var{s})} or these arguments share storage -- you\n"
- "cannot copy a string on top of itself.")
-#define FUNC_NAME s_scm_string_xcopy_x
-{
- char *p;
- const char *cs;
- size_t ctstart, csfrom, csto, cstart, cend;
- SCM dummy = SCM_UNDEFINED;
- int cdummy;
-
- MY_VALIDATE_SUBSTRING_SPEC (1, target,
- 2, tstart, ctstart,
- 2, dummy, cdummy);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cs,
- 6, start, cstart,
- 7, end, cend);
- csfrom = scm_to_size_t (sfrom);
- if (SCM_UNBNDP (sto))
- csto = csfrom + (cend - cstart);
- else
- csto = scm_to_size_t (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;
- while (csfrom < csto)
- {
- int 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 ();
-
- scm_remember_upto_here_2 (target, s);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return the string @var{s1}, but with the characters\n"
- "@var{start1} @dots{} @var{end1} replaced by the characters\n"
- "@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_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
- result = scm_i_make_string (cstart1 + (cend2 - cstart2) +
- scm_i_string_length (s1) - cend1, &p);
- 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 result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
- (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 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
-{
- const char *cstr;
- size_t cstart, cend;
- SCM result = SCM_EOL;
-
- static SCM charset_graphic = SCM_BOOL_F;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
-
- if (SCM_UNBNDP (token_set))
- {
- if (charset_graphic == SCM_BOOL_F)
- {
- 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;
- }
-
- if (SCM_CHARSETP (token_set))
- {
- int idx;
-
- while (cstart < cend)
- {
- while (cstart < cend)
- {
- if (SCM_CHARSET_GET (token_set, cstr[cend - 1]))
- break;
- cend--;
- }
- if (cstart >= cend)
- break;
- idx = cend;
- while (cstart < cend)
- {
- if (!SCM_CHARSET_GET (token_set, cstr[cend - 1]))
- break;
- cend--;
- }
- result = scm_cons (scm_c_substring (s, cend, idx), result);
- cstr = scm_i_string_chars (s);
- }
- }
- else SCM_WRONG_TYPE_ARG (2, token_set);
- scm_remember_upto_here_1 (s);
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
- (SCM s, SCM char_pred, SCM start, SCM end),
- "Filter the string @var{s}, retaining only those characters that\n"
- "satisfy the @var{char_pred} argument. If the argument is a\n"
- "procedure, it is applied to each character as a predicate, if\n"
- "it is a character, it is tested for equality and if it is a\n"
- "character set, it is tested for 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_CHARP (char_pred))
- {
- SCM ls = SCM_EOL;
- char chr;
-
- chr = SCM_CHAR (char_pred);
- idx = cstart;
- while (idx < cend)
- {
- if (cstr[idx] == chr)
- ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
- cstr = scm_i_string_chars (s);
- idx++;
- }
- result = scm_reverse_list_to_string (ls);
- }
- else if (SCM_CHARSETP (char_pred))
- {
- SCM ls = SCM_EOL;
-
- idx = cstart;
- while (idx < cend)
- {
- if (SCM_CHARSET_GET (char_pred, cstr[idx]))
- ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
- cstr = scm_i_string_chars (s);
- idx++;
- }
- result = scm_reverse_list_to_string (ls);
- }
- else
- {
- SCM ls = SCM_EOL;
-
- SCM_VALIDATE_PROC (2, char_pred);
- idx = cstart;
- while (idx < cend)
- {
- SCM res;
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx]));
- if (scm_is_true (res))
- ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
- cstr = scm_i_string_chars (s);
- idx++;
- }
- result = scm_reverse_list_to_string (ls);
- }
- scm_remember_upto_here_1 (s);
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
- (SCM s, SCM char_pred, SCM start, SCM end),
- "Filter the string @var{s}, retaining only those characters that\n"
- "do not satisfy the @var{char_pred} argument. If the argument\n"
- "is a procedure, it is applied to each character as a predicate,\n"
- "if it is a character, it is tested for equality and if it is a\n"
- "character set, it is tested for membership.")
-#define FUNC_NAME s_scm_string_delete
+void
+scm_init_srfi_13 (void)
{
- 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_CHARP (char_pred))
- {
- SCM ls = SCM_EOL;
- char chr;
-
- chr = SCM_CHAR (char_pred);
- idx = cstart;
- while (idx < cend)
- {
- if (cstr[idx] != chr)
- ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
- cstr = scm_i_string_chars (s);
- idx++;
- }
- result = scm_reverse_list_to_string (ls);
- }
- else if (SCM_CHARSETP (char_pred))
- {
- SCM ls = SCM_EOL;
-
- idx = cstart;
- while (idx < cend)
- {
- if (!SCM_CHARSET_GET (char_pred, cstr[idx]))
- ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
- cstr = scm_i_string_chars (s);
- idx++;
- }
- result = scm_reverse_list_to_string (ls);
- }
- else
- {
- SCM ls = SCM_EOL;
-
- SCM_VALIDATE_PROC (2, char_pred);
- idx = cstart;
- while (idx < cend)
- {
- SCM res;
- res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx]));
- if (scm_is_false (res))
- ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
- cstr = scm_i_string_chars (s);
- idx++;
- }
- result = scm_reverse_list_to_string (ls);
- }
- return result;
}
-#undef FUNC_NAME
-
-/* Initialize the SRFI-13 module. This function will be called by the
- loading Scheme module. */
void
-scm_init_srfi_13 (void)
+scm_init_srfi_13_14 (void)
{
- /* 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"
}
-
-/* End of srfi-13.c. */
diff --git a/srfi/srfi-13.h b/srfi/srfi-13.h
index 68def2842..c4cf0cb60 100644
--- a/srfi/srfi-13.h
+++ b/srfi/srfi-13.h
@@ -1,6 +1,7 @@
#ifndef SCM_SRFI_13_H
#define SCM_SRFI_13_H
-/* srfi-13.c --- SRFI-13 procedures for Guile
+
+/* SRFI-13 procedures for Guile
*
* Copyright (C) 2001, 2004 Free Software Foundation, Inc.
*
@@ -20,6 +21,10 @@
*/
+/* All SRFI-13 procedures are in in the core now. */
+
+#include <libguile.h>
+
/* SCM_SRFI1314_API is a macro prepended to all function and data definitions
which should be exported or imported in the resulting dynamic link
library in the Win32 port. */
@@ -35,80 +40,17 @@
SCM_SRFI1314_API void scm_init_srfi_13 (void);
SCM_SRFI1314_API void scm_init_srfi_13_14 (void);
-SCM_SRFI1314_API SCM scm_string_any (SCM pred, SCM s, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_every (SCM pred, SCM s, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_tabulate (SCM proc, SCM len);
-SCM_SRFI1314_API SCM scm_string_to_listS (SCM str, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_reverse_list_to_string (SCM chrs);
-SCM_SRFI1314_API SCM scm_string_join (SCM ls, SCM delimiter, SCM grammar);
-SCM_SRFI1314_API SCM scm_string_copyS (SCM str, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_substring_sharedS (SCM str, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_copy_x (SCM target, SCM tstart, SCM s, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_take (SCM s, SCM n);
-SCM_SRFI1314_API SCM scm_string_drop (SCM s, SCM n);
-SCM_SRFI1314_API SCM scm_string_take_right (SCM s, SCM n);
-SCM_SRFI1314_API SCM scm_string_drop_right (SCM s, SCM n);
-SCM_SRFI1314_API SCM scm_string_pad (SCM s, SCM len, SCM chr, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_pad_right (SCM s, SCM len, SCM chr, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_trim (SCM s, SCM char_pred, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_trim_right (SCM s, SCM char_pred, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_trim_both (SCM s, SCM char_pred, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_fill_xS (SCM str, SCM chr, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_compare (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_compare_ci (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_ci_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_ci_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_ci_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_ci_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_ci_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_ci_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_prefix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_prefix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_suffix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_suffix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_prefix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_prefix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_suffix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_suffix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_indexS (SCM s, SCM char_pred, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_index_right (SCM s, SCM char_pred, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_skip (SCM s, SCM char_pred, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_skip_right (SCM s, SCM char_pred, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_count (SCM s, SCM char_pred, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_contains (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_contains_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_upcase_xS (SCM str, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_upcaseS (SCM str, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_downcase_xS (SCM str, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_downcaseS (SCM str, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_titlecase_x (SCM str, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_titlecase (SCM str, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_reverse (SCM str, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_reverse_x (SCM str, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_append_shared (SCM ls);
-SCM_SRFI1314_API SCM scm_string_concatenate (SCM ls);
-SCM_SRFI1314_API SCM scm_string_concatenate_shared (SCM ls);
-SCM_SRFI1314_API SCM scm_string_concatenate_reverse (SCM ls, SCM final_string, SCM end);
-SCM_SRFI1314_API SCM scm_string_concatenate_reverse_shared (SCM ls, SCM final_string, SCM end);
-SCM_SRFI1314_API SCM scm_string_map (SCM proc, SCM s, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_map_x (SCM proc, SCM s, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_fold (SCM kons, SCM knil, SCM s, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_fold_right (SCM kons, SCM knil, SCM s, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final);
-SCM_SRFI1314_API SCM scm_string_unfold_right (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final);
-SCM_SRFI1314_API SCM scm_string_for_each (SCM proc, SCM s, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_for_each_index (SCM proc, SCM s, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_xsubstring (SCM s, SCM from, SCM to, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_xcopy_x (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_replace (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
-SCM_SRFI1314_API SCM scm_string_tokenize (SCM s, SCM token_char, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_filter (SCM s, SCM char_pred, SCM start, SCM end);
-SCM_SRFI1314_API SCM scm_string_delete (SCM s, SCM char_pred, SCM start, SCM end);
+/* The following functions have new names in the core.
+ */
+
+#define scm_string_to_listS scm_substring_to_list
+#define scm_string_copyS scm_substring_copy
+#define scm_substring_sharedS scm_substring_shared
+#define scm_string_fill_xS scm_substring_fill_x
+#define scm_string_indexS scm_string_index
+#define scm_string_upcase_xS scm_substring_upcase_x
+#define scm_string_upcaseS scm_substring_upcase
+#define scm_string_downcase_xS scm_substring_downcase_x
+#define scm_string_downcaseS scm_substring_downcase
#endif /* SCM_SRFI_13_H */
diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm
index b9b8d03ca..49420f70f 100644
--- a/srfi/srfi-13.scm
+++ b/srfi/srfi-13.scm
@@ -19,28 +19,35 @@
;;; Commentary:
;; This module is fully documented in the Guile Reference Manual.
+;;
+;; All procedures are in the core and are simply reexported here.
;;; Code:
-(define-module (srfi srfi-13)
- :export (
+(define-module (srfi srfi-13))
+
+(re-export
;;; Predicates
- ;; string? string-null? <= in the core
- string-any string-every
+ string?
+ string-null?
+ string-any
+ string-every
;;; Constructors
- ;; make-string string <= in the core
+ make-string
+ string
string-tabulate
;;; List/string conversion
- ;; string->list extended
- ;; list->string <= in the core
+ string->list
+ list->string
reverse-list->string
string-join
;;; Selection
- ;; string-length string-ref <= in the core
- ;; string-copy extended
+ string-length
+ string-ref
+ string-copy
substring/shared
string-copy!
string-take string-take-right
@@ -50,11 +57,12 @@
string-trim-both
;;; Modification
- ;; string-set! <= in the core
- ;; string-fill! extended
+ string-set!
+ string-fill!
;;; Comparison
- string-compare string-compare-ci
+ string-compare
+ string-compare-ci
string= string<>
string< string>
string<= string>=
@@ -74,21 +82,24 @@
string-suffix-ci?
;;; Searching
- ;; string-index extended
+ string-index
string-index-right
string-skip string-skip-right
string-count
string-contains string-contains-ci
;;; Alphabetic case mapping
-
- ;; string-upcase string-upcase! extended
- ;; string-downcase string-downcase! extended
- string-titlecase string-titlecase!
+ string-upcase
+ string-upcase!
+ string-downcase
+ string-downcase!
+ string-titlecase
+ string-titlecase!
;;; Reverse/Append
- string-reverse string-reverse!
- ;; string-append <= in the core
+ string-reverse
+ string-reverse!
+ string-append
string-append/shared
string-concatenate
string-concatenate-reverse
@@ -105,7 +116,8 @@
string-for-each-index
;;; Replicate/Rotate
- xsubstring string-xcopy!
+ xsubstring
+ string-xcopy!
;;; Miscellaneous
string-replace
@@ -113,43 +125,8 @@
;;; Filtering/Deleting
string-filter
- string-delete
- )
- :replace (string->list string-copy string-fill!
- string-upcase! string-upcase string-downcase! string-downcase
- string-index substring/shared)
- )
+ string-delete)
(cond-expand-provide (current-module) '(srfi-13))
-(load-extension "libguile-srfi-srfi-13-14" "scm_init_srfi_13")
-
-(define string-hash
- (lambda (s . rest)
- (let ((bound (if (pair? rest)
- (or (car rest)
- 871)
- 871))
- (start (if (and (pair? rest) (pair? (cdr rest)))
- (cadr rest)
- 0))
- (end (if (and (pair? rest) (pair? (cdr rest)) (pair? (cddr rest)))
- (caddr rest)
- (string-length s))))
- (hash (substring/shared s start end) bound))))
-
-(define string-hash-ci
- (lambda (s . rest)
- (let ((bound (if (pair? rest)
- (or (car rest)
- 871)
- 871))
- (start (if (and (pair? rest) (pair? (cdr rest)))
- (cadr rest)
- 0))
- (end (if (and (pair? rest) (pair? (cdr rest)) (pair? (cddr rest)))
- (caddr rest)
- (string-length s))))
- (hash (string-upcase (substring/shared s start end)) bound))))
-
;;; srfi-13.scm ends here
diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c
index 4c7812512..c2fd02c29 100644
--- a/srfi/srfi-14.c
+++ b/srfi/srfi-14.c
@@ -1,4 +1,4 @@
-/* srfi-14.c --- SRFI-14 procedures for Guile
+/* srfi-14.c --- Old place of SRFI-14 procedures for Guile
*
* Copyright (C) 2001, 2004 Free Software Foundation, Inc.
*
@@ -17,1406 +17,14 @@
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
+#include "srfi/srfi-14.h"
-#include <string.h>
-
-#include <libguile.h>
-
-#include "srfi-14.h"
-
-
-#define SCM_CHARSET_SET(cs, idx) \
- (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= \
- (1L << ((idx) % SCM_BITS_PER_LONG)))
-
-#define BYTES_PER_CHARSET (SCM_CHARSET_SIZE / 8)
-#define LONGS_PER_CHARSET (SCM_CHARSET_SIZE / SCM_BITS_PER_LONG)
-
-
-/* Smob type code for character sets. */
-int scm_tc16_charset = 0;
-
-
-/* Smob print hook for character sets. */
-static int
-charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- int i;
- int first = 1;
-
- scm_puts ("#<charset {", port);
- for (i = 0; i < SCM_CHARSET_SIZE; i++)
- if (SCM_CHARSET_GET (charset, i))
- {
- if (first)
- first = 0;
- else
- scm_puts (" ", port);
- scm_write (SCM_MAKE_CHAR (i), port);
- }
- scm_puts ("}>", port);
- return 1;
-}
-
-
-/* Smob free hook for character sets. */
-static size_t
-charset_free (SCM charset)
-{
- return scm_smob_free (charset);
-}
-
-
-/* Create a new, empty character set. */
-static SCM
-make_char_set (const char * func_name)
-{
- long * p;
-
- p = scm_gc_malloc (BYTES_PER_CHARSET, "character-set");
- memset (p, 0, BYTES_PER_CHARSET);
- SCM_RETURN_NEWSMOB (scm_tc16_charset, p);
-}
-
-
-SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a character set, @code{#f}\n"
- "otherwise.")
-#define FUNC_NAME s_scm_char_set_p
-{
- return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_charset, obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1,
- (SCM char_sets),
- "Return @code{#t} if all given character sets are equal.")
-#define FUNC_NAME s_scm_char_set_eq
-{
- int argnum = 1;
- long *cs1_data = NULL;
-
- SCM_VALIDATE_REST_ARGUMENT (char_sets);
-
- while (!SCM_NULLP (char_sets))
- {
- SCM csi = SCM_CAR (char_sets);
- long *csi_data;
-
- SCM_VALIDATE_SMOB (argnum, csi, charset);
- argnum++;
- csi_data = (long *) SCM_SMOB_DATA (csi);
- if (cs1_data == NULL)
- cs1_data = csi_data;
- else if (memcmp (cs1_data, csi_data, BYTES_PER_CHARSET) != 0)
- return SCM_BOOL_F;
- char_sets = SCM_CDR (char_sets);
- }
- return SCM_BOOL_T;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1,
- (SCM char_sets),
- "Return @code{#t} if every character set @var{cs}i is a subset\n"
- "of character set @var{cs}i+1.")
-#define FUNC_NAME s_scm_char_set_leq
-{
- int argnum = 1;
- long *prev_data = NULL;
-
- SCM_VALIDATE_REST_ARGUMENT (char_sets);
-
- while (!SCM_NULLP (char_sets))
- {
- SCM csi = SCM_CAR (char_sets);
- long *csi_data;
-
- SCM_VALIDATE_SMOB (argnum, csi, charset);
- argnum++;
- csi_data = (long *) SCM_SMOB_DATA (csi);
- if (prev_data)
- {
- int k;
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- {
- if ((prev_data[k] & csi_data[k]) != prev_data[k])
- return SCM_BOOL_F;
- }
- }
- prev_data = csi_data;
- char_sets = SCM_CDR (char_sets);
- }
- return SCM_BOOL_T;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0,
- (SCM cs, SCM bound),
- "Compute a hash value for the character set @var{cs}. If\n"
- "@var{bound} is given and non-zero, it restricts the\n"
- "returned value to the range 0 @dots{} @var{bound - 1}.")
-#define FUNC_NAME s_scm_char_set_hash
-{
- const unsigned long default_bnd = 871;
- unsigned long bnd;
- long * p;
- unsigned long val = 0;
- int k;
-
- SCM_VALIDATE_SMOB (1, cs, charset);
-
- if (SCM_UNBNDP (bound))
- bnd = default_bnd;
- else
- {
- bnd = scm_to_ulong (bound);
- if (bnd == 0)
- bnd = default_bnd;
- }
-
- p = (long *) SCM_SMOB_DATA (cs);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- {
- if (p[k] != 0)
- val = p[k] + (val << 1);
- }
- return scm_from_ulong (val % bnd);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0,
- (SCM cs),
- "Return a cursor into the character set @var{cs}.")
-#define FUNC_NAME s_scm_char_set_cursor
-{
- int idx;
-
- SCM_VALIDATE_SMOB (1, cs, charset);
- for (idx = 0; idx < SCM_CHARSET_SIZE; idx++)
- {
- if (SCM_CHARSET_GET (cs, idx))
- break;
- }
- return SCM_I_MAKINUM (idx);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0,
- (SCM cs, SCM cursor),
- "Return the character at the current cursor position\n"
- "@var{cursor} in the character set @var{cs}. It is an error to\n"
- "pass a cursor for which @code{end-of-char-set?} returns true.")
-#define FUNC_NAME s_scm_char_set_ref
-{
- size_t ccursor = scm_to_size_t (cursor);
- SCM_VALIDATE_SMOB (1, cs, charset);
-
- if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor))
- SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
- return SCM_MAKE_CHAR (ccursor);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0,
- (SCM cs, SCM cursor),
- "Advance the character set cursor @var{cursor} to the next\n"
- "character in the character set @var{cs}. It is an error if the\n"
- "cursor given satisfies @code{end-of-char-set?}.")
-#define FUNC_NAME s_scm_char_set_cursor_next
-{
- size_t ccursor = scm_to_size_t (cursor);
- SCM_VALIDATE_SMOB (1, cs, charset);
-
- if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor))
- SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
- for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++)
- {
- if (SCM_CHARSET_GET (cs, ccursor))
- break;
- }
- return SCM_I_MAKINUM (ccursor);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0,
- (SCM cursor),
- "Return @code{#t} if @var{cursor} has reached the end of a\n"
- "character set, @code{#f} otherwise.")
-#define FUNC_NAME s_scm_end_of_char_set_p
-{
- size_t ccursor = scm_to_size_t (cursor);
- return scm_from_bool (ccursor >= SCM_CHARSET_SIZE);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0,
- (SCM kons, SCM knil, SCM cs),
- "Fold the procedure @var{kons} over the character set @var{cs},\n"
- "initializing it with @var{knil}.")
-#define FUNC_NAME s_scm_char_set_fold
-{
- int k;
-
- SCM_VALIDATE_PROC (1, kons);
- SCM_VALIDATE_SMOB (3, cs, charset);
-
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- {
- knil = scm_call_2 (kons, SCM_MAKE_CHAR (k), knil);
- }
- return knil;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0,
- (SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
- "This is a fundamental constructor for character sets.\n"
- "@itemize @bullet\n"
- "@item @var{g} is used to generate a series of ``seed'' values\n"
- "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
- "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
- "@item @var{p} tells us when to stop -- when it returns true\n"
- "when applied to one of the seed values.\n"
- "@item @var{f} maps each seed value to a character. These\n"
- "characters are added to the base character set @var{base_cs} to\n"
- "form the result; @var{base_cs} defaults to the empty set.\n"
- "@end itemize")
-#define FUNC_NAME s_scm_char_set_unfold
-{
- SCM result, tmp;
-
- SCM_VALIDATE_PROC (1, p);
- SCM_VALIDATE_PROC (2, f);
- SCM_VALIDATE_PROC (3, g);
- if (!SCM_UNBNDP (base_cs))
- {
- SCM_VALIDATE_SMOB (5, base_cs, charset);
- result = scm_char_set_copy (base_cs);
- }
- else
- result = make_char_set (FUNC_NAME);
-
- tmp = scm_call_1 (p, seed);
- while (scm_is_false (tmp))
- {
- SCM ch = scm_call_1 (f, seed);
- if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
- SCM_CHARSET_SET (result, SCM_CHAR (ch));
-
- seed = scm_call_1 (g, seed);
- tmp = scm_call_1 (p, seed);
- }
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0,
- (SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
- "This is a fundamental constructor for character sets.\n"
- "@itemize @bullet\n"
- "@item @var{g} is used to generate a series of ``seed'' values\n"
- "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
- "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
- "@item @var{p} tells us when to stop -- when it returns true\n"
- "when applied to one of the seed values.\n"
- "@item @var{f} maps each seed value to a character. These\n"
- "characters are added to the base character set @var{base_cs} to\n"
- "form the result; @var{base_cs} defaults to the empty set.\n"
- "@end itemize")
-#define FUNC_NAME s_scm_char_set_unfold_x
-{
- SCM tmp;
-
- SCM_VALIDATE_PROC (1, p);
- SCM_VALIDATE_PROC (2, f);
- SCM_VALIDATE_PROC (3, g);
- SCM_VALIDATE_SMOB (5, base_cs, charset);
-
- tmp = scm_call_1 (p, seed);
- while (scm_is_false (tmp))
- {
- SCM ch = scm_call_1 (f, seed);
- if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
- SCM_CHARSET_SET (base_cs, SCM_CHAR (ch));
-
- seed = scm_call_1 (g, seed);
- tmp = scm_call_1 (p, seed);
- }
- return base_cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0,
- (SCM proc, SCM cs),
- "Apply @var{proc} to every character in the character set\n"
- "@var{cs}. The return value is not specified.")
-#define FUNC_NAME s_scm_char_set_for_each
-{
- int k;
-
- SCM_VALIDATE_PROC (1, proc);
- SCM_VALIDATE_SMOB (2, cs, charset);
-
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- scm_call_1 (proc, SCM_MAKE_CHAR (k));
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0,
- (SCM proc, SCM cs),
- "Map the procedure @var{proc} over every character in @var{cs}.\n"
- "@var{proc} must be a character -> character procedure.")
-#define FUNC_NAME s_scm_char_set_map
-{
- SCM result;
- int k;
-
- SCM_VALIDATE_PROC (1, proc);
- SCM_VALIDATE_SMOB (2, cs, charset);
-
- result = make_char_set (FUNC_NAME);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- {
- SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (k));
- if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
- SCM_CHARSET_SET (result, SCM_CHAR (ch));
- }
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0,
- (SCM cs),
- "Return a newly allocated character set containing all\n"
- "characters in @var{cs}.")
-#define FUNC_NAME s_scm_char_set_copy
-{
- SCM ret;
- long * p1, * p2;
- int k;
-
- SCM_VALIDATE_SMOB (1, cs, charset);
- ret = make_char_set (FUNC_NAME);
- p1 = (long *) SCM_SMOB_DATA (cs);
- p2 = (long *) SCM_SMOB_DATA (ret);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p2[k] = p1[k];
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1,
- (SCM rest),
- "Return a character set containing all given characters.")
-#define FUNC_NAME s_scm_char_set
-{
- SCM cs;
- long * p;
- int argnum = 1;
-
- SCM_VALIDATE_REST_ARGUMENT (rest);
- cs = make_char_set (FUNC_NAME);
- p = (long *) SCM_SMOB_DATA (cs);
- while (!SCM_NULLP (rest))
- {
- int c;
-
- SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c);
- argnum++;
- rest = SCM_CDR (rest);
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
- }
- return cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0,
- (SCM list, SCM base_cs),
- "Convert the character list @var{list} to a character set. If\n"
- "the character set @var{base_cs} is given, the character in this\n"
- "set are also included in the result.")
-#define FUNC_NAME s_scm_list_to_char_set
-{
- SCM cs;
- long * p;
-
- SCM_VALIDATE_LIST (1, list);
- if (SCM_UNBNDP (base_cs))
- cs = make_char_set (FUNC_NAME);
- else
- {
- SCM_VALIDATE_SMOB (2, base_cs, charset);
- cs = scm_char_set_copy (base_cs);
- }
- p = (long *) SCM_SMOB_DATA (cs);
- while (!SCM_NULLP (list))
- {
- SCM chr = SCM_CAR (list);
- int c;
-
- SCM_VALIDATE_CHAR_COPY (0, chr, c);
- list = SCM_CDR (list);
-
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
- }
- return cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0,
- (SCM list, SCM base_cs),
- "Convert the character list @var{list} to a character set. The\n"
- "characters are added to @var{base_cs} and @var{base_cs} is\n"
- "returned.")
-#define FUNC_NAME s_scm_list_to_char_set_x
-{
- long * p;
-
- SCM_VALIDATE_LIST (1, list);
- SCM_VALIDATE_SMOB (2, base_cs, charset);
- p = (long *) SCM_SMOB_DATA (base_cs);
- while (!SCM_NULLP (list))
- {
- SCM chr = SCM_CAR (list);
- int c;
-
- SCM_VALIDATE_CHAR_COPY (0, chr, c);
- list = SCM_CDR (list);
-
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
- }
- return base_cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0,
- (SCM str, SCM base_cs),
- "Convert the string @var{str} to a character set. If the\n"
- "character set @var{base_cs} is given, the characters in this\n"
- "set are also included in the result.")
-#define FUNC_NAME s_scm_string_to_char_set
-{
- SCM cs;
- long * p;
- const char * s;
- size_t k = 0, len;
-
- SCM_VALIDATE_STRING (1, str);
- if (SCM_UNBNDP (base_cs))
- cs = make_char_set (FUNC_NAME);
- else
- {
- SCM_VALIDATE_SMOB (2, base_cs, charset);
- cs = scm_char_set_copy (base_cs);
- }
- p = (long *) SCM_SMOB_DATA (cs);
- s = scm_i_string_chars (str);
- len = scm_i_string_length (str);
- while (k < len)
- {
- int c = s[k++];
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
- }
- scm_remember_upto_here_1 (str);
- return cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0,
- (SCM str, SCM base_cs),
- "Convert the string @var{str} to a character set. The\n"
- "characters from the string are added to @var{base_cs}, and\n"
- "@var{base_cs} is returned.")
-#define FUNC_NAME s_scm_string_to_char_set_x
-{
- long * p;
- const char * s;
- size_t k = 0, len;
-
- SCM_VALIDATE_STRING (1, str);
- SCM_VALIDATE_SMOB (2, base_cs, charset);
- p = (long *) SCM_SMOB_DATA (base_cs);
- s = scm_i_string_chars (str);
- len = scm_i_string_length (str);
- while (k < len)
- {
- int c = s[k++];
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
- }
- scm_remember_upto_here_1 (str);
- return base_cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0,
- (SCM pred, SCM cs, SCM base_cs),
- "Return a character set containing every character from @var{cs}\n"
- "so that it satisfies @var{pred}. If provided, the characters\n"
- "from @var{base_cs} are added to the result.")
-#define FUNC_NAME s_scm_char_set_filter
-{
- SCM ret;
- int k;
- long * p;
-
- SCM_VALIDATE_PROC (1, pred);
- SCM_VALIDATE_SMOB (2, cs, charset);
- if (!SCM_UNBNDP (base_cs))
- {
- SCM_VALIDATE_SMOB (3, base_cs, charset);
- ret = scm_char_set_copy (base_cs);
- }
- else
- ret = make_char_set (FUNC_NAME);
- p = (long *) SCM_SMOB_DATA (ret);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- {
- if (SCM_CHARSET_GET (cs, k))
- {
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
-
- if (scm_is_true (res))
- p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG);
- }
- }
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0,
- (SCM pred, SCM cs, SCM base_cs),
- "Return a character set containing every character from @var{cs}\n"
- "so that it satisfies @var{pred}. The characters are added to\n"
- "@var{base_cs} and @var{base_cs} is returned.")
-#define FUNC_NAME s_scm_char_set_filter_x
-{
- int k;
- long * p;
-
- SCM_VALIDATE_PROC (1, pred);
- SCM_VALIDATE_SMOB (2, cs, charset);
- SCM_VALIDATE_SMOB (3, base_cs, charset);
- p = (long *) SCM_SMOB_DATA (base_cs);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- {
- if (SCM_CHARSET_GET (cs, k))
- {
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
-
- if (scm_is_true (res))
- p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG);
- }
- }
- return base_cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
- (SCM lower, SCM upper, SCM error, SCM base_cs),
- "Return a character set containing all characters whose\n"
- "character codes lie in the half-open range\n"
- "[@var{lower},@var{upper}).\n"
- "\n"
- "If @var{error} is a true value, an error is signalled if the\n"
- "specified range contains characters which are not contained in\n"
- "the implemented character range. If @var{error} is @code{#f},\n"
- "these characters are silently left out of the resultung\n"
- "character set.\n"
- "\n"
- "The characters in @var{base_cs} are added to the result, if\n"
- "given.")
-#define FUNC_NAME s_scm_ucs_range_to_char_set
-{
- SCM cs;
- size_t clower, cupper;
- long * p;
-
- clower = scm_to_size_t (lower);
- cupper = scm_to_size_t (upper);
- SCM_ASSERT_RANGE (2, upper, cupper >= clower);
- if (!SCM_UNBNDP (error))
- {
- if (scm_is_true (error))
- {
- SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE);
- SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE);
- }
- }
- if (clower > SCM_CHARSET_SIZE)
- clower = SCM_CHARSET_SIZE;
- if (cupper > SCM_CHARSET_SIZE)
- cupper = SCM_CHARSET_SIZE;
- if (SCM_UNBNDP (base_cs))
- cs = make_char_set (FUNC_NAME);
- else
- {
- SCM_VALIDATE_SMOB (2, base_cs, charset);
- cs = scm_char_set_copy (base_cs);
- }
- p = (long *) SCM_SMOB_DATA (cs);
- while (clower < cupper)
- {
- p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG);
- clower++;
- }
- return cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0,
- (SCM lower, SCM upper, SCM error, SCM base_cs),
- "Return a character set containing all characters whose\n"
- "character codes lie in the half-open range\n"
- "[@var{lower},@var{upper}).\n"
- "\n"
- "If @var{error} is a true value, an error is signalled if the\n"
- "specified range contains characters which are not contained in\n"
- "the implemented character range. If @var{error} is @code{#f},\n"
- "these characters are silently left out of the resultung\n"
- "character set.\n"
- "\n"
- "The characters are added to @var{base_cs} and @var{base_cs} is\n"
- "returned.")
-#define FUNC_NAME s_scm_ucs_range_to_char_set_x
-{
- size_t clower, cupper;
- long * p;
-
- clower = scm_to_size_t (lower);
- cupper = scm_to_size_t (upper);
- SCM_ASSERT_RANGE (2, upper, cupper >= clower);
- if (scm_is_true (error))
- {
- SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE);
- SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE);
- }
- if (clower > SCM_CHARSET_SIZE)
- clower = SCM_CHARSET_SIZE;
- if (cupper > SCM_CHARSET_SIZE)
- cupper = SCM_CHARSET_SIZE;
- p = (long *) SCM_SMOB_DATA (base_cs);
- while (clower < cupper)
- {
- p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG);
- clower++;
- }
- return base_cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0,
- (SCM cs),
- "Return the number of elements in character set @var{cs}.")
-#define FUNC_NAME s_scm_char_set_size
-{
- int k, count = 0;
-
- SCM_VALIDATE_SMOB (1, cs, charset);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- count++;
- return SCM_I_MAKINUM (count);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0,
- (SCM pred, SCM cs),
- "Return the number of the elements int the character set\n"
- "@var{cs} which satisfy the predicate @var{pred}.")
-#define FUNC_NAME s_scm_char_set_count
-{
- int k, count = 0;
-
- SCM_VALIDATE_PROC (1, pred);
- SCM_VALIDATE_SMOB (2, cs, charset);
-
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- {
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
- if (scm_is_true (res))
- count++;
- }
- return SCM_I_MAKINUM (count);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0,
- (SCM cs),
- "Return a list containing the elements of the character set\n"
- "@var{cs}.")
-#define FUNC_NAME s_scm_char_set_to_list
-{
- int k;
- SCM result = SCM_EOL;
-
- SCM_VALIDATE_SMOB (1, cs, charset);
- for (k = SCM_CHARSET_SIZE; k > 0; k--)
- if (SCM_CHARSET_GET (cs, k - 1))
- result = scm_cons (SCM_MAKE_CHAR (k - 1), result);
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0,
- (SCM cs),
- "Return a string containing the elements of the character set\n"
- "@var{cs}. The order in which the characters are placed in the\n"
- "string is not defined.")
-#define FUNC_NAME s_scm_char_set_to_string
-{
- int k;
- int count = 0;
- int idx = 0;
- SCM result;
- char * p;
-
- SCM_VALIDATE_SMOB (1, cs, charset);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- count++;
- result = scm_i_make_string (count, &p);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- p[idx++] = k;
- return result;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_contains_p, "char-set-contains?", 2, 0, 0,
- (SCM cs, SCM ch),
- "Return @code{#t} iff the character @var{ch} is contained in the\n"
- "character set @var{cs}.")
-#define FUNC_NAME s_scm_char_set_contains_p
-{
- SCM_VALIDATE_SMOB (1, cs, charset);
- SCM_VALIDATE_CHAR (2, ch);
- return scm_from_bool (SCM_CHARSET_GET (cs, SCM_CHAR (ch)));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0,
- (SCM pred, SCM cs),
- "Return a true value if every character in the character set\n"
- "@var{cs} satisfies the predicate @var{pred}.")
-#define FUNC_NAME s_scm_char_set_every
-{
- int k;
- SCM res = SCM_BOOL_T;
-
- SCM_VALIDATE_PROC (1, pred);
- SCM_VALIDATE_SMOB (2, cs, charset);
-
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- {
- res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
- if (scm_is_false (res))
- return res;
- }
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0,
- (SCM pred, SCM cs),
- "Return a true value if any character in the character set\n"
- "@var{cs} satisfies the predicate @var{pred}.")
-#define FUNC_NAME s_scm_char_set_any
-{
- int k;
-
- SCM_VALIDATE_PROC (1, pred);
- SCM_VALIDATE_SMOB (2, cs, charset);
-
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- {
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
- if (scm_is_true (res))
- return res;
- }
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1,
- (SCM cs, SCM rest),
- "Add all character arguments to the first argument, which must\n"
- "be a character set.")
-#define FUNC_NAME s_scm_char_set_adjoin
-{
- long * p;
-
- SCM_VALIDATE_SMOB (1, cs, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
- cs = scm_char_set_copy (cs);
-
- p = (long *) SCM_SMOB_DATA (cs);
- while (!SCM_NULLP (rest))
- {
- SCM chr = SCM_CAR (rest);
- int c;
-
- SCM_VALIDATE_CHAR_COPY (1, chr, c);
- rest = SCM_CDR (rest);
-
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
- }
- return cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1,
- (SCM cs, SCM rest),
- "Delete all character arguments from the first argument, which\n"
- "must be a character set.")
-#define FUNC_NAME s_scm_char_set_delete
-{
- long * p;
-
- SCM_VALIDATE_SMOB (1, cs, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
- cs = scm_char_set_copy (cs);
-
- p = (long *) SCM_SMOB_DATA (cs);
- while (!SCM_NULLP (rest))
- {
- SCM chr = SCM_CAR (rest);
- int c;
-
- SCM_VALIDATE_CHAR_COPY (1, chr, c);
- rest = SCM_CDR (rest);
-
- p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG));
- }
- return cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1,
- (SCM cs, SCM rest),
- "Add all character arguments to the first argument, which must\n"
- "be a character set.")
-#define FUNC_NAME s_scm_char_set_adjoin_x
-{
- long * p;
-
- SCM_VALIDATE_SMOB (1, cs, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- p = (long *) SCM_SMOB_DATA (cs);
- while (!SCM_NULLP (rest))
- {
- SCM chr = SCM_CAR (rest);
- int c;
-
- SCM_VALIDATE_CHAR_COPY (1, chr, c);
- rest = SCM_CDR (rest);
-
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
- }
- return cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1,
- (SCM cs, SCM rest),
- "Delete all character arguments from the first argument, which\n"
- "must be a character set.")
-#define FUNC_NAME s_scm_char_set_delete_x
-{
- long * p;
-
- SCM_VALIDATE_SMOB (1, cs, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- p = (long *) SCM_SMOB_DATA (cs);
- while (!SCM_NULLP (rest))
- {
- SCM chr = SCM_CAR (rest);
- int c;
-
- SCM_VALIDATE_CHAR_COPY (1, chr, c);
- rest = SCM_CDR (rest);
-
- p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG));
- }
- return cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0,
- (SCM cs),
- "Return the complement of the character set @var{cs}.")
-#define FUNC_NAME s_scm_char_set_complement
-{
- int k;
- SCM res;
- long * p, * q;
-
- SCM_VALIDATE_SMOB (1, cs, charset);
-
- res = make_char_set (FUNC_NAME);
- p = (long *) SCM_SMOB_DATA (res);
- q = (long *) SCM_SMOB_DATA (cs);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] = ~q[k];
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1,
- (SCM rest),
- "Return the union of all argument character sets.")
-#define FUNC_NAME s_scm_char_set_union
-{
- int c = 1;
- SCM res;
- long * p;
-
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- res = make_char_set (FUNC_NAME);
- p = (long *) SCM_SMOB_DATA (res);
- while (!SCM_NULLP (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- rest = SCM_CDR (rest);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
- }
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1,
- (SCM rest),
- "Return the intersection of all argument character sets.")
-#define FUNC_NAME s_scm_char_set_intersection
-{
- SCM res;
-
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- if (SCM_NULLP (rest))
- res = make_char_set (FUNC_NAME);
- else
- {
- long *p;
- int argnum = 2;
-
- res = scm_char_set_copy (SCM_CAR (rest));
- p = (long *) SCM_SMOB_DATA (res);
- rest = SCM_CDR (rest);
-
- while (SCM_CONSP (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- long *cs_data;
-
- SCM_VALIDATE_SMOB (argnum, cs, charset);
- argnum++;
- cs_data = (long *) SCM_SMOB_DATA (cs);
- rest = SCM_CDR (rest);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] &= cs_data[k];
- }
- }
-
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the difference of all argument character sets.")
-#define FUNC_NAME s_scm_char_set_difference
-{
- int c = 2;
- SCM res;
- long * p;
-
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- res = scm_char_set_copy (cs1);
- p = (long *) SCM_SMOB_DATA (res);
- while (!SCM_NULLP (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- rest = SCM_CDR (rest);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
- }
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1,
- (SCM rest),
- "Return the exclusive-or of all argument character sets.")
-#define FUNC_NAME s_scm_char_set_xor
-{
- SCM res;
-
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- if (SCM_NULLP (rest))
- res = make_char_set (FUNC_NAME);
- else
- {
- int argnum = 2;
- long * p;
-
- res = scm_char_set_copy (SCM_CAR (rest));
- p = (long *) SCM_SMOB_DATA (res);
- rest = SCM_CDR (rest);
-
- while (SCM_CONSP (rest))
- {
- SCM cs = SCM_CAR (rest);
- long *cs_data;
- int k;
-
- SCM_VALIDATE_SMOB (argnum, cs, charset);
- argnum++;
- cs_data = (long *) SCM_SMOB_DATA (cs);
- rest = SCM_CDR (rest);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] ^= cs_data[k];
- }
- }
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the difference and the intersection of all argument\n"
- "character sets.")
-#define FUNC_NAME s_scm_char_set_diff_plus_intersection
-{
- int c = 2;
- SCM res1, res2;
- long * p, * q;
-
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- res1 = scm_char_set_copy (cs1);
- res2 = make_char_set (FUNC_NAME);
- p = (long *) SCM_SMOB_DATA (res1);
- q = (long *) SCM_SMOB_DATA (res2);
- while (!SCM_NULLP (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- long *r;
-
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- r = (long *) SCM_SMOB_DATA (cs);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- {
- q[k] |= p[k] & r[k];
- p[k] &= ~r[k];
- }
- rest = SCM_CDR (rest);
- }
- return scm_values (scm_list_2 (res1, res2));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0,
- (SCM cs),
- "Return the complement of the character set @var{cs}.")
-#define FUNC_NAME s_scm_char_set_complement_x
-{
- int k;
- long * p;
-
- SCM_VALIDATE_SMOB (1, cs, charset);
- p = (long *) SCM_SMOB_DATA (cs);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] = ~p[k];
- return cs;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the union of all argument character sets.")
-#define FUNC_NAME s_scm_char_set_union_x
-{
- int c = 2;
- long * p;
-
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- p = (long *) SCM_SMOB_DATA (cs1);
- while (!SCM_NULLP (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- rest = SCM_CDR (rest);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
- }
- return cs1;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the intersection of all argument character sets.")
-#define FUNC_NAME s_scm_char_set_intersection_x
-{
- int c = 2;
- long * p;
-
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- p = (long *) SCM_SMOB_DATA (cs1);
- while (!SCM_NULLP (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- rest = SCM_CDR (rest);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
- }
- return cs1;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the difference of all argument character sets.")
-#define FUNC_NAME s_scm_char_set_difference_x
-{
- int c = 2;
- long * p;
-
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- p = (long *) SCM_SMOB_DATA (cs1);
- while (!SCM_NULLP (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- rest = SCM_CDR (rest);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
- }
- return cs1;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the exclusive-or of all argument character sets.")
-#define FUNC_NAME s_scm_char_set_xor_x
-{
- /* a side-effecting variant should presumably give consistent results:
- (define a (char-set #\a))
- (char-set-xor a a a) -> char set #\a
- (char-set-xor! a a a) -> char set #\a
- */
- return scm_char_set_xor (scm_cons (cs1, rest));
-
-#if 0
- /* this would give (char-set-xor! a a a) -> empty char set. */
- int c = 2;
- long * p;
-
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- p = (long *) SCM_SMOB_DATA (cs1);
- while (!SCM_NULLP (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- rest = SCM_CDR (rest);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k];
- }
- return cs1;
-#endif
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 2, 0, 1,
- (SCM cs1, SCM cs2, SCM rest),
- "Return the difference and the intersection of all argument\n"
- "character sets.")
-#define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
-{
- int c = 3;
- long * p, * q;
- int k;
-
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_SMOB (2, cs2, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- p = (long *) SCM_SMOB_DATA (cs1);
- q = (long *) SCM_SMOB_DATA (cs2);
- if (p == q)
- {
- /* (char-set-diff+intersection! a a ...): can't share storage,
- but we know the answer without checking for further
- arguments. */
- return scm_values (scm_list_2 (make_char_set (FUNC_NAME), cs1));
- }
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- {
- long t = p[k];
-
- p[k] &= ~q[k];
- q[k] = t & q[k];
- }
- while (!SCM_NULLP (rest))
- {
- SCM cs = SCM_CAR (rest);
- long *r;
-
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- r = (long *) SCM_SMOB_DATA (cs);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- {
- q[k] |= p[k] & r[k];
- p[k] &= ~r[k];
- }
- rest = SCM_CDR (rest);
- }
- return scm_values (scm_list_2 (cs1, cs2));
-}
-#undef FUNC_NAME
-
-
-/* Create the charset smob type. */
void
-scm_c_init_srfi_14 (void)
+scm_init_srfi_14 (void)
{
- /* Charset smob creation is protected by this variable because this
- function can be both called from the SRFI-13 and SRFI-14
- initialization functions. This is because the SRFI-13 procedures
- access the charset smob type code. */
- static int initialized = 0;
-
- if (!initialized)
- {
- scm_tc16_charset = scm_make_smob_type ("character-set",
- BYTES_PER_CHARSET);
- scm_set_smob_free (scm_tc16_charset, charset_free);
- scm_set_smob_print (scm_tc16_charset, charset_print);
- initialized = 1;
- }
}
-
-/* Initialize the SRFI-14 module. This function will be called by the
- loading Scheme module. */
void
-scm_init_srfi_14 (void)
+scm_c_init_srfi_14 (void)
{
-#if 0
- fprintf(stderr, "bytes-per-charset: %d\n", BYTES_PER_CHARSET);
- fprintf(stderr, "bits-per-long: %d\n", SCM_BITS_PER_LONG);
- fprintf(stderr, "longs-per-charset: %d\n", LONGS_PER_CHARSET);
- fflush (stderr);
-#endif /* 0 */
-
- /* Do the smob type initialization. */
- scm_c_init_srfi_14 ();
-
- /* Install the charset primitives. */
-#include "srfi/srfi-14.x"
}
-
-/* End of srfi-14.c. */
diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h
index 4ce0a1fd9..544e1580b 100644
--- a/srfi/srfi-14.h
+++ b/srfi/srfi-14.h
@@ -2,7 +2,7 @@
#define SCM_SRFI_14_H
/* srfi-14.c --- SRFI-14 procedures for Guile
*
- * Copyright (C) 2001 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004 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
@@ -32,71 +32,7 @@
# define SCM_SRFI1314_API extern
#endif
-#define SCM_CHARSET_SIZE 256
-
-/* We expect 8-bit bytes here. Should be no problem in the year
- 2001. */
-#ifndef SCM_BITS_PER_LONG
-# define SCM_BITS_PER_LONG (sizeof (long) * 8)
-#endif
-
-#define SCM_CHARSET_GET(cs, idx) (((long *) SCM_SMOB_DATA (cs))\
- [((unsigned char) (idx)) / SCM_BITS_PER_LONG] &\
- (1L << (((unsigned char) (idx)) % SCM_BITS_PER_LONG)))
-
-#define SCM_CHARSETP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_charset))
-
-/* Smob type code for character sets. */
-SCM_SRFI1314_API int scm_tc16_charset;
-
SCM_SRFI1314_API void scm_c_init_srfi_14 (void);
SCM_SRFI1314_API void scm_init_srfi_14 (void);
-SCM_SRFI1314_API SCM scm_char_set_p (SCM obj);
-SCM_SRFI1314_API SCM scm_char_set_eq (SCM char_sets);
-SCM_SRFI1314_API SCM scm_char_set_leq (SCM char_sets);
-SCM_SRFI1314_API SCM scm_char_set_hash (SCM cs, SCM bound);
-SCM_SRFI1314_API SCM scm_char_set_cursor (SCM cs);
-SCM_SRFI1314_API SCM scm_char_set_ref (SCM cs, SCM cursor);
-SCM_SRFI1314_API SCM scm_char_set_cursor_next (SCM cs, SCM cursor);
-SCM_SRFI1314_API SCM scm_end_of_char_set_p (SCM cursor);
-SCM_SRFI1314_API SCM scm_char_set_fold (SCM kons, SCM knil, SCM cs);
-SCM_SRFI1314_API SCM scm_char_set_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base_cs);
-SCM_SRFI1314_API SCM scm_char_set_unfold_x (SCM p, SCM f, SCM g, SCM seed, SCM base_cs);
-SCM_SRFI1314_API SCM scm_char_set_for_each (SCM proc, SCM cs);
-SCM_SRFI1314_API SCM scm_char_set_map (SCM proc, SCM cs);
-SCM_SRFI1314_API SCM scm_char_set_copy (SCM cs);
-SCM_SRFI1314_API SCM scm_char_set (SCM rest);
-SCM_SRFI1314_API SCM scm_list_to_char_set (SCM list, SCM base_cs);
-SCM_SRFI1314_API SCM scm_list_to_char_set_x (SCM list, SCM base_cs);
-SCM_SRFI1314_API SCM scm_string_to_char_set (SCM str, SCM base_cs);
-SCM_SRFI1314_API SCM scm_string_to_char_set_x (SCM str, SCM base_cs);
-SCM_SRFI1314_API SCM scm_char_set_filter (SCM pred, SCM cs, SCM base_cs);
-SCM_SRFI1314_API SCM scm_char_set_filter_x (SCM pred, SCM cs, SCM base_cs);
-SCM_SRFI1314_API SCM scm_ucs_range_to_char_set (SCM lower, SCM upper, SCM error, SCM base_cs);
-SCM_SRFI1314_API SCM scm_ucs_range_to_char_set_x (SCM lower, SCM upper, SCM error, SCM base_cs);
-SCM_SRFI1314_API SCM scm_char_set_size (SCM cs);
-SCM_SRFI1314_API SCM scm_char_set_count (SCM pred, SCM cs);
-SCM_SRFI1314_API SCM scm_char_set_to_list (SCM cs);
-SCM_SRFI1314_API SCM scm_char_set_to_string (SCM cs);
-SCM_SRFI1314_API SCM scm_char_set_contains_p (SCM cs, SCM ch);
-SCM_SRFI1314_API SCM scm_char_set_every (SCM pred, SCM cs);
-SCM_SRFI1314_API SCM scm_char_set_any (SCM pred, SCM cs);
-SCM_SRFI1314_API SCM scm_char_set_adjoin (SCM cs, SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_delete (SCM cs, SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_adjoin_x (SCM cs, SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_delete_x (SCM cs, SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_complement (SCM cs);
-SCM_SRFI1314_API SCM scm_char_set_union (SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_intersection (SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_difference (SCM cs1, SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_xor (SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_diff_plus_intersection (SCM cs1, SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_complement_x (SCM cs);
-SCM_SRFI1314_API SCM scm_char_set_union_x (SCM cs1, SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_intersection_x (SCM cs1, SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_difference_x (SCM cs1, SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_xor_x (SCM cs1, SCM rest);
-SCM_SRFI1314_API SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM cs2, SCM rest);
-
#endif /* SCM_SRFI_14_H */
diff --git a/srfi/srfi-14.scm b/srfi/srfi-14.scm
index 9f4772df5..d8cbe628f 100644
--- a/srfi/srfi-14.scm
+++ b/srfi/srfi-14.scm
@@ -1,6 +1,6 @@
;;; srfi-14.scm --- Character-set Library
-;; Copyright (C) 2001, 2002 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2004 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
@@ -22,8 +22,9 @@
;;; Code:
-(define-module (srfi srfi-14)
- :export (
+(define-module (srfi srfi-14))
+
+(re-export
;;; General procedures
char-set?
char-set=
@@ -91,60 +92,8 @@
char-set:blank
char-set:ascii
char-set:empty
- char-set:full
- ))
+ char-set:full)
(cond-expand-provide (current-module) '(srfi-14))
-(load-extension "libguile-srfi-srfi-13-14" "scm_init_srfi_14")
-
-(define (->char-set x)
- (cond
- ((string? x) (string->char-set x))
- ((char? x) (char-set x))
- ((char-set? x) x)
- (else (error "invalid argument to `->char-set'"))))
-
-(define char-set:full (ucs-range->char-set 0 256))
-
-(define char-set:lower-case (char-set-filter char-lower-case? char-set:full))
-
-(define char-set:upper-case (char-set-filter char-upper-case? char-set:full))
-
-(define char-set:title-case (char-set))
-
-(define char-set:letter (char-set-union char-set:lower-case
- char-set:upper-case))
-
-(define char-set:digit (string->char-set "0123456789"))
-
-(define char-set:letter+digit
- (char-set-union char-set:letter char-set:digit))
-
-(define char-set:punctuation (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}"))
-
-(define char-set:symbol (string->char-set "$+<=>^`|~"))
-
-(define char-set:whitespace (char-set #\space #\newline #\tab #\cr #\vt #\np))
-
-(define char-set:blank (char-set #\space #\tab))
-
-(define char-set:graphic
- (char-set-union char-set:letter+digit char-set:punctuation char-set:symbol))
-
-(define char-set:printing
- (char-set-union char-set:graphic char-set:whitespace))
-
-(define char-set:iso-control
- (char-set-adjoin
- (char-set-filter (lambda (ch) (< (char->integer ch) 31)) char-set:full)
- (integer->char 127)))
-
-(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF"))
-
-(define char-set:ascii
- (char-set-filter (lambda (ch) (< (char->integer ch) 128)) char-set:full))
-
-(define char-set:empty (char-set))
-
;;; srfi-14.scm ends here