diff options
author | Marius Vollmer <mvo@zagadka.de> | 2004-08-24 22:12:08 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2004-08-24 22:12:08 +0000 |
commit | 63181a97f5d1104e43219548ff71fbf13096c598 (patch) | |
tree | 80473344f4a206b8b58c33c0d5c2d49e12a52761 | |
parent | 4b0d27f2660eadbddd64871def00edcf8502f567 (diff) | |
download | guile-63181a97f5d1104e43219548ff71fbf13096c598.tar.gz |
* srfi-13.c, srfi-13.h, srfi-14.c, srfi-14.h: New files.
* strop.h, strop.c: Removed, they are now empty.
* Makefile.am: Updated for new and removed files.
-rw-r--r-- | libguile/Makefile.am | 10 | ||||
-rw-r--r-- | libguile/srfi-13.c | 3323 | ||||
-rw-r--r-- | libguile/srfi-13.h | 119 | ||||
-rw-r--r-- | libguile/srfi-14.c | 1486 | ||||
-rw-r--r-- | libguile/srfi-14.h | 112 | ||||
-rw-r--r-- | libguile/strop.c | 0 | ||||
-rw-r--r-- | libguile/strop.h | 0 |
7 files changed, 5045 insertions, 5 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 66631d716..31f82dd78 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with Automake to create Makefile.in ## -## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -102,7 +102,7 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ load.c macros.c mallocs.c modules.c numbers.c objects.c objprop.c \ options.c pairs.c ports.c print.c procprop.c procs.c properties.c \ random.c rdelim.c read.c root.c rw.c scmsigs.c script.c simpos.c smob.c \ - sort.c srcprop.c stackchk.c stacks.c stime.c strings.c strop.c \ + sort.c srcprop.c stackchk.c stacks.c stime.c strings.c srfi-13.c srfi-14.c \ strorder.c strports.c struct.c symbols.c threads.c throw.c values.c \ variable.c vectors.c version.c vports.c weaks.c @@ -118,7 +118,7 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ numbers.x objects.x objprop.x options.x pairs.x ports.x print.x \ procprop.x procs.x properties.x random.x rdelim.x read.x root.x rw.x \ scmsigs.x script.x simpos.x smob.x sort.x srcprop.x \ - stackchk.x stacks.x stime.x strings.x strop.x strorder.x strports.x \ + stackchk.x stacks.x stime.x strings.x srfi-13.x srfi-14.x strorder.x strports.x \ struct.x symbols.x threads.x throw.x values.x variable.x vectors.x \ version.x vports.x weaks.x @@ -138,7 +138,7 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ options.doc pairs.doc ports.doc print.doc procprop.doc \ procs.doc properties.doc random.doc rdelim.doc read.doc root.doc rw.doc \ scmsigs.doc script.doc simpos.doc smob.doc sort.doc \ - srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc strop.doc \ + srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc srfi-13.doc srfi-14.doc \ strorder.doc strports.doc struct.doc symbols.doc threads.doc throw.doc \ values.doc variable.doc vectors.doc version.doc vports.doc weaks.doc @@ -194,7 +194,7 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ regex-posix.h print.h procprop.h procs.h properties.h random.h ramap.h \ rdelim.h read.h root.h rw.h scmsigs.h validate.h script.h simpos.h smob.h \ snarf.h socket.h sort.h srcprop.h stackchk.h stacks.h stime.h strings.h \ - strop.h strorder.h strports.h struct.h symbols.h tags.h threads.h \ + srfi-13.h srfi-14.h strorder.h strports.h struct.h symbols.h tags.h threads.h \ throw.h unif.h values.h variable.h vectors.h vports.h weaks.h nodist_modinclude_HEADERS = version.h scmconfig.h diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c new file mode 100644 index 000000000..8f1a89ff5 --- /dev/null +++ b/libguile/srfi-13.c @@ -0,0 +1,3323 @@ +/* srfi-13.c --- SRFI-13 procedures for Guile + * + * 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 + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + +#include <string.h> +#include <ctype.h> + +#include "libguile.h" + +#include "libguile/srfi-13.h" +#include "libguile/srfi-14.h" + +/* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages + messing with the internal representation of strings. We define our + own version since we use it so much and are messing with Guile + internals anyway. +*/ + +#define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \ + pos_start, start, c_start, \ + pos_end, end, c_end) \ + do { \ + SCM_VALIDATE_STRING (pos_str, str); \ + c_str = scm_i_string_chars (str); \ + scm_i_get_substring_spec (scm_i_string_length (str), \ + start, &c_start, end, &c_end); \ + } while (0) + +#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_null_p, "string-null?", 1, 0, 0, + (SCM str), + "Return @code{#t} if @var{str}'s length is zero, and\n" + "@code{#f} otherwise.\n" + "@lisp\n" + "(string-null? \"\") @result{} #t\n" + "y @result{} \"foo\"\n" + "(string-null? y) @result{} #f\n" + "@end lisp") +#define FUNC_NAME s_scm_string_null_p +{ + SCM_VALIDATE_STRING (1, str); + return scm_from_bool (scm_i_string_length (str) == 0); +} +#undef FUNC_NAME + +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_substring_to_list, "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_substring_to_list +{ + 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 + +/* We export scm_substring_to_list as "string->list" since it is + compatible and more general. This function remains for the benefit + of C code that used it. +*/ + +SCM +scm_string_to_list (SCM str) +{ + return scm_substring_to_list (str, SCM_UNDEFINED, SCM_UNDEFINED); +} + +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 + + +/* There are a number of functions to consider here for Scheme and C: + + string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy + substring/copy STR start [end] ;; Guile variant of R5RS substring + + scm_string_copy (str) ;; Old function from Guile + scm_substring_copy (str, [start, [end]]) + ;; C version of SRFI-13 string-copy + ;; and C version of substring/copy + + The C function underlying string-copy is not exported to C + programs. scm_substring_copy is defined in strings.c as the + underlying function of substring/copy and allows an optional START + argument. +*/ + +SCM scm_srfi13_substring_copy (SCM str, SCM start, SCM end); + +SCM_DEFINE (scm_srfi13_substring_copy, "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_srfi13_substring_copy +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return scm_c_substring_copy (str, cstart, cend); +} +#undef FUNC_NAME + +SCM +scm_string_copy (SCM str) +{ + return scm_c_substring (str, 0, scm_c_string_length (str)); +} + +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_substring_move_x, "substring-move!", 5, 0, 0, + (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2), + "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n" + "into @var{str2} beginning at position @var{start2}.\n" + "@var{str1} and @var{str2} can be the same string.") +#define FUNC_NAME s_scm_substring_move_x +{ + return scm_string_copy_x (str2, start2, str1, start1, end1); +} +#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_substring_fill_x, "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_substring_fill_x +{ + char *cstr; + size_t cstart, cend; + int c; + size_t k; + + /* Older versions of Guile provided the function + scm_substring_fill_x with the following order of arguments: + + str, start, end, chr + + We accomodate this here by detecting such a usage and reordering + the arguments. + */ + if (SCM_CHARP (end)) + { + SCM tmp = end; + end = start; + start = chr; + chr = tmp; + } + + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 3, start, cstart, + 4, end, cend); + SCM_VALIDATE_CHAR_COPY (2, chr, c); + + 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 +scm_string_fill_x (SCM str, SCM chr) +{ + return scm_substring_fill_x (str, chr, SCM_UNDEFINED, SCM_UNDEFINED); +} + +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); + + if ((cend1 - cstart1) != (cend2 - cstart2)) + goto false; + + while (cstart1 < cend1) + { + if (cstr1[cstart1] < cstr2[cstart2]) + goto false; + else if (cstr1[cstart1] > cstr2[cstart2]) + goto false; + cstart1++; + cstart2++; + } + + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#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]) + goto true; + else if (cstr1[cstart1] > cstr2[cstart2]) + goto true; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto true; + else if (cstart2 < cend2) + goto true; + else + goto false; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#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]) + goto true; + else if (cstr1[cstart1] > cstr2[cstart2]) + goto false; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto false; + else if (cstart2 < cend2) + goto true; + else + goto false; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#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]) + goto false; + else if (cstr1[cstart1] > cstr2[cstart2]) + goto true; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto true; + else if (cstart2 < cend2) + goto false; + else + goto false; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#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]) + goto true; + else if (cstr1[cstart1] > cstr2[cstart2]) + goto false; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto false; + else if (cstart2 < cend2) + goto true; + else + goto true; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#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]) + goto false; + else if (cstr1[cstart1] > cstr2[cstart2]) + goto true; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto true; + else if (cstart2 < cend2) + goto false; + else + goto true; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#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])) + goto false; + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + goto false; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto false; + else if (cstart2 < cend2) + goto false; + else + goto true; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#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])) + goto true; + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + goto true; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto true; + else if (cstart2 < cend2) + goto true; + else + goto false; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#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])) + goto true; + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + goto false; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto false; + else if (cstart2 < cend2) + goto true; + else + goto false; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#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])) + goto false; + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + goto true; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto true; + else if (cstart2 < cend2) + goto false; + else + goto false; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#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])) + goto true; + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + goto false; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto false; + else if (cstart2 < cend2) + goto true; + else + goto true; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#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])) + goto false; + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + goto true; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto true; + else if (cstart2 < cend2) + goto false; + else + goto true; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_substring_hash, "string-hash", 1, 3, 0, + (SCM s, SCM bound, SCM start, SCM end), + "Compute a hash value for @var{S}. the optional argument " + "@var{bound} is a non-negative exact " + "integer specifying the range of the hash function. " + "A positive value restricts the return value to the " + "range [0,bound).") +#define FUNC_NAME s_scm_substring_hash +{ + if (SCM_UNBNDP (bound)) + bound = scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM); + if (SCM_UNBNDP (start)) + start = SCM_INUM0; + return scm_hash (scm_substring_shared (s, start, end), bound); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_substring_hash_ci, "string-hash-ci", 1, 3, 0, + (SCM s, SCM bound, SCM start, SCM end), + "Compute a hash value for @var{S}. the optional argument " + "@var{bound} is a non-negative exact " + "integer specifying the range of the hash function. " + "A positive value restricts the return value to the " + "range [0,bound).") +#define FUNC_NAME s_scm_substring_hash_ci +{ + return scm_substring_hash (scm_substring_downcase (s, start, end), + bound, + SCM_UNDEFINED, SCM_UNDEFINED); +} +#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 + + +SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Search through the string @var{s} from left to right, returning\n" + "the index of the first occurence of a character which\n" + "\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_index +{ + 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 +scm_string_rindex (SCM str, SCM chr, SCM frm, SCM to) +{ + return scm_string_index_right (str, chr, frm, to); +} + +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; +} + +SCM_DEFINE (scm_substring_upcase_x, "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_substring_upcase_x +{ + 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 + +SCM +scm_string_upcase_x (SCM str) +{ + return scm_substring_upcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED); +} + +SCM_DEFINE (scm_substring_upcase, "string-upcase", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Upcase every character in @code{str}.") +#define FUNC_NAME s_scm_substring_upcase +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_upcase_x (scm_string_copy (str), cstart, cend); +} +#undef FUNC_NAME + +SCM +scm_string_upcase (SCM str) +{ + return scm_substring_upcase (str, SCM_UNDEFINED, SCM_UNDEFINED); +} + +/* 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; +} + +SCM_DEFINE (scm_substring_downcase_x, "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_substring_downcase_x +{ + 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 + +SCM +scm_string_downcase_x (SCM str) +{ + return scm_substring_downcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED); +} + +SCM_DEFINE (scm_substring_downcase, "string-downcase", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Downcase every character in @var{str}.") +#define FUNC_NAME s_scm_substring_downcase +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_downcase_x (scm_string_copy (str), cstart, cend); +} +#undef FUNC_NAME + +SCM +scm_string_downcase (SCM str) +{ + return scm_substring_downcase (str, SCM_UNDEFINED, SCM_UNDEFINED); +} + +/* 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 + +/* Old names, the functions. + */ + +SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, + (SCM str), + "Upcase the first character of every word in @var{str}\n" + "destructively and return @var{str}.\n" + "\n" + "@lisp\n" + "y @result{} \"hello world\"\n" + "(string-capitalize! y) @result{} \"Hello World\"\n" + "y @result{} \"Hello World\"\n" + "@end lisp") +#define FUNC_NAME s_scm_string_capitalize_x +{ + return scm_string_titlecase_x (str, SCM_UNDEFINED, SCM_UNDEFINED); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0, + (SCM str), + "Return a freshly allocated string with the characters in\n" + "@var{str}, where the first character of every word is\n" + "capitalized.") +#define FUNC_NAME s_scm_string_capitalize +{ + return scm_string_capitalize_x (scm_string_copy (str)); +} +#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 +{ + return scm_string_append (ls); +} +#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 +{ + return scm_string_append_shared (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_index +{ + 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}.\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; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + + if (SCM_UNBNDP (token_set)) + token_set = scm_char_set_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_split, "string-split", 2, 0, 0, + (SCM str, SCM chr), + "Split the string @var{str} into the a list of the substrings delimited\n" + "by appearances of the character @var{chr}. Note that an empty substring\n" + "between separator characters will result in an empty string in the\n" + "result list.\n" + "\n" + "@lisp\n" + "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n" + "@result{}\n" + "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n" + "\n" + "(string-split \"::\" #\\:)\n" + "@result{}\n" + "(\"\" \"\" \"\")\n" + "\n" + "(string-split \"\" #\\:)\n" + "@result{}\n" + "(\"\")\n" + "@end lisp") +#define FUNC_NAME s_scm_string_split +{ + long idx, last_idx; + const char * p; + int ch; + SCM res = SCM_EOL; + + SCM_VALIDATE_STRING (1, str); + SCM_VALIDATE_CHAR (2, chr); + + idx = scm_i_string_length (str); + p = scm_i_string_chars (str); + ch = SCM_CHAR (chr); + while (idx >= 0) + { + last_idx = idx; + while (idx > 0 && p[idx - 1] != ch) + idx--; + if (idx >= 0) + { + res = scm_cons (scm_c_substring (str, idx, last_idx), res); + p = scm_i_string_chars (str); + idx--; + } + } + scm_remember_upto_here_1 (str); + return res; +} +#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 +{ + 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) +{ +#include "libguile/srfi-13.x" +} + +/* End of srfi-13.c. */ diff --git a/libguile/srfi-13.h b/libguile/srfi-13.h new file mode 100644 index 000000000..3eec270aa --- /dev/null +++ b/libguile/srfi-13.h @@ -0,0 +1,119 @@ +#ifndef SCM_SRFI_13_H +#define SCM_SRFI_13_H + +/* srfi-13.c --- SRFI-13 procedures for Guile + * + * 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 + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + +#include "libguile/__scm.h" + +SCM_API SCM scm_string_null_p (SCM s); +SCM_API SCM scm_string_any (SCM pred, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_every (SCM pred, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_tabulate (SCM proc, SCM len); +SCM_API SCM scm_string_to_list (SCM str); +SCM_API SCM scm_substring_to_list (SCM str, SCM start, SCM end); +SCM_API SCM scm_reverse_list_to_string (SCM chrs); +SCM_API SCM scm_string_join (SCM ls, SCM delimiter, SCM grammar); +SCM_API SCM scm_string_copy (SCM str); +SCM_API SCM scm_string_copy_x (SCM target, SCM tstart, SCM s, SCM start, SCM end); +SCM_API SCM scm_substring_move_x (SCM str1, SCM start1, SCM end1, + SCM str2, SCM start2); +SCM_API SCM scm_string_take (SCM s, SCM n); +SCM_API SCM scm_string_drop (SCM s, SCM n); +SCM_API SCM scm_string_take_right (SCM s, SCM n); +SCM_API SCM scm_string_drop_right (SCM s, SCM n); +SCM_API SCM scm_string_pad (SCM s, SCM len, SCM chr, SCM start, SCM end); +SCM_API SCM scm_string_pad_right (SCM s, SCM len, SCM chr, SCM start, SCM end); +SCM_API SCM scm_string_trim (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_trim_right (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_trim_both (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_substring_fill_x (SCM str, SCM chr, SCM start, SCM end); +SCM_API SCM scm_string_fill_x (SCM str, SCM chr); +SCM_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_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_API SCM scm_string_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ci_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ci_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ci_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ci_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ci_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ci_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_substring_hash (SCM s, SCM bound, SCM start, SCM end); +SCM_API SCM scm_substring_hash_ci (SCM s, SCM bound, SCM start, SCM end); +SCM_API SCM scm_string_prefix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_prefix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_suffix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_suffix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_prefix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_prefix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_suffix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_suffix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_index (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_index_right (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_rindex (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_skip (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_skip_right (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_count (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_contains (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_contains_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_substring_upcase_x (SCM str, SCM start, SCM end); +SCM_API SCM scm_substring_upcase (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_upcase_x (SCM str); +SCM_API SCM scm_string_upcase (SCM str); +SCM_API SCM scm_substring_downcase_x (SCM str, SCM start, SCM end); +SCM_API SCM scm_substring_downcase (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_downcase_x (SCM str); +SCM_API SCM scm_string_downcase (SCM str); +SCM_API SCM scm_string_titlecase_x (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_titlecase (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_capitalize_x (SCM str); +SCM_API SCM scm_string_capitalize (SCM str); +SCM_API SCM scm_string_reverse (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_reverse_x (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_append_shared (SCM ls); +SCM_API SCM scm_string_concatenate (SCM ls); +SCM_API SCM scm_string_concatenate_shared (SCM ls); +SCM_API SCM scm_string_concatenate_reverse (SCM ls, SCM final_string, SCM end); +SCM_API SCM scm_string_concatenate_reverse_shared (SCM ls, SCM final_string, SCM end); +SCM_API SCM scm_string_map (SCM proc, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_map_x (SCM proc, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_fold (SCM kons, SCM knil, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_fold_right (SCM kons, SCM knil, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final); +SCM_API SCM scm_string_unfold_right (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final); +SCM_API SCM scm_string_for_each (SCM proc, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_for_each_index (SCM proc, SCM s, SCM start, SCM end); +SCM_API SCM scm_xsubstring (SCM s, SCM from, SCM to, SCM start, SCM end); +SCM_API SCM scm_string_xcopy_x (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end); +SCM_API SCM scm_string_replace (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_tokenize (SCM s, SCM token_char, SCM start, SCM end); +SCM_API SCM scm_string_split (SCM s, SCM chr); +SCM_API SCM scm_string_filter (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_delete (SCM s, SCM char_pred, SCM start, SCM end); + +SCM_API void scm_init_srfi_13 (void); +SCM_API void scm_init_srfi_13_14 (void); + +#endif /* SCM_SRFI_13_H */ diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c new file mode 100644 index 000000000..c2a6a9a0c --- /dev/null +++ b/libguile/srfi-14.c @@ -0,0 +1,1486 @@ +/* srfi-14.c --- SRFI-14 procedures for Guile + * + * 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 + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + +#include <string.h> +#include <ctype.h> + +#include "libguile.h" +#include "libguile/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 (4, 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_to_char_set, "->char-set", 1, 0, 0, + (SCM x), + "Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is.") +#define FUNC_NAME s_scm_to_char_set +{ + if (scm_is_string (x)) + return scm_string_to_char_set (x, SCM_UNDEFINED); + else if (SCM_CHARP (x)) + return scm_char_set (scm_list_1 (x)); + else if (SCM_SMOB_PREDICATE (scm_tc16_charset, x)) + return x; + else + scm_wrong_type_arg (NULL, 0, x); +} +#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 + +SCM scm_char_set_lower_case; +SCM scm_char_set_upper_case; +SCM scm_char_set_title_case; +SCM scm_char_set_letter; +SCM scm_char_set_digit; +SCM scm_char_set_letter_and_digit; +SCM scm_char_set_graphic; +SCM scm_char_set_printing; +SCM scm_char_set_whitespace; +SCM scm_char_set_iso_control; +SCM scm_char_set_punctuation; +SCM scm_char_set_symbol; +SCM scm_char_set_hex_digit; +SCM scm_char_set_blank; +SCM scm_char_set_ascii; +SCM scm_char_set_empty; +SCM scm_char_set_full; + +static SCM +make_predset (int (*pred) (int)) +{ + int ch; + SCM cs = make_char_set (NULL); + for (ch = 0; ch < 256; ch++) + if (pred (ch)) + SCM_CHARSET_SET (cs, ch); + return cs; +} + +static SCM +define_predset (const char *name, int (*pred) (int)) +{ + SCM cs = make_predset (pred); + scm_c_define (name, cs); + return scm_permanent_object (cs); +} + +static SCM +make_strset (const char *str) +{ + SCM cs = make_char_set (NULL); + while (*str) + { + SCM_CHARSET_SET (cs, *str); + str++; + } + return cs; +} + +static SCM +define_strset (const char *name, const char *str) +{ + SCM cs = make_strset (str); + scm_c_define (name, cs); + return scm_permanent_object (cs); +} + +static int false (int ch) { return 0; } +static int true (int ch) { return 1; } + +void +scm_init_srfi_14 (void) +{ + 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); + + scm_char_set_upper_case = define_predset ("char-set:upper-case", isupper); + scm_char_set_lower_case = define_predset ("char-set:lower-case", islower); + scm_char_set_title_case = define_predset ("char-set:title-case", false); + scm_char_set_letter = define_predset ("char-set:letter", isalpha); + scm_char_set_digit = define_predset ("char-set:digit", isdigit); + scm_char_set_letter_and_digit = define_predset ("char-set:letter+digit", + isalnum); + scm_char_set_graphic = define_predset ("char-set:graphic", isgraph); + scm_char_set_printing = define_predset ("char-set:printing", isprint); + scm_char_set_whitespace = define_predset ("char-set:whitespace", isspace); + scm_char_set_iso_control = define_predset ("char-set:iso-control", iscntrl); + scm_char_set_punctuation = define_predset ("char-set:punctuation", ispunct); + scm_char_set_symbol = define_strset ("char-set:symbol", "$+<=>^`|~"); + scm_char_set_hex_digit = define_predset ("char-set:hex-digit", isxdigit); + scm_char_set_blank = define_strset ("char-set:blank", " \t"); + scm_char_set_ascii = define_predset ("char-set:ascii", isascii); + scm_char_set_empty = define_predset ("char-set:empty", false); + scm_char_set_full = define_predset ("char-set:full", true); + +#include "libguile/srfi-14.x" +} + +/* End of srfi-14.c. */ diff --git a/libguile/srfi-14.h b/libguile/srfi-14.h new file mode 100644 index 000000000..c6d0f497a --- /dev/null +++ b/libguile/srfi-14.h @@ -0,0 +1,112 @@ +#ifndef SCM_SRFI_14_H +#define SCM_SRFI_14_H + +/* srfi-14.c --- SRFI-14 procedures for Guile + * + * 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 + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + +#include "libguile/__scm.h" + +#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_API int scm_tc16_charset; + +SCM_API SCM scm_char_set_p (SCM obj); +SCM_API SCM scm_char_set_eq (SCM char_sets); +SCM_API SCM scm_char_set_leq (SCM char_sets); +SCM_API SCM scm_char_set_hash (SCM cs, SCM bound); +SCM_API SCM scm_char_set_cursor (SCM cs); +SCM_API SCM scm_char_set_ref (SCM cs, SCM cursor); +SCM_API SCM scm_char_set_cursor_next (SCM cs, SCM cursor); +SCM_API SCM scm_end_of_char_set_p (SCM cursor); +SCM_API SCM scm_char_set_fold (SCM kons, SCM knil, SCM cs); +SCM_API SCM scm_char_set_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base_cs); +SCM_API SCM scm_char_set_unfold_x (SCM p, SCM f, SCM g, SCM seed, SCM base_cs); +SCM_API SCM scm_char_set_for_each (SCM proc, SCM cs); +SCM_API SCM scm_char_set_map (SCM proc, SCM cs); +SCM_API SCM scm_char_set_copy (SCM cs); +SCM_API SCM scm_char_set (SCM rest); +SCM_API SCM scm_list_to_char_set (SCM list, SCM base_cs); +SCM_API SCM scm_list_to_char_set_x (SCM list, SCM base_cs); +SCM_API SCM scm_string_to_char_set (SCM str, SCM base_cs); +SCM_API SCM scm_string_to_char_set_x (SCM str, SCM base_cs); +SCM_API SCM scm_char_set_filter (SCM pred, SCM cs, SCM base_cs); +SCM_API SCM scm_char_set_filter_x (SCM pred, SCM cs, SCM base_cs); +SCM_API SCM scm_ucs_range_to_char_set (SCM lower, SCM upper, SCM error, SCM base_cs); +SCM_API SCM scm_ucs_range_to_char_set_x (SCM lower, SCM upper, SCM error, SCM base_cs); +SCM_API SCM scm_to_char_set (SCM x); +SCM_API SCM scm_char_set_size (SCM cs); +SCM_API SCM scm_char_set_count (SCM pred, SCM cs); +SCM_API SCM scm_char_set_to_list (SCM cs); +SCM_API SCM scm_char_set_to_string (SCM cs); +SCM_API SCM scm_char_set_contains_p (SCM cs, SCM ch); +SCM_API SCM scm_char_set_every (SCM pred, SCM cs); +SCM_API SCM scm_char_set_any (SCM pred, SCM cs); +SCM_API SCM scm_char_set_adjoin (SCM cs, SCM rest); +SCM_API SCM scm_char_set_delete (SCM cs, SCM rest); +SCM_API SCM scm_char_set_adjoin_x (SCM cs, SCM rest); +SCM_API SCM scm_char_set_delete_x (SCM cs, SCM rest); +SCM_API SCM scm_char_set_complement (SCM cs); +SCM_API SCM scm_char_set_union (SCM rest); +SCM_API SCM scm_char_set_intersection (SCM rest); +SCM_API SCM scm_char_set_difference (SCM cs1, SCM rest); +SCM_API SCM scm_char_set_xor (SCM rest); +SCM_API SCM scm_char_set_diff_plus_intersection (SCM cs1, SCM rest); +SCM_API SCM scm_char_set_complement_x (SCM cs); +SCM_API SCM scm_char_set_union_x (SCM cs1, SCM rest); +SCM_API SCM scm_char_set_intersection_x (SCM cs1, SCM rest); +SCM_API SCM scm_char_set_difference_x (SCM cs1, SCM rest); +SCM_API SCM scm_char_set_xor_x (SCM cs1, SCM rest); +SCM_API SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM cs2, SCM rest); + +SCM_API SCM scm_char_set_lower_case; +SCM_API SCM scm_char_set_upper_case; +SCM_API SCM scm_char_set_title_case; +SCM_API SCM scm_char_set_letter; +SCM_API SCM scm_char_set_digit; +SCM_API SCM scm_char_set_letter_and_digit; +SCM_API SCM scm_char_set_graphic; +SCM_API SCM scm_char_set_printing; +SCM_API SCM scm_char_set_whitespace; +SCM_API SCM scm_char_set_iso_control; +SCM_API SCM scm_char_set_punctuation; +SCM_API SCM scm_char_set_symbol; +SCM_API SCM scm_char_set_hex_digit; +SCM_API SCM scm_char_set_blank; +SCM_API SCM scm_char_set_ascii; +SCM_API SCM scm_char_set_empty; +SCM_API SCM scm_char_set_full; + +SCM_API void scm_c_init_srfi_14 (void); +SCM_API void scm_init_srfi_14 (void); + +#endif /* SCM_SRFI_14_H */ diff --git a/libguile/strop.c b/libguile/strop.c deleted file mode 100644 index e69de29bb..000000000 --- a/libguile/strop.c +++ /dev/null diff --git a/libguile/strop.h b/libguile/strop.h deleted file mode 100644 index e69de29bb..000000000 --- a/libguile/strop.h +++ /dev/null |