summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMartin Grabmüller <mgrabmue@cs.tu-berlin.de>2001-04-23 20:21:01 +0000
committerMartin Grabmüller <mgrabmue@cs.tu-berlin.de>2001-04-23 20:21:01 +0000
commitca003b26ce5576999aefeebc4fd0e3c71fdf9668 (patch)
treeeef5b81e094bea1c531cf44cf364a0c0d9ac2f6b
parent1f7f9ed41d855099432fa6338d8e6a535dac41b3 (diff)
downloadguile-ca003b26ce5576999aefeebc4fd0e3c71fdf9668.tar.gz
Integrated the guile-srfi package into the Guile distribution.
-rw-r--r--srfi/.cvsignore12
-rw-r--r--srfi/ChangeLog87
-rw-r--r--srfi/Makefile.am52
-rw-r--r--srfi/README141
-rwxr-xr-xsrfi/autogen.sh0
-rw-r--r--srfi/configure.in0
-rw-r--r--srfi/guile-srfi.texi0
-rw-r--r--srfi/srfi-13.c3052
-rw-r--r--srfi/srfi-13.scm141
-rw-r--r--srfi/srfi-14.c1361
-rw-r--r--srfi/srfi-14.h61
-rw-r--r--srfi/srfi-14.scm142
12 files changed, 5049 insertions, 0 deletions
diff --git a/srfi/.cvsignore b/srfi/.cvsignore
new file mode 100644
index 000000000..6c4e65b0c
--- /dev/null
+++ b/srfi/.cvsignore
@@ -0,0 +1,12 @@
+*.la
+*.lo
+*.x
+.deps
+.libs
+Makefile
+Makefile.in
+aclocal.m4
+config.log
+config.status
+configure
+libtool
diff --git a/srfi/ChangeLog b/srfi/ChangeLog
new file mode 100644
index 000000000..ea6016cf0
--- /dev/null
+++ b/srfi/ChangeLog
@@ -0,0 +1,87 @@
+2001-04-23 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ Integrated the guile-srfi package into the Guile distribution.
+
+ * srfi-13.c: All procedures so specified in the SRFI now accept
+ character set arguments.
+
+ * Makefile.am: Snarfed some variables from the guile-readline
+ directory.
+
+ * srfi-14.c, srfi-14.h: Add prefix SCM_ to exported macros.
+
+ * srfi-13.scm, srfi-14.scm, srfi-13.c, srfi-14.c, srfi-14.h,
+ configure.in, Makefile.am: Added FSF copyright and Guile license
+ information.
+
+ * srfi-13.c, srfi-14.c: Include srfi-14.h.
+ (scm_init_srfi_13_14): Initialize the complete module, if not
+ already done so.
+
+ * srfi-14.h: New file.
+
+ * srfi-13.scm, srfi-14.scm: Load new combined library.
+
+ * Makefile.am: Build only one library,
+ `libguile-srfi-srfi-13-14.la'
+
+2001-04-04 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * guile-srfi.texi: Integrated the SRFI-14 documentation.
+
+ * srfi-14.c, srfi-14.scm: Made the procedures and variables
+ compliant to the final SRFI document.
+
+ * Renamed the package to guile-srfi.
+
+2001-04-03 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * NEWS: New section for 0.0.3.
+
+ * configure.in, README, guile-srfi-13.texi: Bumped version number
+ to 0.0.3.
+
+ * Released version 0.0.2.
+
+ * Makefile.am: Added rules for builing the SRFI-14 library.
+
+ * srfi-14.c, srfi-14.scm: New files, implementing SRFI-14
+ (character set library).
+
+2001-03-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * README: Updated procedure and incompatibility list.
+
+ * srfi-13.c (string_upcase_x, scm_string_upcase_xS),
+ (scm_string_upcase, string_downcase_x, scm_string_downcase_xS),
+ (scm_string_downcaseS, string_titlecase_x),
+ (scm_string_titlecase_x, scm_string_titlecase),
+ (scm_string_fill_xS, scm_string_copyS, scm_string_to_listS): New
+ procedures.
+
+ * srfi-13.scm: Export new case mapping procedures.
+
+ * guile-srfi-13.texi (What cannot be done): Removed case mapping
+ procedures from incompatibility list.
+ (Case Mapping): New section for case mapping procedures.
+
+2001-03-26 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * NEWS: New section for 0.0.2
+
+ * configure.in, README, guile-srfi-13.texi: Bumbed version number
+ to 0.0.2
+
+ * Released version 0.0.1.
+
+ * README: Made procedure list up-to-date.
+
+ * guile-srfi-13.texi: Fixed typos, completed reference and added
+ introductory blurb.
+
+ * srfi-13.c, srfi-13.scm: Filled in the last missing pieces.
+
+2001-03-22 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Started guile-srfi-13 package. Files are copied from the
+ guile-gdbm and slightly modified.
diff --git a/srfi/Makefile.am b/srfi/Makefile.am
new file mode 100644
index 000000000..c9cd7144f
--- /dev/null
+++ b/srfi/Makefile.am
@@ -0,0 +1,52 @@
+## Process this file with Automake to create Makefile.in
+##
+## Copyright (C) 2001 Free Software Foundation, Inc.
+##
+## This file is part of GUILE.
+##
+## GUILE is free software; you can redistribute it and/or modify
+## it under the terms of the GNU General Public License as
+## published by the Free Software Foundation; either version 2, or
+## (at your option) any later version.
+##
+## GUILE is distributed in the hope that it will be useful, but
+## WITHOUT ANY WARRANTY; without even the implied warranty of
+## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+## GNU General Public License for more details.
+##
+## You should have received a copy of the GNU General Public
+## License along with GUILE; see the file COPYING. If not, write
+## to the Free Software Foundation, Inc., 59 Temple Place, Suite
+## 330, Boston, MA 02111-1307 USA
+
+AUTOMAKE_OPTIONS = foreign
+
+#info_TEXINFOS = guile-srfi.texi
+
+## Prevent automake from adding extra -I options
+DEFS = @DEFS@
+## Check for headers in $(srcdir)/.., so that #include
+## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
+## building.
+INCLUDES = -I.. -I$(srcdir)/..
+
+
+lib_LTLIBRARIES = libguile-srfi-srfi-13-14.la
+
+BUILT_SOURCES = srfi-13.x srfi-14.x
+libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srf-14.x srfi-14.c
+libguile_srfi_srfi_13_14_la_LDFLAGS = -version-info 0:0 -export-dynamic
+
+srfidir = $(datadir)/guile/$(VERSION)/srfi
+srfi_DATA = srfi-13.scm srfi-14.scm
+
+EXTRA_DIST = $(srfi_DATA)
+
+GUILE_SNARF = ../libguile/guile-snarf
+
+SUFFIXES = .x
+.c.x:
+ $(GUILE_SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \
+ || { rm $@; false; }
+
+DISTCLEANFILES = *.x
diff --git a/srfi/README b/srfi/README
new file mode 100644
index 000000000..6dca759b2
--- /dev/null
+++ b/srfi/README
@@ -0,0 +1,141 @@
+This is the integration of guile-srfi into the core. -*- text -*-
+
+[ this is the README from guile-srfi 0.0.3, slightly modified for the
+ integration into the Guile core
+
+ 'martin -- 2001-04-23 ]
+
+This is a compiled Guile module that provides the string procedures
+defined in SRFI-13 (string library), and the character set procedures
+defined in SRFI-14 (character-set library).
+
+Getting Started ======================================================
+
+1. Type
+
+ guile
+
+ You should now be at the Guile prompt ("guile> ").
+
+2. Type
+
+ (use-modules (srfi srfi-13))
+
+ so that the srfi-13 module gets loaded.
+
+3. We're now ready to try some basic srfi-13/14 functionality.
+
+ $ guile
+ guile> (use-modules (srfi srfi-13))
+ guile> (string-concatenate '("Hello" " " "World"))
+ "Hello World"
+ guile>
+
+ Check out the SRFI-14 (character-set library) procedures, too:
+
+ $ guile
+ guile> (use-modules (srfi srfi-14))
+ guile> (char-set-union (char-set #\f #\o #\o) (string->char-set "bar"))
+ #<charset {#\a #\b #\f #\o #\r}>
+ guile>
+
+What Is Included =====================================================
+
+ All SRFI-13 procedures which are not already compatibly defined in
+ the Guile core are implemented. These are:
+
+ string-any string-every
+ string-tabulate
+ string->list
+ reverse-list->string
+ string-join
+ string-copy
+ substring/shared string-copy!
+ string-take string-take-right
+ string-drop string-drop-right
+ string-pad string-pad-right
+ string-trim string-trim-right string-trim-both
+ string-fill!
+ string-compare string-compare-ci
+ string= string<>
+ string< string>
+ string<= string>=
+ string-ci= string-ci<>
+ string-ci< string-ci>
+ string-ci<= string-ci>=
+ string-hash string-hash-ci
+ string-prefix-length string-prefix-length-ci
+ string-suffix-length string-suffix-length-ci
+ string-prefix? string-prefix-ci?
+ string-suffix? string-suffix-ci?
+ string-index string-index-right
+ string-skip string-skip-right
+ string-count
+ string-contains string-contains-ci
+ string-upcase string-upcase!
+ string-downcase string-downcase!
+ string-titlecase string-titlecase!
+ string-reverse string-reverse!
+ string-append/shared
+ string-concatenate
+ reverse-string-concatenate
+ string-concatenate/shared
+ reverse-string-concatenate/shared
+ string-map string-map!
+ string-fold string-fold-right
+ string-unfold string-unfold-right
+ string-for-each
+ xsubstring string-xcopy!
+ string-replace string-tokenize
+ string-filter string-delete
+
+
+ All procedures and variables defined in SRFI-14 are implemented.
+ Thes complete list is:
+
+ char-set? char-set= char-set<=
+ char-set-hash
+ char-set-fold char-set-unfold char-set-unfold!
+ char-set-for-each char-set-map
+ char-set-copy
+ char-set
+ list->char-set list->char-set!
+ string->char-set string-char-set!
+ predicate->char-set predicate->char-set!
+ ucs-range->char-set ucs-range->char-set!
+ ->char-set ->char-set!
+ char-set-size char-set-count
+ char-set-members char-set-contains?
+ char-set-every char-set-any
+ char-set-adjoin char-set-adjoin!
+ char-set-delete char-set-delete!
+ char-set-invert char-set-invert!
+ char-set-union char-set-union!
+ char-set-intersection char-set-intersection!
+ char-set-difference char-set-difference!
+ char-set-xor char-set-xor!
+ char-set-diff+intersection char-set-diff+intersection!
+ char-set:lower-case char-set:upper-case
+ char-set:title-case char-set:letter
+ char-set:digit char-set:letter+digit
+ char-set:graphic char-set:printing
+ char-set:whitespace char-set:iso-control
+ char-set:punctuation char-set:symbol
+ char-set:hex-digit char-set:blank
+ char-set:ascii char-set:empty
+ char-set:full
+
+
+What Is Not Included =================================================
+
+ The following low-level procedures and syntax defined in SRFI-13
+ are currently not supported.
+
+ string-parse-start+end
+ string-parse-final-start+end
+ let-string-start+end
+ check-substring-spec
+ substring-spec-ok?
+ make-kmp-restart-vector
+ kmp-step
+ string-search-kmp
diff --git a/srfi/autogen.sh b/srfi/autogen.sh
new file mode 100755
index 000000000..e69de29bb
--- /dev/null
+++ b/srfi/autogen.sh
diff --git a/srfi/configure.in b/srfi/configure.in
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/srfi/configure.in
diff --git a/srfi/guile-srfi.texi b/srfi/guile-srfi.texi
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/srfi/guile-srfi.texi
diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c
new file mode 100644
index 000000000..692f683fe
--- /dev/null
+++ b/srfi/srfi-13.c
@@ -0,0 +1,3052 @@
+/* srfi-13.c --- SRFI-13 procedures for Guile
+ *
+ * Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2, or (at
+ * your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives
+ * permission for additional uses of the text contained in its release
+ * of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other
+ * files to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public
+ * License. Your use of that executable is in no way restricted on
+ * account of linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public
+ * License.
+ *
+ * This exception applies only to the code released by the Free
+ * Software Foundation under the name GUILE. If you copy code from
+ * other Free Software Foundation releases into a copy of GUILE, as
+ * the General Public License permits, the exception does not apply to
+ * the code that you add in this way. To avoid misleading anyone as
+ * to the status of such modified files, you must delete this
+ * exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+
+#include <string.h>
+#include <ctype.h>
+
+#include <libguile.h>
+
+#include "srfi-14.h"
+
+SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0,
+ (SCM pred, SCM s, SCM start, SCM end),
+ "Check if the predicate @var{pred} is true for any character in\n"
+ "the string @var{s}, proceeding from left (index @var{start}) to\n"
+ "right (index @var{end}). If @code{string-any} returns true,\n"
+ "the returned true value is the one produced by the application\n"
+ "of @var{pred}.")
+#define FUNC_NAME s_scm_string_any
+{
+ char * cstr;
+ int cstart, cend;
+ SCM res;
+
+ SCM_VALIDATE_PROC (1, pred);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ cstr += cstart;
+ while (cstart < cend)
+ {
+ res = scm_apply (pred, SCM_MAKE_CHAR (*cstr), scm_listofnull);
+ if (!SCM_FALSEP (res))
+ return res;
+ cstr++;
+ cstart++;
+ }
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0,
+ (SCM pred, SCM s, SCM start, SCM end),
+ "Check if the predicate @var{pred} is true for every character\n"
+ "in the string @var{s}, proceeding from left (index @var{start})\n"
+ "to right (index @var{end}). If @code{string-every} returns\n"
+ "true, the returned true value is the one produced by the final\n"
+ "application of @var{pred} to the last character of @var{s}.")
+#define FUNC_NAME s_scm_string_every
+{
+ char * cstr;
+ int cstart, cend;
+ SCM res;
+
+ SCM_VALIDATE_PROC (1, pred);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ res = SCM_BOOL_F;
+ cstr += cstart;
+ while (cstart < cend)
+ {
+ res = scm_apply (pred, SCM_MAKE_CHAR (*cstr), scm_listofnull);
+ if (SCM_FALSEP (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
+{
+ int clen, i;
+ SCM res;
+ SCM ch;
+ char * p;
+
+ SCM_VALIDATE_PROC (1, proc);
+ SCM_VALIDATE_INUM_COPY (2, len, clen);
+ SCM_ASSERT_RANGE (2, len, clen >= 0);
+
+ res = scm_allocate_string (clen);
+ p = SCM_STRING_CHARS (res);
+ i = 0;
+ while (i < clen)
+ {
+ ch = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull);
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (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
+{
+ char * cstr;
+ int cstart, cend;
+ SCM result = SCM_EOL;
+
+ SCM_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);
+
+ if (i < 0)
+ SCM_WRONG_TYPE_ARG (1, chrs);
+ result = scm_allocate_string (i);
+
+ {
+ unsigned char *data = SCM_STRING_UCHARS (result) + i;
+
+ while (SCM_NNULLP (chrs))
+ {
+ 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_makfrom0str (" ");
+ del_len = 1;
+ }
+ else
+ {
+ SCM_VALIDATE_STRING (2, delimiter);
+ del_len = SCM_STRING_LENGTH (delimiter);
+ }
+
+ /* Validate the grammar symbol and remember the grammar. */
+ if (SCM_UNBNDP (grammar))
+ gram = GRAM_INFIX;
+ else if (SCM_EQ_P (grammar, scm_sym_infix))
+ gram = GRAM_INFIX;
+ else if (SCM_EQ_P (grammar, scm_sym_strict_infix))
+ gram = GRAM_STRICT_INFIX;
+ else if (SCM_EQ_P (grammar, scm_sym_suffix))
+ gram = GRAM_SUFFIX;
+ else if (SCM_EQ_P (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_STRING_LENGTH (elt);
+ tmp = SCM_CDR (tmp);
+ }
+
+ result = scm_allocate_string (len + extra_len);
+ p = SCM_STRING_CHARS (result);
+
+ tmp = ls;
+ switch (gram)
+ {
+ case GRAM_INFIX:
+ case GRAM_STRICT_INFIX:
+ while (!SCM_NULLP (tmp))
+ {
+ SCM elt = SCM_CAR (tmp);
+ memmove (p, SCM_STRING_CHARS (elt),
+ SCM_STRING_LENGTH (elt) * sizeof (char));
+ p += SCM_STRING_LENGTH (elt);
+ if (!SCM_NULLP (SCM_CDR (tmp)) && del_len > 0)
+ {
+ memmove (p, SCM_STRING_CHARS (delimiter),
+ SCM_STRING_LENGTH (delimiter) * sizeof (char));
+ p += del_len;
+ }
+ tmp = SCM_CDR (tmp);
+ }
+ break;
+ case GRAM_SUFFIX:
+ while (!SCM_NULLP (tmp))
+ {
+ SCM elt = SCM_CAR (tmp);
+ memmove (p, SCM_STRING_CHARS (elt),
+ SCM_STRING_LENGTH (elt) * sizeof (char));
+ p += SCM_STRING_LENGTH (elt);
+ if (del_len > 0)
+ {
+ memmove (p, SCM_STRING_CHARS (delimiter),
+ SCM_STRING_LENGTH (delimiter) * sizeof (char));
+ 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_STRING_CHARS (delimiter),
+ SCM_STRING_LENGTH (delimiter) * sizeof (char));
+ p += del_len;
+ }
+ memmove (p, SCM_STRING_CHARS (elt),
+ SCM_STRING_LENGTH (elt) * sizeof (char));
+ p += SCM_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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 2, start, cstart,
+ 3, end, cend);
+ return scm_makfromstr (cstr + start, cend - cstart, 0);
+
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
+ (SCM str, SCM start, SCM end),
+ "Like @code{substring}, but the result may share memory with the\n"
+ "argument @var{str}.")
+#define FUNC_NAME s_scm_substring_shared
+{
+ SCM_VALIDATE_STRING (1, str);
+ SCM_VALIDATE_INUM (2, start);
+ if (SCM_UNBNDP (end))
+ end = SCM_MAKINUM (SCM_STRING_LENGTH (str));
+ else
+ SCM_VALIDATE_INUM (3, end);
+ if (SCM_INUM (start) == 0 &&
+ SCM_INUM (end) == SCM_STRING_LENGTH (str))
+ return str;
+ return scm_substring (str, start, end);
+}
+#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
+{
+ char * cstr, * ctarget;
+ int cstart, cend, ctstart, dummy;
+ int len;
+ SCM sdummy = SCM_UNDEFINED;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target, ctarget,
+ 2, tstart, ctstart,
+ 2, sdummy, dummy);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
+ 4, start, cstart,
+ 5, end, cend);
+ len = cend - cstart;
+ SCM_ASSERT_RANGE (3, s, len <= SCM_STRING_LENGTH (target) - ctstart);
+
+ memmove (SCM_STRING_CHARS (target) + ctstart,
+ SCM_STRING_CHARS (s) + cstart,
+ len * sizeof (char));
+ 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
+{
+ char * cstr;
+ int cn;
+
+ SCM_VALIDATE_STRING_COPY (1, s, cstr);
+ SCM_VALIDATE_INUM_COPY (2, n, cn);
+ SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s));
+
+ return scm_makfromstr (cstr, cn, 0);
+}
+#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
+{
+ char * cstr;
+ int cn;
+
+ SCM_VALIDATE_STRING_COPY (1, s, cstr);
+ SCM_VALIDATE_INUM_COPY (2, n, cn);
+ SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s));
+
+ return scm_makfromstr (cstr + cn, SCM_STRING_LENGTH (s) - cn, 0);
+}
+#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
+{
+ char * cstr;
+ int cn;
+
+ SCM_VALIDATE_STRING_COPY (1, s, cstr);
+ SCM_VALIDATE_INUM_COPY (2, n, cn);
+ SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s));
+
+ return scm_makfromstr (cstr + SCM_STRING_LENGTH (s) - cn, cn, 0);
+}
+#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
+{
+ char * cstr;
+ int cn;
+
+ SCM_VALIDATE_STRING_COPY (1, s, cstr);
+ SCM_VALIDATE_INUM_COPY (2, n, cn);
+ SCM_ASSERT_RANGE (2, n, cn >= 0 && cn <= SCM_STRING_LENGTH (s));
+
+ return scm_makfromstr (cstr, SCM_STRING_LENGTH (s) - cn, 0);
+}
+#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;
+ char * cstr;
+ int cstart, cend, clen;
+ SCM result;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 4, start, cstart,
+ 5, end, cend);
+ SCM_VALIDATE_INUM_COPY (2, len, clen);
+ if (SCM_UNBNDP (chr))
+ cchr = ' ';
+ else
+ {
+ SCM_VALIDATE_CHAR (3, chr);
+ cchr = SCM_CHAR (chr);
+ }
+ result = scm_allocate_string (clen);
+ if (clen < (cend - cstart))
+ memmove (SCM_STRING_CHARS (result),
+ cstr + cend - clen,
+ clen * sizeof (char));
+ else
+ {
+ memset (SCM_STRING_CHARS (result), cchr,
+ (clen - (cend - cstart)) * sizeof (char));
+ memmove (SCM_STRING_CHARS (result) + (clen - (cend - cstart)),
+ cstr + cstart,
+ (cend - cstart) * sizeof (char));
+ }
+ 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;
+ char * cstr;
+ int cstart, cend, clen;
+ SCM result;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 4, start, cstart,
+ 5, end, cend);
+ SCM_VALIDATE_INUM_COPY (2, len, clen);
+ if (SCM_UNBNDP (chr))
+ cchr = ' ';
+ else
+ {
+ SCM_VALIDATE_CHAR (3, chr);
+ cchr = SCM_CHAR (chr);
+ }
+ result = scm_allocate_string (clen);
+ if (clen < (cend - cstart))
+ memmove (SCM_STRING_CHARS (result), cstr + cstart, clen * sizeof (char));
+ else
+ {
+ memset (SCM_STRING_CHARS (result) + (cend - cstart),
+ cchr, (clen - (cend - cstart)) * sizeof (char));
+ memmove (SCM_STRING_CHARS (result), cstr + cstart,
+ (cend - cstart) * sizeof (char));
+ }
+ 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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_UNBNDP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (!isspace(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_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]),
+ scm_listofnull);
+ if (SCM_FALSEP (res))
+ break;
+ cstart++;
+ }
+ }
+ return scm_makfromstr (cstr + cstart, cend - cstart, 0);
+}
+#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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_UNBNDP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (!isspace(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_apply (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]),
+ scm_listofnull);
+ if (SCM_FALSEP (res))
+ break;
+ cend--;
+ }
+ }
+ return scm_makfromstr (cstr + cstart, cend - cstart, 0);
+}
+#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\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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_UNBNDP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (!isspace(cstr[cstart]))
+ break;
+ cstart++;
+ }
+ while (cstart < cend)
+ {
+ if (!isspace(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_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]),
+ scm_listofnull);
+ if (SCM_FALSEP (res))
+ break;
+ cstart++;
+ }
+ while (cstart < cend)
+ {
+ SCM res;
+
+ res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]),
+ scm_listofnull);
+ if (SCM_FALSEP (res))
+ break;
+ cend--;
+ }
+ }
+ return scm_makfromstr (cstr + cstart, cend - cstart, 0);
+}
+#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;
+ int cstart, cend;
+ int c;
+ long k;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ SCM_VALIDATE_CHAR_COPY (2, chr, c);
+ for (k = cstart; k < cend; k++)
+ cstr[k] = c;
+ 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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 6, start1, cstart1,
+ 7, end1, cend1);
+ SCM_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_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull);
+ else if (cstr1[cstart1] > cstr2[cstart2])
+ return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull);
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull);
+ else if (cstart2 < cend2)
+ return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull);
+ else
+ return scm_apply (proc_eq, SCM_MAKINUM (cstart1), scm_listofnull);
+}
+#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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 6, start1, cstart1,
+ 7, end1, cend1);
+ SCM_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_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
+ return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull);
+ else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2]))
+ return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull);
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ return scm_apply (proc_gt, SCM_MAKINUM (cstart1), scm_listofnull);
+ else if (cstart2 < cend2)
+ return scm_apply (proc_lt, SCM_MAKINUM (cstart1), scm_listofnull);
+ else
+ return scm_apply (proc_eq, SCM_MAKINUM (cstart1), scm_listofnull);
+}
+#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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_MAKINUM (cstart1);
+ else if (cstr1[cstart1] > cstr2[cstart2])
+ return SCM_MAKINUM (cstart1);
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ return SCM_MAKINUM (cstart1);
+ else if (cstart2 < cend2)
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_MAKINUM (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_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_MAKINUM (cstart1);
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_MAKINUM (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_MAKINUM (cstart1);
+ else
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_MAKINUM (cstart1);
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ return SCM_MAKINUM (cstart1);
+ else if (cstart2 < cend2)
+ return SCM_BOOL_F;
+ else
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
+ return SCM_BOOL_F;
+ else if (scm_downcase (cstr1[cstart1]) > scm_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_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
+ return SCM_MAKINUM (cstart1);
+ else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2]))
+ return SCM_MAKINUM (cstart1);
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ return SCM_MAKINUM (cstart1);
+ else if (cstart2 < cend2)
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
+ return SCM_MAKINUM (cstart1);
+ else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2]))
+ return SCM_BOOL_F;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ return SCM_BOOL_F;
+ else if (cstart2 < cend2)
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
+ return SCM_BOOL_F;
+ else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2]))
+ return SCM_MAKINUM (cstart1);
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
+ return SCM_MAKINUM (cstart1);
+ else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2]))
+ return SCM_BOOL_F;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ return SCM_BOOL_F;
+ else if (cstart2 < cend2)
+ return SCM_MAKINUM (cstart1);
+ else
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_downcase (cstr1[cstart1]) < scm_downcase (cstr2[cstart2]))
+ return SCM_BOOL_F;
+ else if (scm_downcase (cstr1[cstart1]) > scm_downcase (cstr2[cstart2]))
+ return SCM_MAKINUM (cstart1);
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ return SCM_MAKINUM (cstart1);
+ else if (cstart2 < cend2)
+ return SCM_BOOL_F;
+ else
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+ int len = 0;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_MAKINUM (len);
+ len++;
+ cstart1++;
+ cstart2++;
+ }
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+ int len = 0;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_downcase (cstr1[cstart1]) != scm_downcase (cstr2[cstart2]))
+ return SCM_MAKINUM (len);
+ len++;
+ cstart1++;
+ cstart2++;
+ }
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+ int len = 0;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_MAKINUM (len);
+ len++;
+ }
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+ int len = 0;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ cend1--;
+ cend2--;
+ if (scm_downcase (cstr1[cend1]) != scm_downcase (cstr2[cend2]))
+ return SCM_MAKINUM (len);
+ len++;
+ }
+ return SCM_MAKINUM (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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+ int len = 0, len1;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_BOOL (len == len1);
+ len++;
+ cstart1++;
+ cstart2++;
+ }
+ return SCM_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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+ int len = 0, len1;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ len1 = cend1 - cstart1;
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_downcase (cstr1[cstart1]) != scm_downcase (cstr2[cstart2]))
+ return SCM_BOOL (len == len1);
+ len++;
+ cstart1++;
+ cstart2++;
+ }
+ return SCM_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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+ int len = 0, len1;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_BOOL (len == len1);
+ len++;
+ }
+ return SCM_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
+{
+ char * cstr1, * cstr2;
+ int cstart1, cend1, cstart2, cend2;
+ int len = 0, len1;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_downcase (cstr1[cend1]) != scm_downcase (cstr2[cend2]))
+ return SCM_BOOL (len == len1);
+ len++;
+ }
+ return SCM_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\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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_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_MAKINUM (cstart);
+ cstart++;
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ return SCM_MAKINUM (cstart);
+ cstart++;
+ }
+ }
+ else
+ {
+ SCM_VALIDATE_PROC (2, char_pred);
+ while (cstart < cend)
+ {
+ SCM res;
+ res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]),
+ scm_listofnull);
+ if (!SCM_FALSEP (res))
+ return SCM_MAKINUM (cstart);
+ 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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_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_MAKINUM (cend);
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ cend--;
+ if (SCM_CHARSET_GET (char_pred, cstr[cend]))
+ return SCM_MAKINUM (cend);
+ }
+ }
+ else
+ {
+ SCM_VALIDATE_PROC (2, char_pred);
+ while (cstart < cend)
+ {
+ SCM res;
+ cend--;
+ res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend]),
+ scm_listofnull);
+ if (!SCM_FALSEP (res))
+ return SCM_MAKINUM (cend);
+ }
+ }
+ 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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_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_MAKINUM (cstart);
+ cstart++;
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ return SCM_MAKINUM (cstart);
+ cstart++;
+ }
+ }
+ else
+ {
+ SCM_VALIDATE_PROC (2, char_pred);
+ while (cstart < cend)
+ {
+ SCM res;
+ res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]),
+ scm_listofnull);
+ if (SCM_FALSEP (res))
+ return SCM_MAKINUM (cstart);
+ 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 satisifie 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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_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_MAKINUM (cend);
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ cend--;
+ if (!SCM_CHARSET_GET (char_pred, cstr[cend]))
+ return SCM_MAKINUM (cend);
+ }
+ }
+ else
+ {
+ SCM_VALIDATE_PROC (2, char_pred);
+ while (cstart < cend)
+ {
+ SCM res;
+ cend--;
+ res = scm_apply (char_pred, SCM_MAKE_CHAR (cstr[cend]),
+ scm_listofnull);
+ if (SCM_FALSEP (res))
+ return SCM_MAKINUM (cend);
+ }
+ }
+ 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
+{
+ char * cstr;
+ int cstart, cend;
+ int count = 0;
+
+ SCM_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_apply (char_pred, SCM_MAKE_CHAR (cstr[cstart]),
+ scm_listofnull);
+ if (!SCM_FALSEP (res))
+ count++;
+ cstart++;
+ }
+ }
+ return SCM_MAKINUM (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
+{
+ char * cs1, * cs2;
+ int cstart1, cend1, cstart2, cend2;
+ int len2, i, j;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_MAKINUM (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
+{
+ char * cs1, * cs2;
+ int cstart1, cend1, cstart2, cend2;
+ int len2, i, j;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_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_downcase (cs1[i]) == scm_downcase (cs2[j]))
+ {
+ i++;
+ j++;
+ }
+ if (j == cend2)
+ return SCM_MAKINUM (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)
+{
+ unsigned long k;
+
+ for (k = start; k < end; ++k)
+ SCM_STRING_UCHARS (v) [k] = scm_upcase (SCM_STRING_UCHARS (v) [k]);
+
+ 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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_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)
+{
+ unsigned long k;
+
+ for (k = start; k < end; ++k)
+ SCM_STRING_UCHARS (v) [k] = scm_downcase (SCM_STRING_UCHARS (v) [k]);
+
+ 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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_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)
+{
+ char * sz;
+ int i, in_word = 0;
+
+ sz = SCM_STRING_CHARS (str);
+ for(i = start; i < end; i++)
+ {
+ if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKE_CHAR(sz[i]))))
+ {
+ if (!in_word)
+ {
+ sz[i] = scm_upcase(sz[i]);
+ in_word = 1;
+ }
+ else
+ {
+ sz[i] = scm_downcase(sz[i]);
+ }
+ }
+ else
+ in_word = 0;
+ }
+ 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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_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
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_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
+{
+ char * cstr;
+ int cstart;
+ int cend;
+ SCM result;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 2, start, cstart,
+ 3, end, cend);
+ result = scm_string_copy (str);
+ string_reverse_x (SCM_STRING_CHARS (result), cstart, cend);
+ 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;
+ int cstart;
+ int cend;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 2, start, cstart,
+ 3, end, cend);
+ string_reverse_x (SCM_STRING_CHARS (str), cstart, cend);
+ 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;
+ int 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_STRING_LENGTH (elt);
+ tmp = SCM_CDR (tmp);
+ }
+ result = scm_allocate_string (len);
+
+ /* Copy the list elements into the result. */
+ p = SCM_STRING_CHARS (result);
+ tmp = ls;
+ while (!SCM_NULLP (tmp))
+ {
+ SCM elt = SCM_CAR (tmp);
+ memmove (p, SCM_STRING_CHARS (elt),
+ SCM_STRING_LENGTH (elt) * sizeof (char));
+ p += SCM_STRING_LENGTH (elt);
+ tmp = SCM_CDR (tmp);
+ }
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_reverse_string_concatenate, "reverse-string-concatenate", 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.\n"
+ "\n"
+ "Guaranteed to return a freshly allocated string.")
+#define FUNC_NAME s_scm_reverse_string_concatenate
+{
+ long strings;
+ SCM tmp, result;
+ int len = 0;
+ char * p;
+ int 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))
+ {
+ SCM_VALIDATE_INUM_COPY (3, end, cend);
+ SCM_ASSERT_RANGE (3, end,
+ (cend >= 0) &&
+ (cend <= SCM_STRING_LENGTH (final_string)));
+ }
+ else
+ {
+ cend = SCM_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_STRING_LENGTH (elt);
+ tmp = SCM_CDR (tmp);
+ }
+
+ result = scm_allocate_string (len);
+
+ p = SCM_STRING_CHARS (result) + len;
+
+ /* Construct the result string, possibly by using the optional final
+ string. */
+ if (!SCM_UNBNDP (final_string))
+ {
+ p -= cend;
+ memmove (p, SCM_STRING_CHARS (final_string), cend * sizeof (char));
+ }
+ tmp = ls;
+ while (!SCM_NULLP (tmp))
+ {
+ SCM elt = SCM_CAR (tmp);
+ p -= SCM_STRING_LENGTH (elt);
+ memmove (p, SCM_STRING_CHARS (elt),
+ SCM_STRING_LENGTH (elt) * sizeof (char));
+ 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_reverse_string_concatenate_shared, "reverse-string-concatenate/shared", 1, 2, 0,
+ (SCM ls, SCM final_string, SCM end),
+ "Like @code{reverse-string-concatenate}, but the result may\n"
+ "share memory with the the strings in the @var{ls} arguments.")
+#define FUNC_NAME s_scm_reverse_string_concatenate_shared
+{
+ /* Just call the non-sharing version. */
+ return scm_reverse_string_concatenate (ls, final_string, end);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
+ (SCM s, SCM proc, 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
+{
+ char * cstr, *p;
+ int cstart, cend;
+ SCM result;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ SCM_VALIDATE_PROC (2, proc);
+ result = scm_allocate_string (cend - cstart);
+ p = SCM_STRING_CHARS (result);
+ while (cstart < cend)
+ {
+ SCM ch = scm_apply (proc, SCM_MAKE_CHAR (cstr[cstart]),
+ scm_listofnull);
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc));
+ cstart++;
+ *p++ = SCM_CHAR (ch);
+ }
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0,
+ (SCM s, SCM proc, 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
+{
+ char * cstr, *p;
+ int cstart, cend;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ SCM_VALIDATE_PROC (2, proc);
+ p = SCM_STRING_CHARS (s) + cstart;
+ while (cstart < cend)
+ {
+ SCM ch = scm_apply (proc, SCM_MAKE_CHAR (cstr[cstart]),
+ scm_listofnull);
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc));
+ cstart++;
+ *p++ = SCM_CHAR (ch);
+ }
+ 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
+{
+ char * cstr;
+ int cstart, cend;
+ SCM result;
+
+ SCM_VALIDATE_PROC (1, kons);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
+ 4, start, cstart,
+ 5, end, cend);
+ result = knil;
+ while (cstart < cend)
+ {
+ result = scm_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (cstr[cstart]),
+ result), SCM_EOL);
+ 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
+{
+ char * cstr;
+ int cstart, cend;
+ SCM result;
+
+ SCM_VALIDATE_PROC (1, kons);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
+ 4, start, cstart,
+ 5, end, cend);
+ result = knil;
+ while (cstart < cend)
+ {
+ result = scm_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (cstr[cend - 1]),
+ result), SCM_EOL);
+ 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\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_allocate_string (0);
+ if (!SCM_UNBNDP (make_final))
+ SCM_VALIDATE_PROC (6, make_final);
+
+ res = scm_apply (p, seed, scm_listofnull);
+ while (SCM_FALSEP (res))
+ {
+ SCM str;
+ SCM ch = scm_apply (f, seed, scm_listofnull);
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f));
+ str = scm_allocate_string (1);
+ *SCM_STRING_CHARS (str) = SCM_CHAR (ch);
+
+ ans = scm_string_append (SCM_LIST2 (ans, str));
+ seed = scm_apply (g, seed, scm_listofnull);
+ res = scm_apply (p, seed, scm_listofnull);
+ }
+ if (!SCM_UNBNDP (make_final))
+ {
+ res = scm_apply (make_final, seed, scm_listofnull);
+ return scm_string_append (SCM_LIST2 (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\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_allocate_string (0);
+ if (!SCM_UNBNDP (make_final))
+ SCM_VALIDATE_PROC (6, make_final);
+
+ res = scm_apply (p, seed, scm_listofnull);
+ while (SCM_FALSEP (res))
+ {
+ SCM str;
+ SCM ch = scm_apply (f, seed, scm_listofnull);
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f));
+ str = scm_allocate_string (1);
+ *SCM_STRING_CHARS (str) = SCM_CHAR (ch);
+
+ ans = scm_string_append (SCM_LIST2 (str, ans));
+ seed = scm_apply (g, seed, scm_listofnull);
+ res = scm_apply (p, seed, scm_listofnull);
+ }
+ if (!SCM_UNBNDP (make_final))
+ {
+ res = scm_apply (make_final, seed, scm_listofnull);
+ return scm_string_append (SCM_LIST2 (res, ans));
+ }
+ else
+ return ans;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0,
+ (SCM s, SCM proc, SCM start, SCM end),
+ "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
+ "return value is not specified.")
+#define FUNC_NAME s_scm_string_for_each
+{
+ char * cstr;
+ int cstart, cend;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ SCM_VALIDATE_PROC (2, proc);
+ while (cstart < cend)
+ {
+ scm_apply (proc, SCM_MAKE_CHAR (cstr[cstart]), scm_listofnull);
+ 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
+{
+ char * cs, * p;
+ int cstart, cend, cfrom, cto;
+ SCM result;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cs,
+ 4, start, cstart,
+ 5, end, cend);
+ SCM_VALIDATE_INUM_COPY (2, from, cfrom);
+ SCM_VALIDATE_INUM_DEF_COPY (3, to, cfrom + (cend - cstart), cto);
+ if (cstart == cend && cfrom != cto)
+ SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
+
+ result = scm_allocate_string (cto - cfrom);
+
+ p = SCM_STRING_CHARS (result);
+ while (cfrom < cto)
+ {
+ int t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart);
+ if (cfrom < 0)
+ *p = cs[(cend - cstart) - t];
+ else
+ *p = cs[t];
+ cfrom++;
+ p++;
+ }
+ 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 * ctarget, * cs, * p;
+ int ctstart, csfrom, csto, cstart, cend;
+ SCM dummy = SCM_UNDEFINED;
+ int cdummy;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target, ctarget,
+ 2, tstart, ctstart,
+ 2, dummy, cdummy);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cs,
+ 6, start, cstart,
+ 7, end, cend);
+ SCM_VALIDATE_INUM_COPY (4, sfrom, csfrom);
+ SCM_VALIDATE_INUM_DEF_COPY (5, sto, csfrom + (cend - cstart), csto);
+ 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_STRING_LENGTH (target));
+
+ p = ctarget + 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++;
+ }
+ 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
+{
+ char * cstr1, * cstr2, * p;
+ int cstart1, cend1, cstart2, cend2;
+ SCM result;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ result = scm_allocate_string (cstart1 + (cend2 - cstart2) +
+ SCM_STRING_LENGTH (s1) - cend1);
+ p = SCM_STRING_CHARS (result);
+ memmove (p, cstr1, cstart1);
+ memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2));
+ memmove (p + cstart1 + (cend2 - cstart2),
+ cstr1 + cend1,
+ SCM_STRING_LENGTH (s1) - cend1);
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
+ (SCM s, SCM token_char, SCM start, SCM end),
+ "Split the string @var{s} into a list of substrings, where each\n"
+ "substring is a maximal non-empty contiguous sequence of\n"
+ "characters equal to the character @var{token_char}, or\n"
+ "whitespace, if @var{token_char} is not given. If\n"
+ "@var{token_char} is a character set, it is used for finding the\n"
+ "token borders.")
+#define FUNC_NAME s_scm_string_tokenize
+{
+ char * cstr;
+ int cstart, cend;
+ SCM result = SCM_EOL;
+
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_UNBNDP (token_char))
+ {
+ int idx;
+
+ while (cstart < cend)
+ {
+ while (cstart < cend)
+ {
+ if (!isspace (cstr[cend - 1]))
+ break;
+ cend--;
+ }
+ if (cstart >= cend)
+ break;
+ idx = cend;
+ while (cstart < cend)
+ {
+ if (isspace (cstr[cend - 1]))
+ break;
+ cend--;
+ }
+ result = scm_cons (scm_makfromstr (cstr + cend, idx - cend,
+ 0), result);
+ }
+ }
+ else if (SCM_CHARSETP (token_char))
+ {
+ int idx;
+
+ while (cstart < cend)
+ {
+ while (cstart < cend)
+ {
+ if (!SCM_CHARSET_GET (token_char, cstr[cend - 1]))
+ break;
+ cend--;
+ }
+ if (cstart >= cend)
+ break;
+ idx = cend;
+ while (cstart < cend)
+ {
+ if (SCM_CHARSET_GET (token_char, cstr[cend - 1]))
+ break;
+ cend--;
+ }
+ result = scm_cons (scm_makfromstr (cstr + cend, idx - cend,
+ 0), result);
+ }
+ }
+ else
+ {
+ int idx;
+ char chr;
+
+ SCM_VALIDATE_CHAR (2, token_char);
+ chr = SCM_CHAR (token_char);
+
+ while (cstart < cend)
+ {
+ while (cstart < cend)
+ {
+ if (cstr[cend - 1] != chr)
+ break;
+ cend--;
+ }
+ if (cstart >= cend)
+ break;
+ idx = cend;
+ while (cstart < cend)
+ {
+ if (cstr[cend - 1] == chr)
+ break;
+ cend--;
+ }
+ result = scm_cons (scm_makfromstr (cstr + cend, idx - cend,
+ 0), result);
+ }
+ }
+ 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
+{
+ char * cstr;
+ int cstart, cend;
+ SCM result;
+ int idx;
+
+ SCM_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);
+ 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);
+ 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_apply (char_pred, SCM_MAKE_CHAR (cstr[idx]),
+ scm_listofnull);
+ if (!SCM_FALSEP (res))
+ ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
+ idx++;
+ }
+ result = scm_reverse_list_to_string (ls);
+ }
+ 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
+{
+ char * cstr;
+ int cstart, cend;
+ SCM result;
+ int idx;
+
+ SCM_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);
+ 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);
+ 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_apply (char_pred, SCM_MAKE_CHAR (cstr[idx]),
+ scm_listofnull);
+ if (SCM_FALSEP (res))
+ ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
+ idx++;
+ }
+ result = scm_reverse_list_to_string (ls);
+ }
+ return result;
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_srfi_13 ()
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "srfi-13.x"
+#endif
+}
+
+
+void
+scm_init_srfi_13_14 ()
+{
+ static int initialized = 0;
+
+ if (!initialized)
+ {
+ SCM srfi_13_module = scm_make_module (scm_read_0str ("(srfi srfi-13)"));
+ SCM srfi_14_module = scm_make_module (scm_read_0str ("(srfi srfi-14)"));
+ SCM old_module;
+
+ initialized = 1;
+
+ old_module = scm_set_current_module (srfi_13_module);
+ scm_init_srfi_13 ();
+ scm_set_current_module (srfi_14_module);
+ scm_init_srfi_14 ();
+
+ scm_set_current_module (old_module);
+ }
+}
diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm
new file mode 100644
index 000000000..9b28b65ee
--- /dev/null
+++ b/srfi/srfi-13.scm
@@ -0,0 +1,141 @@
+;;;; srfi-13.scm --- SRFI-13 procedures for Guile
+;;;;
+;;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public License as
+;;;; published by the Free Software Foundation; either version 2, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+
+(define-module (srfi srfi-13))
+
+(export
+;;; Predicates
+ ;; string? string-null? <= in the core
+ string-any string-every
+
+;;; Constructors
+ ;; make-string string <= in the core
+ string-tabulate
+
+;;; List/string conversion
+ string->list
+ ;; list->string <= in the core
+ reverse-list->string
+ string-join
+
+;;; Selection
+ ;; string-length string-ref <= in the core
+ string-copy
+ substring/shared
+ string-copy!
+ string-take string-take-right
+ string-drop string-drop-right
+ string-pad string-pad-right
+ string-trim string-trim-right
+ string-trim-both
+
+;;; Modification
+ ;; string-set! <= in the core
+ string-fill!
+
+;;; Comparison
+ string-compare string-compare-ci
+ string= string<>
+ string< string>
+ string<= string>=
+ string-ci= string-ci<>
+ string-ci< string-ci>
+ string-ci<= string-ci>=
+ string-hash string-hash-ci ; FIXME::martin: rewrite in C?
+
+;;; Prefixes/Suffixes
+ string-prefix-length
+ string-prefix-length-ci
+ string-suffix-length
+ string-suffix-length-ci
+ string-prefix?
+ string-prefix-ci?
+ string-suffix?
+ string-suffix-ci?
+
+;;; Searching
+ string-index string-index-right
+ string-skip string-skip-right
+ string-count
+ string-contains string-contains-ci
+
+;;; Alphabetic case mapping
+
+ string-upcase string-upcase!
+ string-downcase string-downcase!
+ string-titlecase string-titlecase!
+
+;;; Reverse/Append
+ string-reverse string-reverse!
+ ;; string-append <= in the core
+ string-append/shared
+ string-concatenate
+ reverse-string-concatenate
+ string-concatenate/shared
+ reverse-string-concatenate/shared
+
+;;; Fold/Unfold/Map
+ string-map string-map!
+ string-fold
+ string-fold-right
+ string-unfold
+ string-unfold-right
+ string-for-each
+
+;;; Replicate/Rotate
+ xsubstring string-xcopy!
+
+;;; Miscellaneous
+ string-replace
+ string-tokenize
+
+;;; Filtering/Deleting
+ string-filter
+ string-delete
+ )
+
+(dynamic-call "scm_init_srfi_13_14" (dynamic-link "libguile-srfi-srfi-13-14"))
+
+(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))))
diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c
new file mode 100644
index 000000000..b3af7c2b4
--- /dev/null
+++ b/srfi/srfi-14.c
@@ -0,0 +1,1361 @@
+/* srfi-14.c --- SRFI-14 procedures for Guile
+ *
+ * Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2, or (at
+ * your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives
+ * permission for additional uses of the text contained in its release
+ * of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other
+ * files to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public
+ * License. Your use of that executable is in no way restricted on
+ * account of linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public
+ * License.
+ *
+ * This exception applies only to the code released by the Free
+ * Software Foundation under the name GUILE. If you copy code from
+ * other Free Software Foundation releases into a copy of GUILE, as
+ * the General Public License permits, the exception does not apply to
+ * the code that you add in this way. To avoid misleading anyone as
+ * to the status of such modified files, you must delete this
+ * exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+
+#include <string.h>
+
+#include <libguile.h>
+
+#include "srfi-14.h"
+
+#define SCM_CHARSET_SET(cs, idx) (((long *) SCM_SMOB_DATA (cs))[(idx) / sizeof (long)] |= (1 << ((idx) % sizeof (long))))
+
+SCM scm_char_set_copy (SCM cs);
+
+/* 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)
+{
+ int i;
+ int first = 1;
+
+ scm_puts ("#<charset {", port);
+ for (i = 0; i < SCM_CHARSET_SIZE; i++)
+ if (SCM_CHARSET_GET (charset, i))
+ {
+ if (first)
+ first = 0;
+ else
+ scm_puts (" ", port);
+ scm_write (SCM_MAKE_CHAR (i), port);
+ }
+ scm_puts ("}>", port);
+ return 1;
+}
+
+
+/* Smob free hook for character sets. */
+static scm_sizet
+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_must_malloc (SCM_CHARSET_SIZE, func_name);
+ memset (p, 0, SCM_CHARSET_SIZE);
+ 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_BOOL (SCM_SMOB_PREDICATE (scm_tc16_charset, obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_eq, "char-set=", 1, 0, 1,
+ (SCM cs1, SCM csr),
+ "Return @code{#t} if all given character sets are equal.")
+#define FUNC_NAME s_scm_char_set_eq
+{
+ int argnum = 2;
+
+ SCM_VALIDATE_SMOB (1, cs1, charset);
+ SCM_VALIDATE_REST_ARGUMENT (csr);
+
+ while (!SCM_NULLP (csr))
+ {
+ long * p1, * p2;
+ SCM cs2 = SCM_CAR (csr);
+ int k;
+
+ SCM_VALIDATE_SMOB (argnum++, cs2, charset);
+ p1 = (long *) SCM_SMOB_DATA (cs1);
+ p2 = (long *) SCM_SMOB_DATA (cs2);
+ for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ {
+ if (p1[k] != p2[k])
+ return SCM_BOOL_F;
+ }
+
+ csr = SCM_CDR (csr);
+ cs1 = cs2;
+ }
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_leq, "char-set<=", 1, 0, 1,
+ (SCM cs1, SCM csr),
+ "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 = 2;
+
+ SCM_VALIDATE_SMOB (1, cs1, charset);
+ SCM_VALIDATE_REST_ARGUMENT (csr);
+
+ while (!SCM_NULLP (csr))
+ {
+ long * p1, * p2;
+ SCM cs2 = SCM_CAR (csr);
+ int k;
+
+ SCM_VALIDATE_SMOB (argnum++, cs2, charset);
+ p1 = (long *) SCM_SMOB_DATA (cs1);
+ p2 = (long *) SCM_SMOB_DATA (cs2);
+ for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ {
+ if ((p1[k] & p2[k]) != p1[k])
+ return SCM_BOOL_F;
+ }
+
+ csr = SCM_CDR (csr);
+ cs1 = cs2;
+ }
+ 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 not @code{#f}, it restricts the\n"
+ "returned value to the range 0 @dots{} @var{bound - 1}.")
+#define FUNC_NAME s_scm_char_set_hash
+{
+ int bnd;
+ long * p;
+ unsigned val = 0;
+ int k;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ if (SCM_UNBNDP (bound) || SCM_FALSEP (bound))
+ bnd = 871;
+ else
+ SCM_VALIDATE_INUM_COPY (2, bound, bnd);
+
+ p = (long *) SCM_SMOB_DATA (cs);
+ for (k = 0; k < SCM_CHARSET_SIZE - 1; k++)
+ {
+ val = p[k] ^ val;
+ }
+ return SCM_MAKINUM (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_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
+{
+ int ccursor;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ SCM_VALIDATE_INUM_COPY (2, cursor, ccursor);
+
+ if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor))
+ SCM_MISC_ERROR ("invalid character set cursor: ~A", SCM_LIST1 (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
+{
+ int ccursor;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ SCM_VALIDATE_INUM_COPY (2, cursor, ccursor);
+
+ if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor))
+ SCM_MISC_ERROR ("invalid character set cursor: ~A", SCM_LIST1 (cursor));
+ for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++)
+ {
+ if (SCM_CHARSET_GET (cs, ccursor))
+ break;
+ }
+ return SCM_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
+{
+ int ccursor;
+
+ SCM_VALIDATE_INUM_COPY (1, cursor, ccursor);
+ return SCM_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_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (k), (knil)),
+ SCM_EOL);
+ }
+ 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\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_apply (p, seed, scm_listofnull);
+ while (SCM_FALSEP (tmp))
+ {
+ SCM ch = scm_apply (f, seed, scm_listofnull);
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f));
+ SCM_CHARSET_SET (result, SCM_CHAR (ch));
+
+ seed = scm_apply (g, seed, scm_listofnull);
+ tmp = scm_apply (p, seed, scm_listofnull);
+ }
+ 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\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_apply (p, seed, scm_listofnull);
+ while (SCM_FALSEP (tmp))
+ {
+ SCM ch = scm_apply (f, seed, scm_listofnull);
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f));
+ SCM_CHARSET_SET (base_cs, SCM_CHAR (ch));
+
+ seed = scm_apply (g, seed, scm_listofnull);
+ tmp = scm_apply (p, seed, scm_listofnull);
+ }
+ 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_apply (proc, SCM_MAKE_CHAR (k), scm_listofnull);
+ 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_apply (proc, SCM_MAKE_CHAR (k), scm_listofnull);
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc));
+ SCM_CHARSET_SET (cs, 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 < SCM_CHARSET_SIZE / sizeof (long); 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, ls;
+ long * p;
+
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+ ls = rest;
+ cs = make_char_set (FUNC_NAME);
+ p = (long *) SCM_SMOB_DATA (cs);
+ while (!SCM_NULLP (ls))
+ {
+ SCM chr = SCM_CAR (ls);
+ int c;
+
+ SCM_VALIDATE_CHAR_COPY (1, chr, c);
+ ls = SCM_CDR (ls);
+
+ p[c / sizeof (long)] |= 1 << (c % sizeof (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 (1, chr, c);
+ list = SCM_CDR (list);
+
+ p[c / sizeof (long)] |= 1 << (c % sizeof (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
+{
+ 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 (1, chr, c);
+ list = SCM_CDR (list);
+
+ p[c / sizeof (long)] |= 1 << (c % sizeof (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;
+ char * s;
+ int k = 0;
+
+ 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_STRING_CHARS (str);
+ while (k < SCM_STRING_LENGTH (str))
+ {
+ int c = s[k++];
+ p[c / sizeof (long)] |= 1 << (c % sizeof (long));
+ }
+ 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;
+ char * s;
+ int k = 0;
+
+ SCM_VALIDATE_STRING (1, str);
+ SCM_VALIDATE_SMOB (2, base_cs, charset);
+ p = (long *) SCM_SMOB_DATA (base_cs);
+ s = SCM_STRING_CHARS (str);
+ while (k < SCM_STRING_LENGTH (str))
+ {
+ int c = s[k++];
+ p[c / sizeof (long)] |= 1 << (c % sizeof (long));
+ }
+ 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_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
+
+ if (!SCM_FALSEP (res))
+ p[k / sizeof (long)] |= 1 << (k % sizeof (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_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
+
+ if (!SCM_FALSEP (res))
+ p[k / sizeof (long)] |= 1 << (k % sizeof (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;
+ int clower, cupper;
+ long * p;
+
+ SCM_VALIDATE_INUM_COPY (1, lower, clower);
+ SCM_VALIDATE_INUM_COPY (2, upper, cupper);
+ SCM_ASSERT_RANGE (1, lower, clower >= 0);
+ SCM_ASSERT_RANGE (2, upper, cupper >= 0 && cupper >= clower);
+ if (!SCM_UNBNDP (error))
+ {
+ if (!SCM_FALSEP (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 / sizeof (long)] |= 1 << (clower % sizeof (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
+{
+ int clower, cupper;
+ long * p;
+
+ SCM_VALIDATE_INUM_COPY (1, lower, clower);
+ SCM_VALIDATE_INUM_COPY (2, upper, cupper);
+ SCM_ASSERT_RANGE (1, lower, clower >= 0);
+ SCM_ASSERT_RANGE (2, upper, cupper >= 0 && cupper >= clower);
+ if (!SCM_FALSEP (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 / sizeof (long)] |= 1 << (clower % sizeof (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_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_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
+ if (!SCM_FALSEP (res))
+ count++;
+ }
+ return SCM_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_allocate_string (count);
+ p = SCM_STRING_CHARS (result);
+ 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_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_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
+ if (SCM_FALSEP (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_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
+ if (!SCM_FALSEP (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 / sizeof (long)] |= 1 << (c % sizeof (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 / sizeof (long)] &= ~(1 << (c % sizeof (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 / sizeof (long)] |= 1 << (c % sizeof (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 / sizeof (long)] &= ~(1 << (c % sizeof (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 < SCM_CHARSET_SIZE / sizeof (long); 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 < SCM_CHARSET_SIZE / sizeof (long); k++)
+ p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_intersection, "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
+{
+ 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 < SCM_CHARSET_SIZE / sizeof (long); k++)
+ p[k] &= ((long *) SCM_SMOB_DATA (cs))[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 < SCM_CHARSET_SIZE / sizeof (long); k++)
+ p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_xor, "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
+{
+ 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 < SCM_CHARSET_SIZE / sizeof (long); k++)
+ p[k] ^= ((long *) SCM_SMOB_DATA (cs))[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 = scm_char_set_copy (cs1);
+ p = (long *) SCM_SMOB_DATA (res1);
+ q = (long *) SCM_SMOB_DATA (res2);
+ 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 < SCM_CHARSET_SIZE / sizeof (long); k++)
+ {
+ p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
+ q[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
+ }
+ }
+ return scm_values (SCM_LIST2 (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 < SCM_CHARSET_SIZE / sizeof (long); 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 < SCM_CHARSET_SIZE / sizeof (long); 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 < SCM_CHARSET_SIZE / sizeof (long); 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 < SCM_CHARSET_SIZE / sizeof (long); 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
+{
+ 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 < SCM_CHARSET_SIZE / sizeof (long); k++)
+ p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k];
+ }
+ return cs1;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 1, 0, 1,
+ (SCM cs1, SCM rest),
+ "Return the difference and the intersection of all argument character sets.")
+#define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
+{
+ int c = 2;
+ SCM res2;
+ long * p, * q;
+
+ SCM_VALIDATE_SMOB (1, cs1, charset);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ res2 = scm_char_set_copy (cs1);
+ p = (long *) SCM_SMOB_DATA (cs1);
+ q = (long *) SCM_SMOB_DATA (res2);
+ 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 < SCM_CHARSET_SIZE / sizeof (long); k++)
+ {
+ p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
+ q[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
+ }
+ }
+ return scm_values (SCM_LIST2 (cs1, res2));
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_srfi_14 ()
+{
+ scm_tc16_charset = scm_make_smob_type ("character-set",
+ SCM_CHARSET_SIZE * sizeof (long));
+ scm_set_smob_free (scm_tc16_charset, charset_free);
+ scm_set_smob_print (scm_tc16_charset, charset_print);
+
+#ifndef SCM_MAGIC_SNARFER
+#include "srfi-14.x"
+#endif
+}
diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h
new file mode 100644
index 000000000..623d1f9ab
--- /dev/null
+++ b/srfi/srfi-14.h
@@ -0,0 +1,61 @@
+#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 program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2, or (at
+ * your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives
+ * permission for additional uses of the text contained in its release
+ * of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other
+ * files to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public
+ * License. Your use of that executable is in no way restricted on
+ * account of linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public
+ * License.
+ *
+ * This exception applies only to the code released by the Free
+ * Software Foundation under the name GUILE. If you copy code from
+ * other Free Software Foundation releases into a copy of GUILE, as
+ * the General Public License permits, the exception does not apply to
+ * the code that you add in this way. To avoid misleading anyone as
+ * to the status of such modified files, you must delete this
+ * exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+
+#define SCM_CHARSET_SIZE 256
+
+#define SCM_CHARSET_GET(cs, idx) (((long *) SCM_SMOB_DATA (cs))\
+ [(idx) / sizeof (long)] & (1 << ((idx) % sizeof (long))))
+
+#define SCM_CHARSETP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_charset))
+
+/* Smob type code for character sets. */
+extern int scm_tc16_charset;
+
+void scm_init_srfi_14 (void);
+
+#endif /* SCM_SRFI_14_H */
diff --git a/srfi/srfi-14.scm b/srfi/srfi-14.scm
new file mode 100644
index 000000000..117e27818
--- /dev/null
+++ b/srfi/srfi-14.scm
@@ -0,0 +1,142 @@
+;;;; srfi-14.scm --- SRFI-14 procedures for Guile
+;;;;
+;;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public License as
+;;;; published by the Free Software Foundation; either version 2, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+
+(define-module (srfi srfi-14))
+
+(export
+;;; General procedures
+ char-set?
+ char-set=
+ char-set<=
+ char-set-hash
+
+;;; Iterating over character sets
+ char-set-cursor
+ char-set-ref
+ char-set-cursor-next
+ end-of-char-set?
+ char-set-fold
+ char-set-unfold char-set-unfold!
+ char-set-for-each
+ char-set-map
+
+;;; Creating character sets
+ char-set-copy
+ char-set
+ list->char-set list->char-set!
+ string->char-set string-char-set!
+ char-set-filter char-set-filter!
+ ucs-range->char-set ucs-range->char-set!
+ ->char-set
+
+;;; Querying character sets
+ char-set-size
+ char-set-count
+ char-set->list
+ char-set->string
+ char-set-contains?
+ char-set-every
+ char-set-any
+
+;;; Character set algebra
+ char-set-adjoin char-set-adjoin!
+ char-set-delete char-set-delete!
+ char-set-complement
+ char-set-union
+ char-set-intersection
+ char-set-difference
+ char-set-xor
+ char-set-diff+intersection
+ char-set-complement!
+ char-set-union!
+ char-set-intersection!
+ char-set-difference!
+ char-set-xor!
+ char-set-diff+intersection!
+
+;;; Standard character sets
+ char-set:lower-case
+ char-set:upper-case
+ char-set:title-case
+ char-set:letter
+ char-set:digit
+ char-set:letter+digit
+ char-set:graphic
+ char-set:printing
+ char-set:whitespace
+ char-set:iso-control
+ char-set:punctuation
+ char-set:symbol
+ char-set:hex-digit
+ char-set:blank
+ char-set:ascii
+ char-set:empty
+ char-set:full
+ )
+
+(dynamic-call "scm_init_srfi_13_14" (dynamic-link "libguile-srfi-srfi-13-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))