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