From 16e0c623d91810ee6d74934db4a8701455d5bd87 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 18 Aug 2004 00:30:29 +0000 Subject: [PATCH 001/100] * tests/and-let-star.test, tests/arbiters.test, tests/receive.test: New files. * Makefile.am (SCM_TESTS): Add them. --- test-suite/Makefile.am | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 076724aa8..8dc35e58d 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -22,6 +22,7 @@ SUBDIRS = standalone SCM_TESTS = tests/alist.test \ + tests/and-let-star.test \ tests/arbiters.test \ tests/bit-operations.test \ tests/c-api.test \ @@ -57,6 +58,7 @@ SCM_TESTS = tests/alist.test \ tests/r4rs.test \ tests/r5rs_pitfall.test \ tests/reader.test \ + tests/receive.test \ tests/regexp.test \ tests/slib.test \ tests/socket.test \ From a158acd158263325aa416532f18059f1c8010d07 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 18 Aug 2004 00:30:58 +0000 Subject: [PATCH 002/100] *** empty log message *** --- test-suite/ChangeLog | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index c6492ff9e..add8f35c9 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,11 +1,12 @@ 2004-08-18 Kevin Ryde + * tests/and-let-star.test, tests/arbiters.test, tests/receive.test: + New files. + * Makefile.am (SCM_TESTS): Add them. + * tests/fractions.test (fractions): Correction, equal? 3/4 .75 should be #f, according to R5RS. - * tests/arbiters.test: New file - * Makefile.am (SCM_TESTS): Add it. - 2004-08-15 Marius Vollmer * tests/srfi-39.test: New, from Jose A Ortega Ruiz. Thanks! From 35ce851c9e8792c322c7ac5ffa461dc458fafcc0 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 18 Aug 2004 00:34:46 +0000 Subject: [PATCH 003/100] New file. --- test-suite/tests/and-let-star.test | 32 ++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) create mode 100644 test-suite/tests/and-let-star.test diff --git a/test-suite/tests/and-let-star.test b/test-suite/tests/and-let-star.test new file mode 100644 index 000000000..16439463f --- /dev/null +++ b/test-suite/tests/and-let-star.test @@ -0,0 +1,32 @@ +;;;; and-let-star.test --- Tests for Guile and-let-star module. -*- scheme -*- +;;;; +;;;; Copyright (C) 2004 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 (test-suite test-and-let-star) + #:use-module (test-suite lib) + #:use-module (ice-9 and-let-star)) + +;;; +;;; and-let* +;;; + +(with-test-prefix "and-let*" + + (pass-if "cond-expand srfi-2" + (cond-expand (srfi-2 #t) + (else #f)))) From 82e0871c6420accd6e7a4b04e5daed692c755056 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 16:06:45 +0000 Subject: [PATCH 004/100] Align jao's name correctly. --- THANKS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/THANKS b/THANKS index d3ba549b3..6d430b4c5 100644 --- a/THANKS +++ b/THANKS @@ -5,7 +5,7 @@ Contributors since the last release: Neil Jerram Thien-Thi Nguyen Han-Wen Nienhuys - Jose A Ortega Ruiz + Jose A Ortega Ruiz Kevin Ryde Bill Schottstaedt Richard Todd From fddf60002a11cd962db15a905e86f5721eb04680 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 16:41:30 +0000 Subject: [PATCH 005/100] (scm_tc7_stringbuf): New tag. --- libguile/tags.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/tags.h b/libguile/tags.h index 08e33a735..911054d98 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -429,6 +429,7 @@ typedef unsigned long scm_t_bits; #define scm_tc7_string 21 #define scm_tc7_number 23 +#define scm_tc7_stringbuf 39 /* Many of the following should be turned * into structs or smobs. We need back some @@ -439,7 +440,6 @@ typedef unsigned long scm_t_bits; #if SCM_HAVE_ARRAYS #define scm_tc7_llvect 29 #define scm_tc7_uvect 37 -/* free 39 */ #define scm_tc7_fvect 45 #define scm_tc7_dvect 47 #define scm_tc7_cvect 53 From eb01cb6494c4ccf1494ef09ccbb352b4702f7753 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 16:48:38 +0000 Subject: [PATCH 006/100] * gc.h, gc.c (scm_i_gc_admin_mutex): New, to protect scm_gc_mallocated, for now. (scm_init_storage): Initialize it. * gc-malloc.c (descrease_mtrigger, increase_mtrigger): Use it. * gc-mark.c (scm_gc_mark_dependencies): Call scm_i_string_mark, scm_i_stringbuf_mark and scm_i_symbol_mark, as appropriate. * gc-card.c (scm_i_sweep_card): Call scm_i_string_free, scm_i_stringbuf_free and scm_i_symbol_free, as appropriate. --- libguile/gc-card.c | 11 ++++++----- libguile/gc-malloc.c | 24 +++++++++++++++++++----- libguile/gc-mark.c | 20 +++++++++++++------- libguile/gc.c | 6 +++++- libguile/gc.h | 2 ++ 5 files changed, 45 insertions(+), 18 deletions(-) diff --git a/libguile/gc-card.c b/libguile/gc-card.c index 2f57736b3..3bbd12331 100644 --- a/libguile/gc-card.c +++ b/libguile/gc-card.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -193,12 +193,13 @@ scm_i_sweep_card (scm_t_cell * p, SCM *free_list, scm_t_heap_segment*seg) } break; case scm_tc7_string: - scm_gc_free (SCM_I_STRING_CHARS (scmptr), - SCM_I_STRING_LENGTH (scmptr) + 1, "string"); + scm_i_string_free (scmptr); + break; + case scm_tc7_stringbuf: + scm_i_stringbuf_free (scmptr); break; case scm_tc7_symbol: - scm_gc_free (SCM_SYMBOL_CHARS (scmptr), - SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol"); + scm_i_symbol_free (scmptr); break; case scm_tc7_variable: break; diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c index ef7a4e473..b909e9424 100644 --- a/libguile/gc-malloc.c +++ b/libguile/gc-malloc.c @@ -177,38 +177,52 @@ scm_strdup (const char *str) return scm_strndup (str, strlen (str)); } - static void decrease_mtrigger (size_t size, const char * what) { + scm_i_plugin_mutex_lock (&scm_i_gc_admin_mutex); scm_mallocated -= size; scm_gc_malloc_collected += size; + scm_i_plugin_mutex_unlock (&scm_i_gc_admin_mutex); } static void increase_mtrigger (size_t size, const char *what) { + size_t mallocated = 0; + int overflow = 0, triggered = 0; + + scm_i_plugin_mutex_lock (&scm_i_gc_admin_mutex); if (ULONG_MAX - size < scm_mallocated) + overflow = 1; + else + { + scm_mallocated += size; + mallocated = scm_mallocated; + if (scm_mallocated > scm_mtrigger) + triggered = 1; + } + scm_i_plugin_mutex_unlock (&scm_i_gc_admin_mutex); + + if (overflow) { scm_memory_error ("Overflow of scm_mallocated: too much memory in use."); } - scm_mallocated += size; - /* A program that uses a lot of malloced collectable memory (vectors, strings), will use a lot of memory off the cell-heap; it needs to do GC more often (before cells are exhausted), otherwise swapping and malloc management will tie it down. */ - if (scm_mallocated > scm_mtrigger) + if (triggered) { unsigned long prev_alloced; float yield; scm_rec_mutex_lock (&scm_i_sweep_mutex); - prev_alloced = scm_mallocated; + prev_alloced = mallocated; scm_igc (what); scm_i_sweep_all_segments ("mtrigger"); diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c index cb966c9f3..8c5991fd2 100644 --- a/libguile/gc-mark.c +++ b/libguile/gc-mark.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -199,9 +199,9 @@ scm_gc_mark_dependencies (SCM p) scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct; scm_t_bits * vtable_data = (scm_t_bits *) word0; SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); - long len = SCM_SYMBOL_LENGTH (layout); - char * fields_desc = SCM_SYMBOL_CHARS (layout); - scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr); + long len = scm_i_symbol_length (layout); + const char *fields_desc = scm_i_symbol_chars (layout); + scm_t_bits *struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr); if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) { @@ -276,9 +276,15 @@ scm_gc_mark_dependencies (SCM p) #if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: #endif -#endif - case scm_tc7_string: break; +#endif + + case scm_tc7_string: + ptr = scm_i_string_mark (ptr); + goto gc_mark_loop; + case scm_tc7_stringbuf: + ptr = scm_i_stringbuf_mark (ptr); + goto gc_mark_loop; case scm_tc7_number: if (SCM_TYP16 (ptr) == scm_tc16_fraction) @@ -349,7 +355,7 @@ scm_gc_mark_dependencies (SCM p) break; case scm_tc7_symbol: - ptr = SCM_PROP_SLOTS (ptr); + ptr = scm_i_symbol_mark (ptr); goto gc_mark_loop; case scm_tc7_variable: ptr = SCM_CELL_OBJECT_1 (ptr); diff --git a/libguile/gc.c b/libguile/gc.c index 2e163df83..5b3dfa471 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -642,7 +642,7 @@ scm_igc (const char *what) * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the * call to 'some_function'. Note that this would not be necessary if str was * used anyway after the call to 'some_function'. - * char *chars = SCM_I_STRING_CHARS (str); + * char *chars = scm_i_string_chars (str); * some_function (chars); * scm_remember_upto_here_1 (str); // str will be alive up to this point. */ @@ -884,6 +884,8 @@ scm_storage_prehistory () scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL); } +scm_t_mutex scm_i_gc_admin_mutex; + int scm_init_storage () { @@ -891,6 +893,8 @@ scm_init_storage () /* Fixme: Should use mutexattr from the low-level API. */ scm_rec_mutex_init (&scm_i_sweep_mutex, &scm_i_plugin_rec_mutex); + + scm_i_plugin_mutex_init (&scm_i_gc_admin_mutex, &scm_i_plugin_mutex); j = SCM_NUM_PROTECTS; while (j) diff --git a/libguile/gc.h b/libguile/gc.h index 0dc40f618..4e546446b 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -230,6 +230,8 @@ SCM_API int scm_debug_cells_gc_interval ; void scm_i_expensive_validation_check (SCM cell); #endif +SCM_API scm_t_mutex scm_i_gc_admin_mutex; + SCM_API int scm_block_gc; SCM_API int scm_gc_heap_lock; SCM_API unsigned int scm_gc_running_p; From 3ee86942a7cc519ef1c6f6a9868a5136f85558bc Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 16:49:42 +0000 Subject: [PATCH 007/100] * strings.h, strings.c: (scm_i_string_chars, scm_i_string_length, scm_i_string_writable_chars, scm_i_string_stop_writing): New, to replace SCM_I_STRING_CHARS and SCM_I_STRING_LENGTH. Updated all uses. (scm_i_make_string, scm_c_make_string): New, to replace scm_allocate_string. Updated all uses. (SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_UCHARS, SCM_STRING_LENGTH): Deprecated. (scm_allocate_string, scm_take_str, scm_take0str, scm_mem2string, scm_str2string, scm_makfrom0str, scm_makfrom0str_opt): Discouraged. Replaced all uses with scm_from_locale_string or similar, as appropriate. (scm_c_string_length, scm_c_string_ref, scm_c_string_set_x, scm_c_substring, scm_c_substring_shared, scm_c_substring_copy, scm_substring_shared, scm_substring_copy): New. * symbols.c, symbols.h (SCM_SYMBOLP, SCM_SYMBOL_FUNC, SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, SCM_SET_SYMBOL_PROPS, SCM_SYMBOL_HASH, SCM_SYMBOL_INTERNED_P, scm_mem2symbol, scm_str2symbol, scm_mem2uninterned_symbol): Discouraged. (SCM_SYMBOL_LENGTH, SCM_SYMBOL_CHARS, scm_c_symbol2str): Deprecated. (SCM_MAKE_SYMBOL_TAG, SCM_SET_SYMBOL_LENGTH, SCM_SET_SYMBOL_CHARS, SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS): Removed. (scm_is_symbol, scm_from_locale_symbol, scm_from_locale_symboln): New, to replace scm_str2symbol and scm_mem2symbol, respectively. Updated all uses. (scm_gensym): Generate only the number suffix in the buffer, just string-append the prefix. --- libguile/deprecated.c | 66 +++- libguile/deprecated.h | 8 + libguile/discouraged.c | 76 +++- libguile/discouraged.h | 35 ++ libguile/strings.c | 792 +++++++++++++++++++++++++++++++++-------- libguile/strings.h | 117 ++++-- libguile/symbols.c | 169 +++------ libguile/symbols.h | 42 +-- 8 files changed, 964 insertions(+), 341 deletions(-) diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 99b6e70cd..de2d6da16 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -179,7 +179,7 @@ SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0, res = SCM_EOL; for (md = registered_mods; md; md = md->link) - res = scm_cons (scm_cons (scm_makfrom0str (md->module_name), + res = scm_cons (scm_cons (scm_from_locale_string (md->module_name), scm_from_ulong ((unsigned long) md->init_func)), res); return res; @@ -379,17 +379,17 @@ SCM scm_makstr (size_t len, int dummy) { scm_c_issue_deprecation_warning - ("'scm_makstr' is deprecated. Use 'scm_allocate_string' instead."); - return scm_allocate_string (len); + ("'scm_makstr' is deprecated. Use 'scm_c_make_string' instead."); + return scm_c_make_string (len, SCM_UNDEFINED); } SCM scm_makfromstr (const char *src, size_t len, int dummy SCM_UNUSED) { scm_c_issue_deprecation_warning ("`scm_makfromstr' is deprecated. " - "Use `scm_mem2string' instead."); + "Use `scm_from_locale_stringn' instead."); - return scm_mem2string (src, len); + return scm_from_locale_stringn (src, len); } SCM @@ -653,7 +653,7 @@ SCM scm_sym2ovcell_soft (SCM sym, SCM obarray) { SCM lsym, z; - size_t hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); + size_t hash = scm_i_symbol_hash (sym) % SCM_VECTOR_LENGTH (obarray); scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. " "Use hashtables instead."); @@ -716,8 +716,8 @@ scm_sym2ovcell (SCM sym, SCM obarray) SCM scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int softness) { - SCM symbol = scm_mem2symbol (name, len); - size_t raw_hash = SCM_SYMBOL_HASH (symbol); + SCM symbol = scm_from_locale_symboln (name, len); + size_t raw_hash = scm_i_symbol_hash (symbol); size_t hash; SCM lsym; @@ -814,8 +814,8 @@ SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, else if (scm_is_eq (o, SCM_BOOL_T)) o = SCM_BOOL_F; - vcell = scm_intern_obarray_soft (SCM_I_STRING_CHARS(s), - SCM_I_STRING_LENGTH (s), + vcell = scm_intern_obarray_soft (scm_i_string_chars (s), + scm_i_string_length (s), o, softness); if (scm_is_false (vcell)) @@ -841,7 +841,7 @@ SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, "Use hashtables instead."); SCM_VALIDATE_VECTOR (1,o); - hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); + hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o); /* If the symbol is already interned, simply return. */ SCM_REDEFER_INTS; { @@ -883,7 +883,7 @@ SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, if (scm_is_false (o)) return SCM_BOOL_F; SCM_VALIDATE_VECTOR (1,o); - hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); + hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o); SCM_DEFER_INTS; { SCM lsym_follow; @@ -1047,10 +1047,10 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, else { SCM_VALIDATE_STRING (1, prefix); - len = SCM_I_STRING_LENGTH (prefix); + len = scm_i_string_length (prefix); if (len > MAX_PREFIX_LENGTH) name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); - strncpy (name, SCM_I_STRING_CHARS (prefix), len); + strncpy (name, scm_i_string_chars (prefix), len); } if (SCM_UNBNDP (obarray)) @@ -1112,7 +1112,7 @@ scm_c_string2str (SCM obj, char *str, size_t *lenp) { char *result = scm_to_locale_string (obj); if (lenp) - *lenp = SCM_I_STRING_LENGTH (obj); + *lenp = scm_i_string_length (obj); return result; } else @@ -1140,6 +1140,25 @@ scm_c_substring2str (SCM obj, char *str, size_t start, size_t len) return str; } +/* Converts the given Scheme symbol OBJ into a C string, containing a copy + of OBJ's content with a trailing null byte. If LENP is non-NULL, set + *LENP to the string's length. + + When STR is non-NULL it receives the copy and is returned by the function, + otherwise new memory is allocated and the caller is responsible for + freeing it via free(). If out of memory, NULL is returned. + + Note that Scheme symbols may contain arbitrary data, including null + characters. This means that null termination is not a reliable way to + determine the length of the returned value. However, the function always + copies the complete contents of OBJ, and sets *LENP to the length of the + scheme symbol (if LENP is non-null). */ +char * +scm_c_symbol2str (SCM obj, char *str, size_t *lenp) +{ + return scm_c_string2str (scm_symbol_to_string (obj), str, lenp); +} + double scm_truncate (double x) { @@ -1156,6 +1175,23 @@ scm_round (double x) return scm_c_round (x); } +char * +SCM_SYMBOL_CHARS (SCM sym) +{ + scm_c_issue_deprecation_warning + ("SCM_SYMBOL_CHARS is deprecated. Use scm_symbol_to_string."); + + return scm_i_symbol_chars (sym); +} + +size_t +SCM_SYMBOL_LENGTH (SCM sym) +{ + scm_c_issue_deprecation_warning + ("SCM_SYMBOL_LENGTH is deprecated. Use scm_symbol_to_string."); + return scm_c_symbol_length (sym); +} + void scm_i_init_deprecated () { diff --git a/libguile/deprecated.h b/libguile/deprecated.h index bc7f527f7..e3f229566 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -404,6 +404,8 @@ SCM_API char *scm_c_string2str (SCM obj, char *str, size_t *lenp); */ SCM_API char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len); +SCM_API char *scm_c_symbol2str (SCM obj, char *str, size_t *lenp); + /* Deprecated because the names belong to what is now scm_truncate_number and scm_round_number. */ @@ -438,6 +440,12 @@ SCM_API double scm_round (double x); && (size_t) c_end <= SCM_STRING_LENGTH (str));\ } while (0) +/* Deprecated because we don't want people to access the internals of + symbols directly. +*/ + +SCM_API char *SCM_SYMBOL_CHARS (SCM sym); +SCM_API size_t SCM_SYMBOL_LENGTH (SCM sym); void scm_i_init_deprecated (void); diff --git a/libguile/discouraged.c b/libguile/discouraged.c index 7b0dcdc58..10386ce75 100644 --- a/libguile/discouraged.c +++ b/libguile/discouraged.c @@ -2,7 +2,7 @@ discourage something, move it here when that is feasible. */ -/* Copyright (C) 2003 Free Software Foundation, Inc. +/* Copyright (C) 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -82,6 +82,80 @@ scm_make_complex (double x, double y) return scm_c_make_rectangular (x, y); } +SCM +scm_mem2symbol (const char *mem, size_t len) +{ + return scm_from_locale_symboln (mem, len); +} + +SCM +scm_mem2uninterned_symbol (const char *mem, size_t len) +{ + return scm_make_symbol (scm_from_locale_stringn (mem, len)); +} + +SCM +scm_str2symbol (const char *str) +{ + return scm_from_locale_symbol (str); +} + + +/* This function must only be applied to memory obtained via malloc, + since the GC is going to apply `free' to it when the string is + dropped. + + Also, s[len] must be `\0', since we promise that strings are + null-terminated. Perhaps we could handle non-null-terminated + strings by claiming they're shared substrings of a string we just + made up. */ +SCM +scm_take_str (char *s, size_t len) +{ + SCM answer = scm_from_locale_stringn (s, len); + free (s); + return answer; +} + +/* `s' must be a malloc'd string. See scm_take_str. */ +SCM +scm_take0str (char *s) +{ + return scm_take_locale_string (s); +} + +SCM +scm_mem2string (const char *src, size_t len) +{ + return scm_from_locale_stringn (src, len); +} + +SCM +scm_str2string (const char *src) +{ + return scm_from_locale_string (src); +} + +SCM +scm_makfrom0str (const char *src) +{ + if (!src) return SCM_BOOL_F; + return scm_from_locale_string (src); +} + +SCM +scm_makfrom0str_opt (const char *src) +{ + return scm_makfrom0str (src); +} + + +SCM +scm_allocate_string (size_t len) +{ + return scm_i_make_string (len, NULL); +} + void scm_i_init_discouraged (void) { diff --git a/libguile/discouraged.h b/libguile/discouraged.h index 5e8fbc12e..c036d9ad2 100644 --- a/libguile/discouraged.h +++ b/libguile/discouraged.h @@ -113,6 +113,41 @@ SCM_API double scm_num2double (SCM num, unsigned long int pos, SCM_API SCM scm_make_complex (double x, double y); +/* Discouraged because they don't make the encoding explicit. + */ + +SCM_API SCM scm_mem2symbol (const char *mem, size_t len); +SCM_API SCM scm_mem2uninterned_symbol (const char *mem, size_t len); +SCM_API SCM scm_str2symbol (const char *str); + +SCM_API SCM scm_take_str (char *s, size_t len); +SCM_API SCM scm_take0str (char *s); +SCM_API SCM scm_mem2string (const char *src, size_t len); +SCM_API SCM scm_str2string (const char *src); +SCM_API SCM scm_makfrom0str (const char *src); +SCM_API SCM scm_makfrom0str_opt (const char *src); + +/* Discouraged because scm_c_make_string has a better name and is more + consistent with make-string. + */ +SCM_API SCM scm_allocate_string (size_t len); + +/* Discouraged because scm_is_symbol has a better name, + */ +#define SCM_SYMBOLP scm_is_symbol + +/* Discouraged because the alternatives have the better names. + */ +#define SCM_SYMBOL_FUNC scm_symbol_fref +#define SCM_SET_SYMBOL_FUNC scm_symbol_fset_x +#define SCM_SYMBOL_PROPS scm_symbol_pref +#define SCM_SET_SYMBOL_PROPS scm_symbol_pset_x + +/* Discouraged because there are better ways. + */ +#define SCM_SYMBOL_HASH scm_i_symbol_hash +#define SCM_SYMBOL_INTERNED_P(X) scm_i_symbol_is_interned + void scm_i_init_discouraged (void); #endif /* SCM_ENABLE_DISCOURAGED == 1 */ diff --git a/libguile/strings.c b/libguile/strings.c index 0e15f7222..1035244db 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -19,6 +19,7 @@ #include +#include #include "libguile/_scm.h" #include "libguile/chars.h" @@ -33,12 +34,454 @@ /* {Strings} */ + +/* Stringbufs + * + * XXX - keeping an accurate refcount during GC seems to be quite + * tricky, so we just keep score of whether a stringbuf might be + * shared, not wether it definitely is. + * + * The scheme I (mvo) tried to keep an accurate reference count would + * recount all strings that point to a stringbuf during the mark-phase + * of the GC. This was done since one cannot access the stringbuf of + * a string when that string is freed (in order to decrease the + * reference count). The memory of the stringbuf might have been + * reused already for something completely different. + * + * This recounted worked for a small number of threads beating on + * cow-strings, but it failed randomly with more than 10 threads, say. + * I couldn't figure out what went wrong, so I used the conservative + * approach implemented below. + * + * A stringbuf needs to know its length, but only so that it can be + * reported when the stringbuf is freed. + * + * Stringbufs (and strings) are not stored very compactly: a stringbuf + * has room for about 2*sizeof(scm_t_bits)-1 bytes additional + * information. As a compensation, the code below is made more + * complicated by storing small strings inline in the double cell of a + * stringbuf. So we have fixstrings and bigstrings... + */ + +#define STRINGBUF_F_SHARED 0x100 +#define STRINGBUF_F_INLINE 0x200 + +#define STRINGBUF_TAG scm_tc7_stringbuf +#define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED) +#define STRINGBUF_INLINE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE) + +#define STRINGBUF_OUTLINE_CHARS(buf) ((char *)SCM_CELL_WORD_1(buf)) +#define STRINGBUF_OUTLINE_LENGTH(buf) (SCM_CELL_WORD_2(buf)) +#define STRINGBUF_INLINE_CHARS(buf) ((char *)SCM_CELL_OBJECT_LOC(buf,1)) +#define STRINGBUF_INLINE_LENGTH(buf) (((size_t)SCM_CELL_WORD_0(buf))>>16) + +#define STRINGBUF_CHARS(buf) (STRINGBUF_INLINE (buf) \ + ? STRINGBUF_INLINE_CHARS (buf) \ + : STRINGBUF_OUTLINE_CHARS (buf)) +#define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \ + ? STRINGBUF_INLINE_LENGTH (buf) \ + : STRINGBUF_OUTLINE_LENGTH (buf)) + +#define STRINGBUF_MAX_INLINE_LEN (3*sizeof(scm_t_bits)) + +#define SET_STRINGBUF_SHARED(buf) \ + (SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED)) + +#if SCM_DEBUG +static size_t lenhist[1001]; +#endif + +static SCM +make_stringbuf (size_t len) +{ + /* XXX - for the benefit of SCM_STRING_CHARS, SCM_SYMBOL_CHARS and + scm_i_symbol_chars, all stringbufs are null-terminated. Once + SCM_STRING_CHARS and SCM_SYMBOL_CHARS are removed and the code + has been changed for scm_i_symbol_chars, this null-termination + can be dropped. + */ + +#if SCM_DEBUG + if (len < 1000) + lenhist[len]++; + else + lenhist[1000]++; +#endif + + if (len <= STRINGBUF_MAX_INLINE_LEN-1) + { + return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_INLINE | (len << 16), + 0, 0, 0); + } + else + { + char *mem = scm_gc_malloc (len+1, "string"); + mem[len] = '\0'; + return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) mem, + (scm_t_bits) len, (scm_t_bits) 0); + } +} + +SCM +scm_i_stringbuf_mark (SCM buf) +{ + return SCM_BOOL_F; +} + +void +scm_i_stringbuf_free (SCM buf) +{ + if (!STRINGBUF_INLINE (buf)) + scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf), + STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string"); +} + +SCM_MUTEX (stringbuf_write_mutex); + +/* Copy-on-write strings. + */ + +#define STRING_TAG scm_tc7_string + +#define STRING_STRINGBUF(str) (SCM_CELL_OBJECT_1(str)) +#define STRING_START(str) ((size_t)SCM_CELL_WORD_2(str)) +#define STRING_LENGTH(str) ((size_t)SCM_CELL_WORD_3(str)) + +#define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf)) +#define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start)) + +#define IS_STRING(str) (SCM_NIMP(str) && SCM_TYP7(str) == STRING_TAG) + +SCM +scm_i_make_string (size_t len, char **charsp) +{ + SCM buf = make_stringbuf (len); + SCM res; + if (charsp) + *charsp = STRINGBUF_CHARS (buf); + res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf), + (scm_t_bits)0, (scm_t_bits) len); + return res; +} + +static void +validate_substring_args (SCM str, size_t start, size_t end) +{ + if (!IS_STRING (str)) + scm_wrong_type_arg_msg (NULL, 0, str, "string"); + if (start > STRING_LENGTH (str)) + scm_out_of_range (NULL, scm_from_size_t (start)); + if (end > STRING_LENGTH (str) || end < start) + scm_out_of_range (NULL, scm_from_size_t (end)); +} + +SCM +scm_i_substring (SCM str, size_t start, size_t end) +{ + SCM buf = STRING_STRINGBUF (str); + scm_i_plugin_mutex_lock (&stringbuf_write_mutex); + SET_STRINGBUF_SHARED (buf); + scm_i_plugin_mutex_unlock (&stringbuf_write_mutex); + return scm_double_cell (STRING_TAG, SCM_UNPACK(buf), + (scm_t_bits)start, (scm_t_bits) end - start); +} + +SCM +scm_i_substring_copy (SCM str, size_t start, size_t end) +{ + size_t len = end - start; + SCM buf = STRING_STRINGBUF (str); + SCM my_buf = make_stringbuf (len); + memcpy (STRINGBUF_CHARS (my_buf), STRINGBUF_CHARS (buf) + start, len); + scm_remember_upto_here_1 (buf); + return scm_double_cell (STRING_TAG, SCM_UNPACK(my_buf), + (scm_t_bits)0, (scm_t_bits) len); +} + +SCM +scm_c_substring (SCM str, size_t start, size_t end) +{ + validate_substring_args (str, start, end); + return scm_i_substring (str, start, end); +} + +SCM +scm_c_substring_copy (SCM str, size_t start, size_t end) +{ + validate_substring_args (str, start, end); + return scm_i_substring_copy (str, start, end); +} + +/* Mutation-sharing substrings + */ + +#define SH_STRING_TAG (scm_tc7_string + 0x100) + +#define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh)) +/* START and LENGTH as for STRINGs. */ + +#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG) + +SCM +scm_i_substring_shared (SCM str, size_t start, size_t end) +{ + if (start == 0 && end == STRING_LENGTH (str)) + return str; + else + { + SCM res = scm_double_cell (SH_STRING_TAG, SCM_UNPACK(str), + (scm_t_bits)start, (scm_t_bits) end - start); + return res; + } +} + +SCM +scm_c_substring_shared (SCM str, size_t start, size_t end) +{ + validate_substring_args (str, start, end); + return scm_i_substring_shared (str, start, end); +} + +SCM +scm_i_string_mark (SCM str) +{ + if (IS_SH_STRING (str)) + return SH_STRING_STRING (str); + else + return STRING_STRINGBUF (str); +} + +void +scm_i_string_free (SCM str) +{ +} + +/* Internal accessors + */ + +size_t +scm_i_string_length (SCM str) +{ + return STRING_LENGTH (str); +} + +const char * +scm_i_string_chars (SCM str) +{ + SCM buf; + size_t start = STRING_START(str); + if (IS_SH_STRING (str)) + { + str = SH_STRING_STRING (str); + start += STRING_START (str); + } + buf = STRING_STRINGBUF (str); + return STRINGBUF_CHARS (buf) + start; +} + +char * +scm_i_string_writable_chars (SCM str) +{ + SCM buf; + size_t start = STRING_START(str); + if (IS_SH_STRING (str)) + { + str = SH_STRING_STRING (str); + start += STRING_START (str); + } + buf = STRING_STRINGBUF (str); + scm_i_plugin_mutex_lock (&stringbuf_write_mutex); + if (STRINGBUF_SHARED (buf)) + { + /* Clone stringbuf. For this, we put all threads to sleep. + */ + + size_t len = STRING_LENGTH (str); + SCM new_buf; + + scm_i_plugin_mutex_unlock (&stringbuf_write_mutex); + + new_buf = make_stringbuf (len); + memcpy (STRINGBUF_CHARS (new_buf), + STRINGBUF_CHARS (buf) + STRING_START (str), len); + + scm_i_thread_put_to_sleep (); + SET_STRING_STRINGBUF (str, new_buf); + start -= STRING_START (str); + SET_STRING_START (str, 0); + scm_i_thread_wake_up (); + + buf = new_buf; + + scm_i_plugin_mutex_lock (&stringbuf_write_mutex); + } + + return STRINGBUF_CHARS (buf) + start; +} + +void +scm_i_string_stop_writing (void) +{ + scm_i_plugin_mutex_unlock (&stringbuf_write_mutex); +} + +/* Symbols. + + Basic symbol creation and accessing is done here, the rest is in + symbols.[hc]. This has been done to keep stringbufs and the + internals of strings and string-like objects confined to this file. +*/ + +#define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1 + +SCM +scm_i_make_symbol (SCM name, unsigned long hash, SCM props) +{ + SCM buf; + size_t start = STRING_START (name); + size_t length = STRING_LENGTH (name); + + if (IS_SH_STRING (name)) + { + name = SH_STRING_STRING (name); + start += STRING_START (name); + } + buf = SYMBOL_STRINGBUF (name); + + if (start == 0 && length == STRINGBUF_LENGTH (buf)) + { + /* reuse buf. */ + scm_i_plugin_mutex_lock (&stringbuf_write_mutex); + SET_STRINGBUF_SHARED (buf); + scm_i_plugin_mutex_unlock (&stringbuf_write_mutex); + } + else + { + /* make new buf. */ + SCM new_buf = make_stringbuf (length); + memcpy (STRINGBUF_CHARS (new_buf), + STRINGBUF_CHARS (buf) + start, length); + buf = new_buf; + } + return scm_double_cell (scm_tc7_symbol, SCM_UNPACK (buf), + (scm_t_bits) hash, SCM_UNPACK (props)); +} + +size_t +scm_i_symbol_length (SCM sym) +{ + return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym)); +} + +const char * +scm_i_symbol_chars (SCM sym) +{ + SCM buf = SYMBOL_STRINGBUF (sym); + return STRINGBUF_CHARS (buf); +} + +SCM +scm_i_symbol_mark (SCM sym) +{ + scm_gc_mark (SYMBOL_STRINGBUF (sym)); + return SCM_CELL_OBJECT_3 (sym); +} + +void +scm_i_symbol_free (SCM sym) +{ +} + +SCM +scm_i_symbol_substring (SCM sym, size_t start, size_t end) +{ + SCM buf = SYMBOL_STRINGBUF (sym); + scm_i_plugin_mutex_lock (&stringbuf_write_mutex); + SET_STRINGBUF_SHARED (buf); + scm_i_plugin_mutex_unlock (&stringbuf_write_mutex); + return scm_double_cell (STRING_TAG, SCM_UNPACK(buf), + (scm_t_bits)start, (scm_t_bits) end - start); +} + +/* Debugging + */ + +#if SCM_DEBUG + +SCM scm_sys_string_dump (SCM); +SCM scm_sys_symbol_dump (SCM); +SCM scm_sys_stringbuf_hist (void); + +SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, + (SCM str), + "") +#define FUNC_NAME s_scm_sys_string_dump +{ + SCM_VALIDATE_STRING (1, str); + fprintf (stderr, "%p:\n", str); + fprintf (stderr, " start: %u\n", STRING_START (str)); + fprintf (stderr, " len: %u\n", STRING_LENGTH (str)); + if (IS_SH_STRING (str)) + { + fprintf (stderr, " string: %p\n", SH_STRING_STRING (str)); + fprintf (stderr, "\n"); + scm_sys_string_dump (SH_STRING_STRING (str)); + } + else + { + SCM buf = STRING_STRINGBUF (str); + fprintf (stderr, " buf: %p\n", buf); + fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf)); + fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf)); + fprintf (stderr, " flags: %x\n", (SCM_CELL_WORD_0 (buf) & 0x300)); + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, + (SCM sym), + "") +#define FUNC_NAME s_scm_sys_symbol_dump +{ + SCM_VALIDATE_SYMBOL (1, sym); + fprintf (stderr, "%p:\n", sym); + fprintf (stderr, " hash: %lu\n", scm_i_symbol_hash (sym)); + { + SCM buf = SYMBOL_STRINGBUF (sym); + fprintf (stderr, " buf: %p\n", buf); + fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf)); + fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf)); + fprintf (stderr, " shared: %u\n", STRINGBUF_SHARED (buf)); + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0, + (void), + "") +#define FUNC_NAME s_scm_sys_string_dump +{ + int i; + for (i = 0; i < 1000; i++) + if (lenhist[i]) + fprintf (stderr, " %3d: %u\n", i, lenhist[i]); + fprintf (stderr, ">999: %u\n", lenhist[1000]); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +#endif + + + SCM_DEFINE (scm_string_p, "string?", 1, 0, 0, (SCM obj), "Return @code{#t} if @var{obj} is a string, else @code{#f}.") #define FUNC_NAME s_scm_string_p { - return scm_from_bool (SCM_I_STRINGP (obj)); + return scm_from_bool (IS_STRING (obj)); } #undef FUNC_NAME @@ -53,126 +496,35 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, #define FUNC_NAME s_scm_string { SCM result; + size_t len; + char *data; { long i = scm_ilength (chrs); SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME); - result = scm_allocate_string (i); + len = i; } - { - unsigned char *data = SCM_I_STRING_UCHARS (result); + result = scm_i_make_string (len, &data); + while (len > 0 && SCM_CONSP (chrs)) + { + SCM elt = SCM_CAR (chrs); - while (!SCM_NULLP (chrs)) - { - SCM elt = SCM_CAR (chrs); + SCM_VALIDATE_CHAR (SCM_ARGn, elt); + *data++ = SCM_CHAR (elt); + chrs = SCM_CDR (chrs); + len--; + } + if (len > 0) + scm_misc_error (NULL, "list changed while constructing string", SCM_EOL); + if (!SCM_NULLP (chrs)) + scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list"); - SCM_VALIDATE_CHAR (SCM_ARGn, elt); - *data++ = SCM_CHAR (elt); - chrs = SCM_CDR (chrs); - } - } return result; } #undef FUNC_NAME - -/* converts C scm_array of strings to SCM scm_list of strings. */ -/* If argc < 0, a null terminated scm_array is assumed. */ -SCM -scm_makfromstrs (int argc, char **argv) -{ - int i = argc; - SCM lst = SCM_EOL; - if (0 > i) - for (i = 0; argv[i]; i++); - while (i--) - lst = scm_cons (scm_mem2string (argv[i], strlen (argv[i])), lst); - return lst; -} - - -/* This function must only be applied to memory obtained via malloc, - since the GC is going to apply `free' to it when the string is - dropped. - - Also, s[len] must be `\0', since we promise that strings are - null-terminated. Perhaps we could handle non-null-terminated - strings by claiming they're shared substrings of a string we just - made up. */ -SCM -scm_take_str (char *s, size_t len) -#define FUNC_NAME "scm_take_str" -{ - SCM answer; - - SCM_ASSERT_RANGE (2, scm_from_ulong (len), len <= SCM_STRING_MAX_LENGTH); - - answer = scm_cell (SCM_I_MAKE_STRING_TAG (len), (scm_t_bits) s); - scm_gc_register_collectable_memory (s, len+1, "string"); - - return answer; -} -#undef FUNC_NAME - - -/* `s' must be a malloc'd string. See scm_take_str. */ -SCM -scm_take0str (char *s) -{ - return scm_take_locale_string (s); -} - - -SCM -scm_mem2string (const char *src, size_t len) -{ - return scm_from_locale_stringn (src, len); -} - - -SCM -scm_str2string (const char *src) -{ - return scm_from_locale_string (src); -} - - -SCM -scm_makfrom0str (const char *src) -{ - if (!src) return SCM_BOOL_F; - return scm_from_locale_string (src); -} - - -SCM -scm_makfrom0str_opt (const char *src) -{ - return scm_makfrom0str (src); -} - - -SCM -scm_allocate_string (size_t len) -#define FUNC_NAME "scm_allocate_string" -{ - char *mem; - SCM s; - - SCM_ASSERT_RANGE (1, scm_from_size_t (len), len <= SCM_STRING_MAX_LENGTH); - - mem = (char *) scm_gc_malloc (len + 1, "string"); - mem[len] = 0; - - s = scm_cell (SCM_I_MAKE_STRING_TAG (len), (scm_t_bits) mem); - - return s; -} -#undef FUNC_NAME - - SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, (SCM k, SCM chr), "Return a newly allocated string of\n" @@ -181,34 +533,45 @@ SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, "of the @var{string} are unspecified.") #define FUNC_NAME s_scm_make_string { - size_t i = scm_to_unsigned_integer (k, 0, SCM_STRING_MAX_LENGTH); - SCM res = scm_allocate_string (i); + return scm_c_make_string (scm_to_size_t (k), chr); +} +#undef FUNC_NAME + +SCM +scm_c_make_string (size_t len, SCM chr) +#define FUNC_NAME NULL +{ + char *dst; + SCM res = scm_i_make_string (len, &dst); if (!SCM_UNBNDP (chr)) { - unsigned char *dst; - - SCM_VALIDATE_CHAR (2, chr); - - dst = SCM_I_STRING_UCHARS (res); - memset (dst, SCM_CHAR (chr), i); + SCM_VALIDATE_CHAR (0, chr); + memset (dst, SCM_CHAR (chr), len); } return res; } #undef FUNC_NAME - SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0, (SCM string), "Return the number of characters in @var{string}.") #define FUNC_NAME s_scm_string_length { SCM_VALIDATE_STRING (1, string); - return scm_from_size_t (SCM_I_STRING_LENGTH (string)); + return scm_from_size_t (STRING_LENGTH (string)); } #undef FUNC_NAME +size_t +scm_c_string_length (SCM string) +{ + if (!IS_STRING (string)) + scm_wrong_type_arg_msg (NULL, 0, string, "string"); + return STRING_LENGTH (string); +} + SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, (SCM str, SCM k), "Return character @var{k} of @var{str} using zero-origin\n" @@ -218,11 +581,18 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, unsigned long idx; SCM_VALIDATE_STRING (1, str); - idx = scm_to_unsigned_integer (k, 0, SCM_I_STRING_LENGTH(str)-1); - return SCM_MAKE_CHAR (SCM_I_STRING_UCHARS (str)[idx]); + idx = scm_to_unsigned_integer (k, 0, scm_i_string_length (str)-1); + return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]); } #undef FUNC_NAME +SCM +scm_c_string_ref (SCM str, size_t p) +{ + if (p >= scm_i_string_length (str)) + scm_out_of_range (NULL, scm_from_size_t (p)); + return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]); +} SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, (SCM str, SCM k, SCM chr), @@ -234,13 +604,28 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, unsigned long idx; SCM_VALIDATE_STRING (1, str); - idx = scm_to_unsigned_integer (k, 0, SCM_I_STRING_LENGTH(str)-1); + idx = scm_to_unsigned_integer (k, 0, scm_i_string_length(str)-1); SCM_VALIDATE_CHAR (3, chr); - SCM_I_STRING_UCHARS (str)[idx] = SCM_CHAR (chr); + { + char *dst = scm_i_string_writable_chars (str); + dst[idx] = SCM_CHAR (chr); + scm_i_string_stop_writing (); + } return SCM_UNSPECIFIED; } #undef FUNC_NAME +void +scm_c_string_set_x (SCM str, size_t p, SCM chr) +{ + if (p >= scm_i_string_length (str)) + scm_out_of_range (NULL, scm_from_size_t (p)); + { + char *dst = scm_i_string_writable_chars (str); + dst[p] = SCM_CHAR (chr); + scm_i_string_stop_writing (); + } +} SCM_DEFINE (scm_substring, "substring", 2, 1, 0, (SCM str, SCM start, SCM end), @@ -252,24 +637,64 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, "0 <= @var{start} <= @var{end} <= (string-length @var{str}).") #define FUNC_NAME s_scm_substring { - unsigned long int from; - unsigned long int to; - SCM substr; + size_t len, from, to; SCM_VALIDATE_STRING (1, str); - from = scm_to_unsigned_integer (start, 0, SCM_I_STRING_LENGTH(str)); + len = scm_i_string_length (str); + from = scm_to_unsigned_integer (start, 0, len); if (SCM_UNBNDP (end)) - to = SCM_I_STRING_LENGTH(str); + to = len; else - to = scm_to_unsigned_integer (end, from, SCM_I_STRING_LENGTH(str)); - substr = scm_allocate_string (to - from); - memcpy (SCM_I_STRING_CHARS (substr), SCM_I_STRING_CHARS (str) + from, - to - from); - scm_remember_upto_here_1 (str); - return substr; + to = scm_to_unsigned_integer (end, from, len); + return scm_i_substring (str, from, to); } #undef FUNC_NAME +SCM_DEFINE (scm_substring_copy, "substring/copy", 2, 1, 0, + (SCM str, SCM start, SCM end), + "Return a newly allocated string formed from the characters\n" + "of @var{str} beginning with index @var{start} (inclusive) and\n" + "ending with index @var{end} (exclusive).\n" + "@var{str} must be a string, @var{start} and @var{end} must be\n" + "exact integers satisfying:\n\n" + "0 <= @var{start} <= @var{end} <= (string-length @var{str}).") +#define FUNC_NAME s_scm_substring_copy +{ + size_t len, from, to; + + SCM_VALIDATE_STRING (1, str); + len = scm_i_string_length (str); + from = scm_to_unsigned_integer (start, 0, len); + if (SCM_UNBNDP (end)) + to = len; + else + to = scm_to_unsigned_integer (end, from, len); + return scm_i_substring_copy (str, from, to); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0, + (SCM str, SCM start, SCM end), + "Return string that indirectly refers to the characters\n" + "of @var{str} beginning with index @var{start} (inclusive) and\n" + "ending with index @var{end} (exclusive).\n" + "@var{str} must be a string, @var{start} and @var{end} must be\n" + "exact integers satisfying:\n\n" + "0 <= @var{start} <= @var{end} <= (string-length @var{str}).") +#define FUNC_NAME s_scm_substring_shared +{ + size_t len, from, to; + + SCM_VALIDATE_STRING (1, str); + len = scm_i_string_length (str); + from = scm_to_unsigned_integer (start, 0, len); + if (SCM_UNBNDP (end)) + to = len; + else + to = scm_to_unsigned_integer (end, from, len); + return scm_i_substring_shared (str, from, to); +} +#undef FUNC_NAME SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, (SCM args), @@ -287,15 +712,16 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, { s = SCM_CAR (l); SCM_VALIDATE_STRING (SCM_ARGn, s); - i += SCM_I_STRING_LENGTH (s); + i += scm_i_string_length (s); } - res = scm_allocate_string (i); - data = SCM_I_STRING_CHARS (res); + res = scm_i_make_string (i, &data); for (l = args; !SCM_NULLP (l); l = SCM_CDR (l)) { s = SCM_CAR (l); - memcpy (data, SCM_I_STRING_CHARS (s), SCM_I_STRING_LENGTH (s)); - data += SCM_I_STRING_LENGTH (s); + SCM_VALIDATE_STRING (SCM_ARGn, s); + size_t len = scm_i_string_length (s); + memcpy (data, scm_i_string_chars (s), len); + data += len; scm_remember_upto_here_1 (s); } return res; @@ -305,7 +731,7 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, int scm_is_string (SCM obj) { - return SCM_I_STRINGP (obj); + return IS_STRING (obj); } SCM @@ -316,8 +742,7 @@ scm_from_locale_stringn (const char *str, size_t len) if (len == (size_t)-1) len = strlen (str); - res = scm_allocate_string (len); - dst = SCM_I_STRING_CHARS (res); + res = scm_i_make_string (len, &dst); memcpy (dst, str, len); return res; } @@ -348,17 +773,14 @@ SCM scm_take_locale_string (char *str) { size_t len = strlen (str); - SCM res; + SCM buf, res; - if (len > SCM_STRING_MAX_LENGTH) - { - free (str); - scm_out_of_range (NULL, scm_from_size_t (len)); - } - - res = scm_cell (SCM_I_MAKE_STRING_TAG (len), (scm_t_bits) str); + buf = scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str, + (scm_t_bits) len, (scm_t_bits) 0); + res = scm_double_cell (STRING_TAG, + SCM_UNPACK (buf), + (scm_t_bits) 0, (scm_t_bits) len); scm_gc_register_collectable_memory (str, len+1, "string"); - return res; } @@ -368,11 +790,11 @@ scm_to_locale_stringn (SCM str, size_t *lenp) char *res; size_t len; - if (!SCM_I_STRINGP (str)) + if (!scm_is_string (str)) scm_wrong_type_arg_msg (NULL, 0, str, "string"); - len = SCM_I_STRING_LENGTH (str); + len = scm_i_string_length (str); res = scm_malloc (len + ((lenp==NULL)? 1 : 0)); - memcpy (res, SCM_I_STRING_CHARS (str), len); + memcpy (res, scm_i_string_chars (str), len); if (lenp == NULL) { res[len] = '\0'; @@ -402,14 +824,28 @@ scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len) { size_t len; - if (!SCM_I_STRINGP (str)) + if (!scm_is_string (str)) scm_wrong_type_arg_msg (NULL, 0, str, "string"); - len = SCM_I_STRING_LENGTH (str); - memcpy (buf, SCM_I_STRING_CHARS (str), (len > max_len)? max_len : len); + len = scm_i_string_length (str); + memcpy (buf, scm_i_string_chars (str), (len > max_len)? max_len : len); scm_remember_upto_here_1 (str); return len; } +/* converts C scm_array of strings to SCM scm_list of strings. */ +/* If argc < 0, a null terminated scm_array is assumed. */ +SCM +scm_makfromstrs (int argc, char **argv) +{ + int i = argc; + SCM lst = SCM_EOL; + if (0 > i) + for (i = 0; argv[i]; i++); + while (i--) + lst = scm_cons (scm_from_locale_string (argv[i]), lst); + return lst; +} + /* Return a newly allocated array of char pointers to each of the strings in args, with a terminating NULL pointer. */ @@ -468,10 +904,50 @@ scm_i_get_substring_spec (size_t len, *cend = scm_to_unsigned_integer (end, *cstart, len); } +#if SCM_ENABLE_DEPRECATED + +int +SCM_STRINGP (SCM str) +{ + scm_c_issue_deprecation_warning + ("SCM_STRINGP is deprecated. Use scm_is_string instead."); + + /* We don't accept shared substrings here since they are not + null-terminated. + */ + + return IS_STRING (str) && !IS_SH_STRING (str); +} + +char * +SCM_STRING_CHARS (SCM str) +{ + char *chars; + + scm_c_issue_deprecation_warning + ("SCM_STRING_CHARS is deprecated. See the manual for alternatives."); + + /* The following is wrong, of course... + */ + chars = scm_i_string_writable_chars (str); + scm_i_string_stop_writing (); + return chars; +} + +size_t +SCM_STRING_LENGTH (SCM str) +{ + scm_c_issue_deprecation_warning + ("SCM_STRING_LENGTH is deprecated. Use scm_c_string_length instead."); + return scm_c_string_length (str); +} + +#endif + void scm_init_strings () { - scm_nullstr = scm_allocate_string (0); + scm_nullstr = scm_i_make_string (0, NULL); #include "libguile/strings.x" } diff --git a/libguile/strings.h b/libguile/strings.h index 942001e07..9491262e8 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -3,7 +3,7 @@ #ifndef SCM_STRINGS_H #define SCM_STRINGS_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -26,20 +26,56 @@ -#define SCM_STRING_MAX_LENGTH ((SCM_T_BITS_MAX-255)/256) +/* String representation. -#define SCM_I_MAKE_STRING_TAG(l) ((((scm_t_bits) (l)) << 8) + scm_tc7_string) -#define SCM_I_STRINGP(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_string)) -#define SCM_I_STRING_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) -#define SCM_I_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) -#define SCM_I_STRING_LENGTH(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 8)) + A string is a piece of a stringbuf. A stringbuf can be used by + more than one string. When a string is written to and the + stringbuf of that string is used by more than one string, a new + stringbuf is created. That is, strings are copy-on-write. This + behavior can be used to make the substring operation quite + efficient. -#define SCM_STRINGP SCM_I_STRINGP -#define SCM_STRING_CHARS SCM_I_STRING_CHARS -#define SCM_STRING_UCHARS SCM_I_STRING_UCHARS -#define SCM_STRING_LENGTH SCM_I_STRING_LENGTH + The implementation is tuned so that mutating a string is costly, + but just reading it is cheap and lock-free. - + There are also mutation-sharing strings. They refer to a part of + an ordinary string. Writing to a mutation-sharing string just + writes to the ordinary string. + + + Internal, low level interface to the character arrays + + - Use scm_i_string_chars to get a pointer to the byte array of a + string for reading. Use scm_i_string_length to get the number of + bytes in that array. The array is not null-terminated. + + - The array is valid as long as the corresponding SCM object is + protected but only until the next SCM_TICK. During such a 'safe + point', strings might change their representation. + + - Use scm_i_string_writable_chars to get the same pointer as with + scm_i_string_chars, but for reading and writing. This is a + potentially costly operation since it implements the + copy-on-write behavior. When done with the writing, call + scm_i_string_stop_writing. You must do this before the next + SCM_TICK. (This means, before calling almost any other scm_ + function and you can't allow throws, of course.) + + - New strings can be created with scm_i_make_string. This gives + access to a writable pointer that remains valid as long as nobody + else makes a copy-on-write substring of the string. Do not call + scm_i_string_stop_writing for this pointer. + + Legacy interface + + - SCM_STRINGP returns false for sh-strings. + + - SCM_STRING_CHARS uses scm_i_string_writable_chars and immediately + calls scm_i_stop_writing, hoping for the best. SCM_STRING_LENGTH + is the same as scm_i_string_length. SCM_STRINGP will only return + true for strings that are null-terminated when accessed with + SCM_STRING_CHARS. +*/ SCM_API SCM scm_string_p (SCM x); SCM_API SCM scm_string (SCM chrs); @@ -48,16 +84,17 @@ SCM_API SCM scm_string_length (SCM str); SCM_API SCM scm_string_ref (SCM str, SCM k); SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr); SCM_API SCM scm_substring (SCM str, SCM start, SCM end); +SCM_API SCM scm_substring_shared (SCM str, SCM start, SCM end); +SCM_API SCM scm_substring_copy (SCM str, SCM start, SCM end); SCM_API SCM scm_string_append (SCM args); -SCM_API SCM scm_makfromstrs (int argc, char **argv); -SCM_API SCM scm_take_str (char *s, size_t len); -SCM_API SCM scm_take0str (char *s); -SCM_API SCM scm_mem2string (const char *src, size_t len); -SCM_API SCM scm_str2string (const char *src); -SCM_API SCM scm_makfrom0str (const char *src); -SCM_API SCM scm_makfrom0str_opt (const char *src); -SCM_API SCM scm_allocate_string (size_t len); +SCM_API SCM scm_c_make_string (size_t len, SCM chr); +SCM_API size_t scm_c_string_length (SCM str); +SCM_API SCM scm_c_string_ref (SCM str, size_t pos); +SCM_API void scm_c_string_set_x (SCM str, size_t pos, SCM chr); +SCM_API SCM scm_c_substring (SCM str, size_t start, size_t end); +SCM_API SCM scm_c_substring_shared (SCM str, size_t start, size_t end); +SCM_API SCM scm_c_substring_copy (SCM str, size_t start, size_t end); SCM_API int scm_is_string (SCM x); SCM_API SCM scm_from_locale_string (const char *str); @@ -68,6 +105,35 @@ SCM_API char *scm_to_locale_string (SCM str); SCM_API char *scm_to_locale_stringn (SCM str, size_t *lenp); SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len); +SCM_API SCM scm_makfromstrs (int argc, char **argv); + +/* internal accessor functions. Arguments must be valid. */ + +SCM_API SCM scm_i_make_string (size_t len, char **datap); +SCM_API SCM scm_i_substring (SCM str, size_t start, size_t end); +SCM_API SCM scm_i_substring_shared (SCM str, size_t start, size_t end); +SCM_API SCM scm_i_substring_copy (SCM str, size_t start, size_t end); +SCM_API size_t scm_i_string_length (SCM str); +SCM_API const char *scm_i_string_chars (SCM str); +SCM_API char *scm_i_string_writable_chars (SCM str); +SCM_API void scm_i_string_stop_writing (void); + +/* internal functions related to symbols. */ + +SCM_API SCM scm_i_make_symbol (SCM name, unsigned long hash, SCM props); +SCM_API const char *scm_i_symbol_chars (SCM sym); +SCM_API size_t scm_i_symbol_length (SCM sym); +SCM_API SCM scm_i_symbol_substring (SCM sym, size_t start, size_t end); + +/* internal GC functions. */ + +SCM_API SCM scm_i_string_mark (SCM str); +SCM_API SCM scm_i_stringbuf_mark (SCM buf); +SCM_API SCM scm_i_symbol_mark (SCM buf); +SCM_API void scm_i_string_free (SCM str); +SCM_API void scm_i_stringbuf_free (SCM buf); +SCM_API void scm_i_symbol_free (SCM sym); + /* internal utility functions. */ SCM_API char **scm_i_allocate_string_pointers (SCM list); @@ -76,6 +142,17 @@ SCM_API void scm_i_get_substring_spec (size_t len, SCM start, size_t *cstart, SCM end, size_t *cend); +/* deprecated stuff */ + +#if SCM_ENABLE_DEPRECATED + +SCM_API int SCM_STRINGP (SCM obj); +SCM_API char *SCM_STRING_CHARS (SCM str); +SCM_API size_t SCM_STRING_LENGTH (SCM str); +#define SCM_STRING_UCHARS ((unsigned char *)SCM_STRING_CHARS (str)) + +#endif + SCM_API void scm_init_strings (void); #endif /* SCM_STRINGS_H */ diff --git a/libguile/symbols.c b/libguile/symbols.c index dc413c369..657723cc6 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -69,7 +69,7 @@ SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0, * without first creating an SCM string object. (This would have * been necessary if we had used the hashtable API in hashtab.h.) * - * 2. We can use the raw hash value stored in SCM_SYMBOL_HASH (sym) + * 2. We can use the raw hash value stored in scm_i_symbol_hash (sym) * to speed up lookup. * * Both optimizations might be possible without breaking the @@ -79,12 +79,15 @@ SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0, unsigned long scm_i_hash_symbol (SCM obj, unsigned long n, void *closure) { - return SCM_SYMBOL_HASH (obj) % n; + return scm_i_symbol_hash (obj) % n; } -SCM -scm_mem2symbol (const char *name, size_t len) +static SCM +scm_i_mem2symbol (SCM str) { + const char *name = scm_i_string_chars (str); + size_t len = scm_i_string_length (str); + size_t raw_hash = scm_string_hash ((const unsigned char *) name, len) / 2; size_t hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols); @@ -98,10 +101,10 @@ scm_mem2symbol (const char *name, size_t len) l = SCM_CDR (l)) { SCM sym = SCM_CAAR (l); - if (SCM_SYMBOL_HASH (sym) == raw_hash - && SCM_SYMBOL_LENGTH (sym) == len) + if (scm_i_symbol_hash (sym) == raw_hash + && scm_i_symbol_length (sym) == len) { - char *chrs = SCM_SYMBOL_CHARS (sym); + const char *chrs = scm_i_symbol_chars (sym); size_t i = len; while (i != 0) @@ -120,11 +123,8 @@ scm_mem2symbol (const char *name, size_t len) { /* The symbol was not found - create it. */ - SCM symbol = scm_double_cell (SCM_MAKE_SYMBOL_TAG (len), - (scm_t_bits) scm_gc_strndup (name, len, - "symbol"), - raw_hash, - SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL))); + SCM symbol = scm_i_make_symbol (str, raw_hash, + scm_cons (SCM_BOOL_F, SCM_EOL)); SCM slot = SCM_HASHTABLE_BUCKETS (symbols) [hash]; SCM cell = scm_cons (symbol, SCM_UNDEFINED); @@ -137,23 +137,17 @@ scm_mem2symbol (const char *name, size_t len) } } -SCM -scm_mem2uninterned_symbol (const char *name, size_t len) +static SCM +scm_i_mem2uninterned_symbol (SCM str) { + const char *name = scm_i_string_chars (str); + size_t len = scm_i_string_length (str); + size_t raw_hash = (scm_string_hash ((const unsigned char *) name, len)/2 + SCM_T_BITS_MAX/2 + 1); - return scm_double_cell (SCM_MAKE_SYMBOL_TAG (len), - (scm_t_bits) scm_gc_strndup (name, len, - "symbol"), - raw_hash, - SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL))); -} - -SCM -scm_str2symbol (const char *str) -{ - return scm_mem2symbol (str, strlen (str)); + return scm_i_make_symbol (str, raw_hash, + scm_cons (SCM_BOOL_F, SCM_EOL)); } SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, @@ -162,7 +156,7 @@ SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_symbol_p { - return scm_from_bool (SCM_SYMBOLP (obj)); + return scm_from_bool (scm_is_symbol (obj)); } #undef FUNC_NAME @@ -173,7 +167,7 @@ SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 1, 0, 0, #define FUNC_NAME s_scm_symbol_interned_p { SCM_VALIDATE_SYMBOL (1, symbol); - return scm_from_bool (SCM_SYMBOL_INTERNED_P (symbol)); + return scm_from_bool (scm_i_symbol_is_interned (symbol)); } #undef FUNC_NAME @@ -184,12 +178,8 @@ SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0, "calls to @code{string->symbol} will not return it.") #define FUNC_NAME s_scm_make_symbol { - SCM sym; SCM_VALIDATE_STRING (1, name); - sym = scm_mem2uninterned_symbol (SCM_I_STRING_CHARS (name), - SCM_I_STRING_LENGTH (name)); - scm_remember_upto_here_1 (name); - return sym; + return scm_i_mem2uninterned_symbol (name); } #undef FUNC_NAME @@ -220,11 +210,8 @@ SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_symbol_to_string { - SCM str; SCM_VALIDATE_SYMBOL (1, s); - str = scm_mem2string (SCM_SYMBOL_CHARS (s), SCM_SYMBOL_LENGTH (s)); - scm_remember_upto_here_1 (s); - return str; + return scm_i_symbol_substring (s, 0, scm_i_symbol_length (s)); } #undef FUNC_NAME @@ -253,12 +240,8 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_string_to_symbol { - SCM sym; SCM_VALIDATE_STRING (1, string); - sym = scm_mem2symbol (SCM_I_STRING_CHARS (string), - SCM_I_STRING_LENGTH (string)); - scm_remember_upto_here_1 (string); - return sym; + return scm_i_mem2symbol (string); } #undef FUNC_NAME @@ -274,39 +257,23 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, #define FUNC_NAME s_scm_gensym { static int gensym_counter = 0; + + SCM suffix, name; + int n, n_digits; + char buf[SCM_INTBUFLEN]; - char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; - char *name = buf; - size_t len; if (SCM_UNBNDP (prefix)) - { - name[0] = ' '; - name[1] = 'g'; - len = 2; - } - else - { - SCM_VALIDATE_STRING (1, prefix); - len = SCM_I_STRING_LENGTH (prefix); - if (len > MAX_PREFIX_LENGTH) - name = scm_malloc (len + SCM_INTBUFLEN); - memcpy (name, SCM_I_STRING_CHARS (prefix), len); - scm_remember_upto_here_1 (prefix); - } - { - int n, n_digits; + prefix = scm_from_locale_string (" g"); + + /* mutex in case another thread looks and incs at the exact same moment */ + scm_mutex_lock (&scm_i_misc_mutex); + n = gensym_counter++; + scm_mutex_unlock (&scm_i_misc_mutex); - /* mutex in case another thread looks and incs at the exact same moment */ - scm_mutex_lock (&scm_i_misc_mutex); - n = gensym_counter++; - scm_mutex_unlock (&scm_i_misc_mutex); - - n_digits = scm_iint2str (n, 10, &name[len]); - SCM res = scm_mem2symbol (name, len + n_digits); - if (name != buf) - free (name); - return res; - } + n_digits = scm_iint2str (n, 10, buf); + suffix = scm_from_locale_stringn (buf, n_digits); + name = scm_string_append (scm_list_2 (prefix, suffix)); + return scm_string_to_symbol (name); } #undef FUNC_NAME @@ -316,7 +283,7 @@ SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, #define FUNC_NAME s_scm_symbol_hash { SCM_VALIDATE_SYMBOL (1, symbol); - return scm_from_ulong (SCM_SYMBOL_HASH (symbol)); + return scm_from_ulong (scm_i_symbol_hash (symbol)); } #undef FUNC_NAME @@ -326,7 +293,7 @@ SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0, #define FUNC_NAME s_scm_symbol_fref { SCM_VALIDATE_SYMBOL (1, s); - return SCM_SYMBOL_FUNC (s); + return SCM_CAR (SCM_CELL_OBJECT_3 (s)); } #undef FUNC_NAME @@ -337,7 +304,7 @@ SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0, #define FUNC_NAME s_scm_symbol_pref { SCM_VALIDATE_SYMBOL (1, s); - return SCM_SYMBOL_PROPS (s); + return SCM_CDR (SCM_CELL_OBJECT_3 (s)); } #undef FUNC_NAME @@ -348,7 +315,7 @@ SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0, #define FUNC_NAME s_scm_symbol_fset_x { SCM_VALIDATE_SYMBOL (1, s); - SCM_SET_SYMBOL_FUNC (s, val); + SCM_SETCAR (SCM_CELL_OBJECT_3 (s), val); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -360,56 +327,22 @@ SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, #define FUNC_NAME s_scm_symbol_pset_x { SCM_VALIDATE_SYMBOL (1, s); - SCM_DEFER_INTS; - SCM_SET_SYMBOL_PROPS (s, val); - SCM_ALLOW_INTS; + SCM_SETCDR (SCM_CELL_OBJECT_3 (s), val); return SCM_UNSPECIFIED; } #undef FUNC_NAME - -/* Converts the given Scheme symbol OBJ into a C string, containing a copy - of OBJ's content with a trailing null byte. If LENP is non-NULL, set - *LENP to the string's length. - - When STR is non-NULL it receives the copy and is returned by the function, - otherwise new memory is allocated and the caller is responsible for - freeing it via free(). If out of memory, NULL is returned. - - Note that Scheme symbols may contain arbitrary data, including null - characters. This means that null termination is not a reliable way to - determine the length of the returned value. However, the function always - copies the complete contents of OBJ, and sets *LENP to the length of the - scheme symbol (if LENP is non-null). */ -#define FUNC_NAME "scm_c_symbol2str" -char * -scm_c_symbol2str (SCM obj, char *str, size_t *lenp) +SCM +scm_from_locale_symbol (const char *sym) { - size_t len; - - SCM_ASSERT (SCM_SYMBOLP (obj), obj, SCM_ARG1, FUNC_NAME); - len = SCM_SYMBOL_LENGTH (obj); - - if (str == NULL) - { - /* FIXME: Should we use exported wrappers for malloc (and free), which - * allow windows DLLs to call the correct freeing function? */ - str = (char *) scm_malloc ((len + 1) * sizeof (char)); - if (str == NULL) - return NULL; - } - - memcpy (str, SCM_SYMBOL_CHARS (obj), len); - scm_remember_upto_here_1 (obj); - str[len] = '\0'; - - if (lenp != NULL) - *lenp = len; - - return str; + return scm_string_to_symbol (scm_from_locale_string (sym)); } -#undef FUNC_NAME +SCM +scm_from_locale_symboln (const char *sym, size_t len) +{ + return scm_string_to_symbol (scm_from_locale_stringn (sym, len)); +} void scm_symbols_prehistory () diff --git a/libguile/symbols.h b/libguile/symbols.h index 59d792ff6..a96d786e9 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -3,7 +3,7 @@ #ifndef SCM_SYMBOLS_H #define SCM_SYMBOLS_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -25,39 +25,16 @@ #include "libguile/__scm.h" -/* SCM_SYMBOL_LENGTH(SYM) is the length of SYM's name in characters, and - * SCM_SYMBOL_CHARS(SYM) is the address of the first character of SYM's name. - * - * SCM_SYMBOL_HASH is a hash value for the symbol. It is also used to - * encode whether the symbol is interned or not. See - * SCM_SYMBOL_INTERNED_P. - */ - -#define SCM_SYMBOLP(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_symbol)) -#define SCM_SYMBOL_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8) -#define SCM_MAKE_SYMBOL_TAG(l) (((l) << 8) + scm_tc7_symbol) -#define SCM_SET_SYMBOL_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), SCM_MAKE_SYMBOL_TAG(l))) -#define SCM_SYMBOL_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) -#define SCM_SET_SYMBOL_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) -#define SCM_SYMBOL_HASH(X) ((unsigned long) SCM_CELL_WORD_2 (X)) -#define SCM_SYMBOL_INTERNED_P(X) (SCM_SYMBOL_HASH(X) <= (SCM_T_BITS_MAX/2)) - -#define SCM_PROP_SLOTS(X) (SCM_CELL_OBJECT_3 (X)) -#define SCM_SET_PROP_SLOTS(X, v) (SCM_SET_CELL_OBJECT_3 ((X), (v))) -#define SCM_SYMBOL_FUNC(X) (SCM_CAR (SCM_CELL_OBJECT_3 (X))) -#define SCM_SET_SYMBOL_FUNC(X, v) (SCM_SETCAR (SCM_CELL_OBJECT_3 (X), (v))) -#define SCM_SYMBOL_PROPS(X) (SCM_CDR (SCM_CELL_OBJECT_3 (X))) -#define SCM_SET_SYMBOL_PROPS(X, v) (SCM_SETCDR (SCM_CELL_OBJECT_3 (X), (v))) +#define scm_is_symbol(x) (!SCM_IMP (x) \ + && (SCM_TYP7 (x) == scm_tc7_symbol)) +#define scm_i_symbol_hash(x) ((unsigned long) SCM_CELL_WORD_2 (x)) +#define scm_i_symbol_is_interned(x) (scm_i_symbol_hash(x)<=(SCM_T_BITS_MAX/2)) #ifdef GUILE_DEBUG SCM_API SCM scm_sys_symbols (void); #endif -SCM_API unsigned long scm_i_hash_symbol (SCM obj, unsigned long n, void *closure); -SCM_API SCM scm_mem2symbol (const char*, size_t); -SCM_API SCM scm_mem2uninterned_symbol (const char *name, size_t len); -SCM_API SCM scm_str2symbol (const char*); SCM_API SCM scm_symbol_p (SCM x); SCM_API SCM scm_symbol_interned_p (SCM sym); @@ -73,7 +50,14 @@ SCM_API SCM scm_symbol_pset_x (SCM s, SCM val); SCM_API SCM scm_symbol_hash (SCM s); SCM_API SCM scm_gensym (SCM prefix); -SCM_API char *scm_c_symbol2str (SCM obj, char *str, size_t *lenp); +SCM_API SCM scm_from_locale_symbol (const char *str); +SCM_API SCM scm_from_locale_symboln (const char *str, size_t len); + +/* internal functions. */ + +SCM_API unsigned long scm_i_hash_symbol (SCM obj, unsigned long n, + void *closure); + SCM_API void scm_symbols_prehistory (void); SCM_API void scm_init_symbols (void); From 6087fad9c7263be996e8cb91cb300a20280048be Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:16:01 +0000 Subject: [PATCH 008/100] (gc_section_count): Removed, thread-sleeping can not be nested. (scm_i_thread_put_to_sleep): Call scm_i_leave_guile before locking admin mutex so that we can be put to sleep by other threads while blocking on that mutex. Lock all the heap mutex of all threads, including ourselves. (scm_i_thread_wake_up): Unlock all threads, including ourselves, call scm_i_enter_guile. (scm_thread_mark_stacks): Expect all threads to be suspended. --- libguile/threads.c | 99 ++++++++++++++-------------------------------- 1 file changed, 29 insertions(+), 70 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 25f06d6d4..d32156eb2 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -937,6 +937,7 @@ void scm_threads_mark_stacks (void) { volatile SCM c; + for (c = all_threads; !SCM_NULLP (c); c = SCM_CDR (c)) { scm_thread *t = SCM_THREAD_DATA (SCM_CAR (c)); @@ -945,70 +946,24 @@ scm_threads_mark_stacks (void) /* Not fully initialized yet. */ continue; } + if (t->top == NULL) { - long stack_len; -#ifdef SCM_DEBUG - if (t->thread != scm_thread_self ()) - abort (); -#endif - /* Active thread */ - /* stack_len is long rather than size_t in order to guarantee - that &stack_len is long aligned */ -#if SCM_STACK_GROWS_UP - stack_len = SCM_STACK_PTR (&t) - t->base; - - /* Protect from the C stack. This must be the first marking - * done because it provides information about what objects - * are "in-use" by the C code. "in-use" objects are those - * for which the information about length and base address must - * remain usable. This requirement is stricter than a liveness - * requirement -- in particular, it constrains the implementation - * of scm_resizuve. + /* Thread has not been suspended, which should never happen. */ - SCM_FLUSH_REGISTER_WINDOWS; - /* This assumes that all registers are saved into the jmp_buf */ - setjmp (scm_save_regs_gc_mark); - scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, - ((size_t) sizeof scm_save_regs_gc_mark - / sizeof (SCM_STACKITEM))); - - scm_mark_locations (t->base, (size_t) stack_len); -#else - stack_len = t->base - SCM_STACK_PTR (&t); - - /* Protect from the C stack. This must be the first marking - * done because it provides information about what objects - * are "in-use" by the C code. "in-use" objects are those - * for which the information about length and base address must - * remain usable. This requirement is stricter than a liveness - * requirement -- in particular, it constrains the implementation - * of scm_resizuve. - */ - SCM_FLUSH_REGISTER_WINDOWS; - /* This assumes that all registers are saved into the jmp_buf */ - setjmp (scm_save_regs_gc_mark); - scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, - ((size_t) sizeof scm_save_regs_gc_mark - / sizeof (SCM_STACKITEM))); - - scm_mark_locations (SCM_STACK_PTR (&t), stack_len); -#endif + abort (); } - else - { - /* Suspended thread */ + #if SCM_STACK_GROWS_UP - long stack_len = t->top - t->base; - scm_mark_locations (t->base, stack_len); + long stack_len = t->top - t->base; + scm_mark_locations (t->base, stack_len); #else - long stack_len = t->base - t->top; - scm_mark_locations (t->top, stack_len); + long stack_len = t->base - t->top; + scm_mark_locations (t->top, stack_len); #endif - scm_mark_locations ((SCM_STACKITEM *) t->regs, - ((size_t) sizeof(t->regs) - / sizeof (SCM_STACKITEM))); - } + scm_mark_locations ((SCM_STACKITEM *) t->regs, + ((size_t) sizeof(t->regs) + / sizeof (SCM_STACKITEM))); } } @@ -1189,25 +1144,29 @@ scm_c_thread_exited_p (SCM thread) static scm_t_cond wake_up_cond; int scm_i_thread_go_to_sleep; -static int gc_section_count = 0; static int threads_initialized_p = 0; void scm_i_thread_put_to_sleep () { - if (threads_initialized_p && !gc_section_count++) + if (threads_initialized_p) { SCM threads; + + /* We leave Guile completely before locking the + thread_admin_mutex. This ensures that other threads can put + us to sleep while we block on that mutex. + */ + scm_i_leave_guile (); scm_i_plugin_mutex_lock (&thread_admin_mutex); threads = all_threads; /* Signal all threads to go to sleep */ scm_i_thread_go_to_sleep = 1; for (; !SCM_NULLP (threads); threads = SCM_CDR (threads)) - if (SCM_CAR (threads) != cur_thread) - { - scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads)); - scm_i_plugin_mutex_lock (&t->heap_mutex); - } + { + scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads)); + scm_i_plugin_mutex_lock (&t->heap_mutex); + } scm_i_thread_go_to_sleep = 0; } } @@ -1228,18 +1187,18 @@ scm_i_thread_invalidate_freelists () void scm_i_thread_wake_up () { - if (threads_initialized_p && !--gc_section_count) + if (threads_initialized_p) { SCM threads; threads = all_threads; scm_i_plugin_cond_broadcast (&wake_up_cond); for (; !SCM_NULLP (threads); threads = SCM_CDR (threads)) - if (SCM_CAR (threads) != cur_thread) - { - scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads)); - scm_i_plugin_mutex_unlock (&t->heap_mutex); - } + { + scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads)); + scm_i_plugin_mutex_unlock (&t->heap_mutex); + } scm_i_plugin_mutex_unlock (&thread_admin_mutex); + scm_i_enter_guile (SCM_CURRENT_THREAD); } } From 468e87a786860de58fec93d65b0a4b17d4ef18a1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:16:49 +0000 Subject: [PATCH 009/100] (scm_memory_error): Do not try to throw, just abort. Throwing will not work anyway. * strings.h, strings.c: (scm_i_string_chars, scm_i_string_length, scm_i_string_writable_chars, scm_i_string_stop_writing): New, to replace SCM_I_STRING_CHARS and SCM_I_STRING_LENGTH. Updated all uses. (scm_i_make_string, scm_c_make_string): New, to replace scm_allocate_string. Updated all uses. (SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_UCHARS, SCM_STRING_LENGTH): Deprecated. (scm_allocate_string, scm_take_str, scm_take0str, scm_mem2string, scm_str2string, scm_makfrom0str, scm_makfrom0str_opt): Discouraged. Replaced all uses with scm_from_locale_string or similar, as appropriate. (scm_c_string_length, scm_c_string_ref, scm_c_string_set_x, scm_c_substring, scm_c_substring_shared, scm_c_substring_copy, scm_substring_shared, scm_substring_copy): New. * symbols.c, symbols.h (SCM_SYMBOLP, SCM_SYMBOL_FUNC, SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, SCM_SET_SYMBOL_PROPS, SCM_SYMBOL_HASH, SCM_SYMBOL_INTERNED_P, scm_mem2symbol, scm_str2symbol, scm_mem2uninterned_symbol): Discouraged. (SCM_SYMBOL_LENGTH, SCM_SYMBOL_CHARS, scm_c_symbol2str): Deprecated. (SCM_MAKE_SYMBOL_TAG, SCM_SET_SYMBOL_LENGTH, SCM_SET_SYMBOL_CHARS, SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS): Removed. (scm_is_symbol, scm_from_locale_symbol, scm_from_locale_symboln): New, to replace scm_str2symbol and scm_mem2symbol, respectively. Updated all uses. (scm_gensym): Generate only the number suffix in the buffer, just string-append the prefix. --- libguile/error.c | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/libguile/error.c b/libguile/error.c index e61004a7a..ef364b707 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -135,7 +135,7 @@ SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0, SCM_F_WIND_EXPLICITLY); scm_mutex_lock (&scm_i_misc_mutex); - ret = scm_makfrom0str (SCM_I_STRERROR (scm_to_int (err))); + ret = scm_from_locale_string (SCM_I_STRERROR (scm_to_int (err))); scm_frame_end (); return ret; @@ -215,7 +215,7 @@ scm_error_num_args_subr (const char *subr) scm_error (scm_args_number_key, NULL, "Wrong number of arguments to ~A", - scm_list_1 (scm_makfrom0str (subr)), + scm_list_1 (scm_from_locale_string (subr)), SCM_BOOL_F); } @@ -236,7 +236,7 @@ scm_wrong_type_arg (const char *subr, int pos, SCM bad_value) void scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage) { - SCM msg = scm_makfrom0str(szMessage); + SCM msg = scm_from_locale_string (szMessage); if (pos == 0) { scm_error (scm_arg_type_key, subr, "Wrong type argument (expecting ~A): ~S", @@ -256,11 +256,8 @@ SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error"); void scm_memory_error (const char *subr) { - scm_error (scm_memory_alloc_key, - subr, - "Memory allocation error", - SCM_BOOL_F, - SCM_BOOL_F); + fprintf (stderr, "FATAL: memory error in %s\n", subr); + abort (); } SCM_GLOBAL_SYMBOL (scm_misc_error_key, "misc-error"); From 3a5fb14dbcad7096d7e2f6d5daf18f6deef03c1d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:17:22 +0000 Subject: [PATCH 010/100] (scm_i_mode_bits_n): New, for counted strings. (scm_mode_bits): Use it. (scm_c_port_for_each): Blocking GC does not seem to work, allocate a vector normally and fill that instead of consing a list with a blocked GC. * strings.h, strings.c: (scm_i_string_chars, scm_i_string_length, scm_i_string_writable_chars, scm_i_string_stop_writing): New, to replace SCM_I_STRING_CHARS and SCM_I_STRING_LENGTH. Updated all uses. (scm_i_make_string, scm_c_make_string): New, to replace scm_allocate_string. Updated all uses. (SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_UCHARS, SCM_STRING_LENGTH): Deprecated. (scm_allocate_string, scm_take_str, scm_take0str, scm_mem2string, scm_str2string, scm_makfrom0str, scm_makfrom0str_opt): Discouraged. Replaced all uses with scm_from_locale_string or similar, as appropriate. (scm_c_string_length, scm_c_string_ref, scm_c_string_set_x, scm_c_substring, scm_c_substring_shared, scm_c_substring_copy, scm_substring_shared, scm_substring_copy): New. * symbols.c, symbols.h (SCM_SYMBOLP, SCM_SYMBOL_FUNC, SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, SCM_SET_SYMBOL_PROPS, SCM_SYMBOL_HASH, SCM_SYMBOL_INTERNED_P, scm_mem2symbol, scm_str2symbol, scm_mem2uninterned_symbol): Discouraged. (SCM_SYMBOL_LENGTH, SCM_SYMBOL_CHARS, scm_c_symbol2str): Deprecated. (SCM_MAKE_SYMBOL_TAG, SCM_SET_SYMBOL_LENGTH, SCM_SET_SYMBOL_CHARS, SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS): Removed. (scm_is_symbol, scm_from_locale_symbol, scm_from_locale_symboln): New, to replace scm_str2symbol and scm_mem2symbol, respectively. Updated all uses. (scm_gensym): Generate only the number suffix in the buffer, just string-append the prefix. --- libguile/ports.c | 61 ++++++++++++++++++++++++++++-------------------- 1 file changed, 36 insertions(+), 25 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index de9a19158..5fe928aa3 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -39,6 +39,7 @@ #include "libguile/mallocs.h" #include "libguile/validate.h" #include "libguile/ports.h" +#include "libguile/vectors.h" #ifdef HAVE_STRING_H #include @@ -319,6 +320,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, #define FUNC_NAME s_scm_drain_input { SCM result; + char *data; scm_t_port *pt; long count; @@ -329,9 +331,8 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, if (pt->read_buf == pt->putback_buf) count += pt->saved_read_end - pt->saved_read_pos; - result = scm_allocate_string (count); - scm_take_from_input_buffers (port, SCM_I_STRING_CHARS (result), count); - + result = scm_i_make_string (count, &data); + scm_take_from_input_buffers (port, data, count); return result; } #undef FUNC_NAME @@ -668,16 +669,22 @@ SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, * See PORT FLAGS in scm.h */ +static long +scm_i_mode_bits_n (const char *modes, size_t n) +{ + return (SCM_OPN + | (memchr (modes, 'r', n) || memchr (modes, '+', n) ? SCM_RDNG : 0) + | ( memchr (modes, 'w', n) + || memchr (modes, 'a', n) + || memchr (modes, '+', n) ? SCM_WRTNG : 0) + | (memchr (modes, '0', n) ? SCM_BUF0 : 0) + | (memchr (modes, 'l', n) ? SCM_BUFLINE : 0)); +} + long scm_mode_bits (char *modes) { - return (SCM_OPN - | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0) - | ( strchr (modes, 'w') - || strchr (modes, 'a') - || strchr (modes, '+') ? SCM_WRTNG : 0) - | (strchr (modes, '0') ? SCM_BUF0 : 0) - | (strchr (modes, 'l') ? SCM_BUFLINE : 0)); + return scm_i_mode_bits_n (modes, strlen (modes)); } long @@ -688,7 +695,8 @@ scm_i_mode_bits (SCM modes) if (!scm_is_string (modes)) scm_wrong_type_arg_msg (NULL, 0, modes, "string"); - bits = scm_mode_bits (SCM_I_STRING_CHARS (modes)); + bits = scm_i_mode_bits_n (scm_i_string_chars (modes), + scm_i_string_length (modes)); scm_remember_upto_here_1 (modes); return bits; } @@ -720,7 +728,7 @@ SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0, strcpy (modes, "w"); if (SCM_CELL_WORD_0 (port) & SCM_BUF0) strcat (modes, "0"); - return scm_mem2string (modes, strlen (modes)); + return scm_from_locale_string (modes); } #undef FUNC_NAME @@ -798,26 +806,29 @@ void scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data) { long i; + size_t n; SCM ports; /* Even without pre-emptive multithreading, running arbitrary code while scanning the port table is unsafe because the port table - can change arbitrarily (from a GC, for example). So we build a - list in advance while blocking the GC. -mvo */ + can change arbitrarily (from a GC, for example). So we first + collect the ports into a vector. -mvo */ scm_mutex_lock (&scm_i_port_table_mutex); - scm_block_gc++; - ports = SCM_EOL; - for (i = 0; i < scm_i_port_table_size; i++) - ports = scm_cons (scm_i_port_table[i]->port, ports); - scm_block_gc--; + n = scm_i_port_table_size; scm_mutex_unlock (&scm_i_port_table_mutex); - while (ports != SCM_EOL) - { - proc (data, SCM_CAR (ports)); - ports = SCM_CDR (ports); - } + ports = scm_make_vector (scm_from_size_t (n), SCM_BOOL_F); + + scm_mutex_lock (&scm_i_port_table_mutex); + if (n > scm_i_port_table_size) + n = scm_i_port_table_size; + for (i = 0; i < n; i++) + SCM_VECTOR_SET (ports, i, scm_i_port_table[i]->port); + scm_mutex_unlock (&scm_i_port_table_mutex); + + for (i = 0; i < n; i++) + proc (data, SCM_VECTOR_REF (ports, i)); } SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0, @@ -1322,7 +1333,7 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0, else SCM_VALIDATE_OPINPORT (2, port); - scm_ungets (SCM_I_STRING_CHARS (str), SCM_I_STRING_LENGTH (str), port); + scm_ungets (scm_i_string_chars (str), scm_i_string_length (str), port); return str; } From 272632a67c4772ee439813b55c7b2f2dbeb77af3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:17:43 +0000 Subject: [PATCH 011/100] (scm_i_casei_streq): New, for counted strings. * strings.h, strings.c: (scm_i_string_chars, scm_i_string_length, scm_i_string_writable_chars, scm_i_string_stop_writing): New, to replace SCM_I_STRING_CHARS and SCM_I_STRING_LENGTH. Updated all uses. (scm_i_make_string, scm_c_make_string): New, to replace scm_allocate_string. Updated all uses. (SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_UCHARS, SCM_STRING_LENGTH): Deprecated. (scm_allocate_string, scm_take_str, scm_take0str, scm_mem2string, scm_str2string, scm_makfrom0str, scm_makfrom0str_opt): Discouraged. Replaced all uses with scm_from_locale_string or similar, as appropriate. (scm_c_string_length, scm_c_string_ref, scm_c_string_set_x, scm_c_substring, scm_c_substring_shared, scm_c_substring_copy, scm_substring_shared, scm_substring_copy): New. * symbols.c, symbols.h (SCM_SYMBOLP, SCM_SYMBOL_FUNC, SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, SCM_SET_SYMBOL_PROPS, SCM_SYMBOL_HASH, SCM_SYMBOL_INTERNED_P, scm_mem2symbol, scm_str2symbol, scm_mem2uninterned_symbol): Discouraged. (SCM_SYMBOL_LENGTH, SCM_SYMBOL_CHARS, scm_c_symbol2str): Deprecated. (SCM_MAKE_SYMBOL_TAG, SCM_SET_SYMBOL_LENGTH, SCM_SET_SYMBOL_CHARS, SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS): Removed. (scm_is_symbol, scm_from_locale_symbol, scm_from_locale_symboln): New, to replace scm_str2symbol and scm_mem2symbol, respectively. Updated all uses. (scm_gensym): Generate only the number suffix in the buffer, just string-append the prefix. --- libguile/read.c | 85 ++++++++++++++++++++++++++++--------------------- 1 file changed, 49 insertions(+), 36 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index fc973dcd2..c64651b72 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -86,16 +86,16 @@ scm_input_error (char const *function, SCM string_port = scm_open_output_string (); SCM string = SCM_EOL; scm_simple_format (string_port, - scm_makfrom0str ("~A:~S:~S: ~A"), + scm_from_locale_string ("~A:~S:~S: ~A"), scm_list_4 (fn, scm_from_int (SCM_LINUM (port) + 1), scm_from_int (SCM_COL (port) + 1), - scm_makfrom0str (message))); + scm_from_locale_string (message))); string = scm_get_output_string (string_port); scm_close_output_port (string_port); - scm_error_scm (scm_str2symbol ("read-error"), - scm_makfrom0str (function), + scm_error_scm (scm_from_locale_symbol ("read-error"), + scm_from_locale_string (function), string, arg, SCM_BOOL_F); @@ -141,7 +141,7 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0, return SCM_EOF_VAL; scm_ungetc (c, port); - tok_buf = scm_allocate_string (30); + tok_buf = scm_c_make_string (30, SCM_UNDEFINED); return scm_lreadr (&tok_buf, port, ©); } #undef FUNC_NAME @@ -151,15 +151,17 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0, char * scm_grow_tok_buf (SCM *tok_buf) { - size_t oldlen = SCM_I_STRING_LENGTH (*tok_buf); - SCM newstr = scm_allocate_string (2 * oldlen); + size_t oldlen = scm_i_string_length (*tok_buf); + const char *olddata = scm_i_string_chars (*tok_buf); + char *newdata; + SCM newstr = scm_i_make_string (2 * oldlen, &newdata); size_t i; for (i = 0; i != oldlen; ++i) - SCM_I_STRING_CHARS (newstr) [i] = SCM_I_STRING_CHARS (*tok_buf) [i]; + newdata[i] = olddata[i]; *tok_buf = newstr; - return SCM_I_STRING_CHARS (newstr); + return newdata; } @@ -218,6 +220,20 @@ scm_casei_streq (char *s1, char *s2) return !(*s1 || *s2); } +static int +scm_i_casei_streq (const char *s1, const char *s2, size_t len2) +{ + while (*s1 && len2 > 0) + if (scm_c_downcase((int)*s1) != scm_c_downcase((int)*s2)) + return 0; + else + { + ++s1; + ++s2; + --len2; + } + return !(*s1 || len2 > 0); +} /* recsexpr is used when recording expressions * constructed by read:sharp. @@ -437,7 +453,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) #if SCM_HAVE_ARRAYS case '*': j = scm_read_token (c, tok_buf, port, 0); - p = scm_istr2bve (SCM_I_STRING_CHARS (*tok_buf) + 1, (long) (j - 1)); + p = scm_istr2bve (scm_c_substring_shared (*tok_buf, 1, j-1)); if (scm_is_true (p)) return p; else @@ -446,7 +462,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) case '{': j = scm_read_token (c, tok_buf, port, 1); - return scm_mem2symbol (SCM_I_STRING_CHARS (*tok_buf), j); + return scm_string_to_symbol (scm_c_substring_copy (*tok_buf, 0, j)); case '\\': c = scm_getc (port); @@ -460,20 +476,22 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) * does only consist of octal digits. Finally, it should be * checked whether the resulting fixnum is in the range of * characters. */ - p = scm_i_mem2number (SCM_I_STRING_CHARS (*tok_buf), j, 8); + p = scm_i_mem2number (scm_i_string_chars (*tok_buf), j, 8); if (SCM_I_INUMP (p)) return SCM_MAKE_CHAR (SCM_I_INUM (p)); } for (c = 0; c < scm_n_charnames; c++) if (scm_charnames[c] - && (scm_casei_streq (scm_charnames[c], SCM_I_STRING_CHARS (*tok_buf)))) + && (scm_i_casei_streq (scm_charnames[c], + scm_i_string_chars (*tok_buf), j))) return SCM_MAKE_CHAR (scm_charnums[c]); - scm_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL); + scm_input_error (FUNC_NAME, port, "unknown character name ~a", + scm_list_1 (scm_c_substring (*tok_buf, 0, j))); /* #:SYMBOL is a syntax for keywords supported in all contexts. */ case ':': j = scm_read_token ('-', tok_buf, port, 0); - p = scm_mem2symbol (SCM_I_STRING_CHARS (*tok_buf), j); + p = scm_string_to_symbol (scm_c_substring_copy (*tok_buf, 0, j)); return scm_make_keyword_from_dash_symbol (p); default: @@ -509,7 +527,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) if (c == EOF) str_eof: scm_input_error (FUNC_NAME, port, "end of file in string constant", SCM_EOL); - while (j + 2 >= SCM_I_STRING_LENGTH (*tok_buf)) + while (j + 2 >= scm_i_string_length (*tok_buf)) scm_grow_tok_buf (tok_buf); if (c == '\\') @@ -574,13 +592,12 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) "illegal character in escape sequence: ~S", scm_list_1 (SCM_MAKE_CHAR (c))); } - SCM_I_STRING_CHARS (*tok_buf)[j] = c; + scm_c_string_set_x (*tok_buf, j, SCM_MAKE_CHAR (c)); ++j; } if (j == 0) return scm_nullstr; - SCM_I_STRING_CHARS (*tok_buf)[j] = 0; - return scm_mem2string (SCM_I_STRING_CHARS (*tok_buf), j); + return scm_c_substring_copy (*tok_buf, 0, j); case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': @@ -593,7 +610,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) /* Shortcut: Detected symbol '+ or '- */ goto tok; - p = scm_i_mem2number (SCM_I_STRING_CHARS (*tok_buf), j, 10); + p = scm_i_mem2number (scm_i_string_chars (*tok_buf), j, 10); if (scm_is_true (p)) return p; if (c == '#') @@ -601,7 +618,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) if ((j == 2) && (scm_getc (port) == '(')) { scm_ungetc ('(', port); - c = SCM_I_STRING_CHARS (*tok_buf)[1]; + c = scm_i_string_chars (*tok_buf)[1]; goto callshrp; } scm_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL); @@ -612,7 +629,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) { j = scm_read_token ('-', tok_buf, port, 0); - p = scm_mem2symbol (SCM_I_STRING_CHARS (*tok_buf), j); + p = scm_string_to_symbol (scm_c_substring (*tok_buf, 0, j)); return scm_make_keyword_from_dash_symbol (p); } /* fallthrough */ @@ -624,7 +641,7 @@ scm_lreadr (SCM *tok_buf, SCM port, SCM *copy) /* fallthrough */ tok: - return scm_mem2symbol (SCM_I_STRING_CHARS (*tok_buf), j); + return scm_string_to_symbol (scm_c_substring (*tok_buf, 0, j)); } } #undef FUNC_NAME @@ -637,28 +654,26 @@ _Pragma ("noopt"); /* # pragma _CRI noopt */ size_t scm_read_token (int ic, SCM *tok_buf, SCM port, int weird) { - register size_t j; - register int c; - register char *p; + size_t j; + int c; c = (SCM_CASE_INSENSITIVE_P ? scm_c_downcase(ic) : ic); - p = SCM_I_STRING_CHARS (*tok_buf); - + if (weird) j = 0; else { j = 0; - while (j + 2 >= SCM_I_STRING_LENGTH (*tok_buf)) - p = scm_grow_tok_buf (tok_buf); - p[j] = c; + while (j + 2 >= scm_i_string_length (*tok_buf)) + scm_grow_tok_buf (tok_buf); + scm_c_string_set_x (*tok_buf, j, SCM_MAKE_CHAR (c)); ++j; } while (1) { - while (j + 2 >= SCM_I_STRING_LENGTH (*tok_buf)) - p = scm_grow_tok_buf (tok_buf); + while (j + 2 >= scm_i_string_length (*tok_buf)) + scm_grow_tok_buf (tok_buf); c = scm_getc (port); switch (c) { @@ -682,7 +697,6 @@ scm_read_token (int ic, SCM *tok_buf, SCM port, int weird) scm_ungetc (c, port); case EOF: eof_case: - p[j] = 0; return j; case '\\': if (!weird) @@ -702,7 +716,6 @@ scm_read_token (int ic, SCM *tok_buf, SCM port, int weird) c = scm_getc (port); if (c == '#') { - p[j] = 0; return j; } else @@ -716,7 +729,7 @@ scm_read_token (int ic, SCM *tok_buf, SCM port, int weird) default_case: { c = (SCM_CASE_INSENSITIVE_P ? scm_c_downcase(c) : c); - p[j] = c; + scm_c_string_set_x (*tok_buf, j, SCM_MAKE_CHAR (c)); ++j; } From f76c6bb2342534158769cc55ce40edd17492f9c4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:18:25 +0000 Subject: [PATCH 012/100] (gh_set_substr): Made src const. * strings.h, strings.c: (scm_i_string_chars, scm_i_string_length, scm_i_string_writable_chars, scm_i_string_stop_writing): New, to replace SCM_I_STRING_CHARS and SCM_I_STRING_LENGTH. Updated all uses. (scm_i_make_string, scm_c_make_string): New, to replace scm_allocate_string. Updated all uses. (SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_UCHARS, SCM_STRING_LENGTH): Deprecated. (scm_allocate_string, scm_take_str, scm_take0str, scm_mem2string, scm_str2string, scm_makfrom0str, scm_makfrom0str_opt): Discouraged. Replaced all uses with scm_from_locale_string or similar, as appropriate. (scm_c_string_length, scm_c_string_ref, scm_c_string_set_x, scm_c_substring, scm_c_substring_shared, scm_c_substring_copy, scm_substring_shared, scm_substring_copy): New. * symbols.c, symbols.h (SCM_SYMBOLP, SCM_SYMBOL_FUNC, SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, SCM_SET_SYMBOL_PROPS, SCM_SYMBOL_HASH, SCM_SYMBOL_INTERNED_P, scm_mem2symbol, scm_str2symbol, scm_mem2uninterned_symbol): Discouraged. (SCM_SYMBOL_LENGTH, SCM_SYMBOL_CHARS, scm_c_symbol2str): Deprecated. (SCM_MAKE_SYMBOL_TAG, SCM_SET_SYMBOL_LENGTH, SCM_SET_SYMBOL_CHARS, SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS): Removed. (scm_is_symbol, scm_from_locale_symbol, scm_from_locale_symboln): New, to replace scm_str2symbol and scm_mem2symbol, respectively. Updated all uses. (scm_gensym): Generate only the number suffix in the buffer, just string-append the prefix. --- libguile/gh.h | 2 +- libguile/gh_data.c | 56 +++++++++++++++------------------------------- 2 files changed, 19 insertions(+), 39 deletions(-) diff --git a/libguile/gh.h b/libguile/gh.h index dfc892f17..c9558d3db 100644 --- a/libguile/gh.h +++ b/libguile/gh.h @@ -81,7 +81,7 @@ SCM_API SCM gh_double2scm(double x); SCM_API SCM gh_char2scm(char c); SCM_API SCM gh_str2scm(const char *s, size_t len); SCM_API SCM gh_str02scm(const char *s); -SCM_API void gh_set_substr(char *src, SCM dst, long start, size_t len); +SCM_API void gh_set_substr(const char *src, SCM dst, long start, size_t len); SCM_API SCM gh_symbol2scm(const char *symbol_str); SCM_API SCM gh_ints2scm(const int *d, long n); diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 7f41b206d..1b87ad25f 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2004 Free Software Foundation, Inc. * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either @@ -61,12 +61,12 @@ gh_char2scm (char c) SCM gh_str2scm (const char *s, size_t len) { - return scm_mem2string (s, len); + return scm_from_locale_stringn (s, len); } SCM gh_str02scm (const char *s) { - return scm_makfrom0str (s); + return scm_from_locale_string (s); } /* Copy LEN characters at SRC into the *existing* Scheme string DST, starting at START. START is an index into DST; zero means the @@ -75,18 +75,19 @@ gh_str02scm (const char *s) If START + LEN is off the end of DST, signal an out-of-range error. */ void -gh_set_substr (char *src, SCM dst, long start, size_t len) +gh_set_substr (const char *src, SCM dst, long start, size_t len) { char *dst_ptr; size_t dst_len; - SCM_ASSERT (SCM_I_STRINGP (dst), dst, SCM_ARG3, "gh_set_substr"); + SCM_ASSERT (scm_is_string (dst), dst, SCM_ARG3, "gh_set_substr"); - dst_ptr = SCM_I_STRING_CHARS (dst); - dst_len = SCM_I_STRING_LENGTH (dst); + dst_len = scm_i_string_length (dst); SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr"); - + + dst_ptr = scm_i_string_writable_chars (dst); memmove (dst_ptr + start, src, len); + scm_i_string_stop_writing (); scm_remember_upto_here_1 (dst); } @@ -94,7 +95,7 @@ gh_set_substr (char *src, SCM dst, long start, size_t len) SCM gh_symbol2scm (const char *symbol_str) { - return scm_str2symbol(symbol_str); + return scm_from_locale_symbol(symbol_str); } SCM @@ -259,12 +260,12 @@ gh_scm2chars (SCM obj, char *m) break; #endif case scm_tc7_string: - n = SCM_I_STRING_LENGTH (obj); + n = scm_i_string_length (obj); if (m == 0) m = (char *) malloc (n * sizeof (char)); if (m == NULL) return NULL; - memcpy (m, SCM_I_STRING_CHARS (obj), n * sizeof (char)); + memcpy (m, scm_i_string_chars (obj), n * sizeof (char)); break; default: scm_wrong_type_arg (0, 0, obj); @@ -525,7 +526,7 @@ gh_scm2newstr (SCM str, size_t *lenp) ret_str = scm_to_locale_string (str); if (lenp) - *lenp = SCM_I_STRING_LENGTH (str); + *lenp = scm_i_string_length (str); return ret_str; } @@ -540,11 +541,11 @@ void gh_get_substr (SCM src, char *dst, long start, size_t len) { size_t src_len, effective_length; - SCM_ASSERT (SCM_I_STRINGP (src), src, SCM_ARG3, "gh_get_substr"); + SCM_ASSERT (scm_is_string (src), src, SCM_ARG3, "gh_get_substr"); - src_len = SCM_I_STRING_LENGTH (src); + src_len = scm_i_string_length (src); effective_length = (len < src_len) ? len : src_len; - memcpy (dst + start, SCM_I_STRING_CHARS (src), effective_length * sizeof (char)); + memcpy (dst + start, scm_i_string_chars (src), effective_length * sizeof (char)); /* FIXME: must signal an error if len > src_len */ scm_remember_upto_here_1 (src); } @@ -561,28 +562,7 @@ gh_get_substr (SCM src, char *dst, long start, size_t len) char * gh_symbol2newstr (SCM sym, size_t *lenp) { - char *ret_str; - size_t len; - - SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3, "gh_scm2newsymbol"); - - len = SCM_SYMBOL_LENGTH (sym); - - ret_str = (char *) malloc ((len + 1) * sizeof (char)); - if (ret_str == NULL) - return NULL; - /* so we copy sym to ret_str, which is what we will allocate */ - memcpy (ret_str, SCM_SYMBOL_CHARS (sym), len); - scm_remember_upto_here_1 (sym); - /* now make sure we null-terminate it */ - ret_str[len] = '\0'; - - if (lenp != NULL) - { - *lenp = len; - } - - return ret_str; + return gh_scm2newstr (scm_symbol_to_string (sym), lenp); } @@ -665,7 +645,7 @@ gh_module_lookup (SCM module, const char *sname) SCM_VALIDATE_MODULE (SCM_ARG1, module); - sym = scm_str2symbol (sname); + sym = scm_from_locale_symbol (sname); var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F); if (var != SCM_BOOL_F) return SCM_VARIABLE_REF (var); From cc95e00ac63820cbc03ca858ff6b8e1015c9d168 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:19:44 +0000 Subject: [PATCH 013/100] * strings.h, strings.c: (scm_i_string_chars, scm_i_string_length, scm_i_string_writable_chars, scm_i_string_stop_writing): New, to replace SCM_I_STRING_CHARS and SCM_I_STRING_LENGTH. Updated all uses. (scm_i_make_string, scm_c_make_string): New, to replace scm_allocate_string. Updated all uses. (SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_UCHARS, SCM_STRING_LENGTH): Deprecated. (scm_allocate_string, scm_take_str, scm_take0str, scm_mem2string, scm_str2string, scm_makfrom0str, scm_makfrom0str_opt): Discouraged. Replaced all uses with scm_from_locale_string or similar, as appropriate. (scm_c_string_length, scm_c_string_ref, scm_c_string_set_x, scm_c_substring, scm_c_substring_shared, scm_c_substring_copy, scm_substring_shared, scm_substring_copy): New. * symbols.c, symbols.h (SCM_SYMBOLP, SCM_SYMBOL_FUNC, SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, SCM_SET_SYMBOL_PROPS, SCM_SYMBOL_HASH, SCM_SYMBOL_INTERNED_P, scm_mem2symbol, scm_str2symbol, scm_mem2uninterned_symbol): Discouraged. (SCM_SYMBOL_LENGTH, SCM_SYMBOL_CHARS, scm_c_symbol2str): Deprecated. (SCM_MAKE_SYMBOL_TAG, SCM_SET_SYMBOL_LENGTH, SCM_SET_SYMBOL_CHARS, SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS): Removed. (scm_is_symbol, scm_from_locale_symbol, scm_from_locale_symboln): New, to replace scm_str2symbol and scm_mem2symbol, respectively. Updated all uses. (scm_gensym): Generate only the number suffix in the buffer, just string-append the prefix. --- libguile/backtrace.c | 34 ++++++----- libguile/convert.i.c | 4 +- libguile/deprecation.c | 2 +- libguile/dynl.c | 4 +- libguile/environments.c | 31 +++++----- libguile/eval.c | 63 ++++++++++---------- libguile/feature.c | 6 +- libguile/filesys.c | 30 +++++----- libguile/fports.c | 2 +- libguile/gdbint.c | 6 +- libguile/goops.c | 86 +++++++++++++--------------- libguile/hash.c | 6 +- libguile/init.c | 7 ++- libguile/keywords.c | 23 ++++---- libguile/load.c | 33 +++++------ libguile/modules.c | 17 +++--- libguile/net_db.c | 10 ++-- libguile/numbers.c | 16 +++--- libguile/objects.c | 13 ++--- libguile/options.c | 4 +- libguile/posix.c | 48 ++++++++-------- libguile/print.c | 43 +++++++------- libguile/procs.c | 2 +- libguile/ramap.c | 23 +++++--- libguile/random.c | 10 ++-- libguile/random.h | 6 +- libguile/rdelim.c | 16 +++--- libguile/regex-posix.c | 58 ++++++++----------- libguile/rw.c | 13 +++-- libguile/script.c | 8 +-- libguile/snarf.h | 6 +- libguile/socket.c | 38 ++++++++----- libguile/stacks.c | 5 +- libguile/stime.c | 27 ++++++--- libguile/strop.c | 123 ++++++++++++++++++++++++---------------- libguile/strorder.c | 36 ++++++------ libguile/strports.c | 56 +++++++++++++----- libguile/struct.c | 57 ++++++++++--------- libguile/throw.c | 6 +- libguile/unif.c | 113 ++++++++++++++++++++++-------------- libguile/unif.h | 2 +- libguile/validate.h | 12 +++- libguile/values.c | 6 +- libguile/version.c | 4 +- libguile/vports.c | 2 +- 45 files changed, 623 insertions(+), 494 deletions(-) diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 23e67e4da..09430f5cc 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -177,7 +177,7 @@ display_expression (SCM frame, SCM pname, SCM source, SCM port) pstate->fancyp = 1; pstate->level = DISPLAY_EXPRESSION_MAX_LEVEL; pstate->length = DISPLAY_EXPRESSION_MAX_LENGTH; - if (SCM_SYMBOLP (pname) || scm_is_string (pname)) + if (scm_is_symbol (pname) || scm_is_string (pname)) { if (SCM_FRAMEP (frame) && SCM_FRAME_EVAL_ARGS_P (frame)) @@ -228,13 +228,13 @@ display_error_body (struct display_error_args *a) prev_frame = SCM_FRAME_PREV (current_frame); if (!SCM_MEMOIZEDP (source) && scm_is_true (prev_frame)) source = SCM_FRAME_SOURCE (prev_frame); - if (!SCM_SYMBOLP (pname) + if (!scm_is_symbol (pname) && !scm_is_string (pname) && SCM_FRAME_PROC_P (current_frame) && scm_is_true (scm_procedure_p (SCM_FRAME_PROC (current_frame)))) pname = scm_procedure_name (SCM_FRAME_PROC (current_frame)); } - if (SCM_SYMBOLP (pname) || scm_is_string (pname) || SCM_MEMOIZEDP (source)) + if (scm_is_symbol (pname) || scm_is_string (pname) || SCM_MEMOIZEDP (source)) { display_header (source, a->port); display_expression (current_frame, pname, source, a->port); @@ -401,18 +401,24 @@ display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, S string = scm_strport_to_string (sport); assert (scm_is_string (string)); - /* Remove control characters */ - for (i = 0; i < n; ++i) - if (iscntrl ((int) SCM_I_STRING_UCHARS (string)[i])) - SCM_I_STRING_UCHARS (string)[i] = ' '; - /* Truncate */ - if (indentation + n > SCM_BACKTRACE_WIDTH) - { - n = SCM_BACKTRACE_WIDTH - indentation; - SCM_I_STRING_UCHARS (string)[n - 1] = '$'; - } + { + char *data = scm_i_string_writable_chars (string); + + /* Remove control characters */ + for (i = 0; i < n; ++i) + if (iscntrl (data[i])) + data[i] = ' '; + /* Truncate */ + if (indentation + n > SCM_BACKTRACE_WIDTH) + { + n = SCM_BACKTRACE_WIDTH - indentation; + data[n-1] = '$'; + } + + scm_i_string_stop_writing (); + } - scm_lfwrite (SCM_I_STRING_CHARS (string), n, port); + scm_lfwrite (scm_i_string_chars (string), n, port); scm_remember_upto_here_1 (string); } diff --git a/libguile/convert.i.c b/libguile/convert.i.c index 1fe928110..230aa5192 100644 --- a/libguile/convert.i.c +++ b/libguile/convert.i.c @@ -163,11 +163,11 @@ SCM2CTYPES (SCM obj, CTYPE *data) #if SIZEOF_CTYPE == 1 case scm_tc7_string: - n = SCM_I_STRING_LENGTH (obj); + n = scm_i_string_length (obj); if (data == NULL) if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) return NULL; - memcpy (data, SCM_I_STRING_CHARS (obj), n * sizeof (CTYPE)); + memcpy (data, scm_i_string_chars (obj), n * sizeof (CTYPE)); break; #endif diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 3d4852a2f..d33e6b5ae 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -103,7 +103,7 @@ SCM_DEFINE(scm_issue_deprecation_warning, mode = summary_print; else { - SCM nl = scm_str2string ("\n"); + SCM nl = scm_from_locale_string ("\n"); SCM msgs_nl = SCM_EOL; char *c_msgs; while (SCM_CONSP (msgs)) diff --git a/libguile/dynl.c b/libguile/dynl.c index 99c6dc837..ad2b3a32a 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -75,8 +75,8 @@ sysdep_dynl_link (const char *fname, const char *subr) SCM fn; SCM msg; - fn = scm_makfrom0str (fname); - msg = scm_makfrom0str (scm_lt_dlerror ()); + fn = scm_from_locale_string (fname); + msg = scm_from_locale_string (scm_lt_dlerror ()); scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg)); } return (void *) handle; diff --git a/libguile/environments.c b/libguile/environments.c index 1b75bcd2d..bd90a43fe 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -118,7 +118,7 @@ SCM_DEFINE (scm_environment_bound_p, "environment-bound?", 2, 0, 0, #define FUNC_NAME s_scm_environment_bound_p { SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); - SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME); + SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME); return scm_from_bool (SCM_ENVIRONMENT_BOUND_P (env, sym)); } @@ -135,7 +135,7 @@ SCM_DEFINE (scm_environment_ref, "environment-ref", 2, 0, 0, SCM val; SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); - SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME); + SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME); val = SCM_ENVIRONMENT_REF (env, sym); @@ -155,7 +155,7 @@ SCM scm_c_environment_ref (SCM env, SCM sym) { SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_ref"); - SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, "scm_c_environment_ref"); + SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_ref"); return SCM_ENVIRONMENT_REF (env, sym); } @@ -240,7 +240,7 @@ SCM_DEFINE (scm_environment_define, "environment-define", 3, 0, 0, SCM status; SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); - SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME); + SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME); status = SCM_ENVIRONMENT_DEFINE (env, sym, val); @@ -266,7 +266,7 @@ SCM_DEFINE (scm_environment_undefine, "environment-undefine", 2, 0, 0, SCM status; SCM_ASSERT(SCM_ENVIRONMENT_P(env), env, SCM_ARG1, FUNC_NAME); - SCM_ASSERT(SCM_SYMBOLP(sym), sym, SCM_ARG2, FUNC_NAME); + SCM_ASSERT(scm_is_symbol(sym), sym, SCM_ARG2, FUNC_NAME); status = SCM_ENVIRONMENT_UNDEFINE (env, sym); @@ -294,7 +294,7 @@ SCM_DEFINE (scm_environment_set_x, "environment-set!", 3, 0, 0, SCM status; SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); - SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME); + SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME); status = SCM_ENVIRONMENT_SET (env, sym, val); @@ -329,7 +329,7 @@ SCM_DEFINE (scm_environment_cell, "environment-cell", 3, 0, 0, SCM location; SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME); - SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, FUNC_NAME); + SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME); SCM_ASSERT (scm_is_bool (for_write), for_write, SCM_ARG3, FUNC_NAME); location = SCM_ENVIRONMENT_CELL (env, sym, scm_is_true (for_write)); @@ -355,7 +355,7 @@ SCM scm_c_environment_cell(SCM env, SCM sym, int for_write) { SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_cell"); - SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG2, "scm_c_environment_cell"); + SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_cell"); return SCM_ENVIRONMENT_CELL (env, sym, for_write); } @@ -507,7 +507,7 @@ observer_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED) static SCM obarray_enter (SCM obarray, SCM symbol, SCM data) { - size_t hash = SCM_SYMBOL_HASH (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray); + size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray); SCM entry = scm_cons (symbol, data); SCM slot = scm_cons (entry, SCM_HASHTABLE_BUCKETS (obarray)[hash]); SCM_SET_HASHTABLE_BUCKET (obarray, hash, slot); @@ -525,7 +525,7 @@ obarray_enter (SCM obarray, SCM symbol, SCM data) static SCM obarray_replace (SCM obarray, SCM symbol, SCM data) { - size_t hash = SCM_SYMBOL_HASH (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray); + size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray); SCM new_entry = scm_cons (symbol, data); SCM lsym; SCM slot; @@ -557,7 +557,7 @@ obarray_replace (SCM obarray, SCM symbol, SCM data) static SCM obarray_retrieve (SCM obarray, SCM sym) { - size_t hash = SCM_SYMBOL_HASH (sym) % SCM_HASHTABLE_N_BUCKETS (obarray); + size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray); SCM lsym; for (lsym = SCM_HASHTABLE_BUCKETS (obarray)[hash]; @@ -580,7 +580,7 @@ obarray_retrieve (SCM obarray, SCM sym) static SCM obarray_remove (SCM obarray, SCM sym) { - size_t hash = SCM_SYMBOL_HASH (sym) % SCM_HASHTABLE_N_BUCKETS (obarray); + size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray); SCM table_entry = SCM_HASHTABLE_BUCKETS (obarray)[hash]; SCM handle = scm_sloppy_assq (sym, table_entry); @@ -787,7 +787,8 @@ update_catch_handler (void *ptr, SCM tag, SCM args) { struct update_data *data = (struct update_data *) ptr; SCM observer = data->observer; - SCM message = scm_makfrom0str ("Observer `~A' signals `~A' error: ~S"); + SCM message = + scm_from_locale_string ("Observer `~A' signals `~A' error: ~S"); return scm_cons (message, scm_list_3 (observer, tag, args)); } @@ -2238,7 +2239,7 @@ export_environment_parse_signature (SCM signature, const char* caller) { SCM entry = SCM_CAR (l); - if (SCM_SYMBOLP (entry)) + if (scm_is_symbol (entry)) { SCM new_entry = scm_cons2 (entry, symbol_immutable_location, SCM_EOL); result = scm_cons (new_entry, result); @@ -2253,7 +2254,7 @@ export_environment_parse_signature (SCM signature, const char* caller) SCM l2; SCM_ASSERT (SCM_CONSP (entry), entry, SCM_ARGn, caller); - SCM_ASSERT (SCM_SYMBOLP (SCM_CAR (entry)), entry, SCM_ARGn, caller); + SCM_ASSERT (scm_is_symbol (SCM_CAR (entry)), entry, SCM_ARGn, caller); sym = SCM_CAR (entry); diff --git a/libguile/eval.c b/libguile/eval.c index d8dfc9e70..a032cf8da 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -254,7 +254,7 @@ syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN; static void syntax_error (const char* const msg, const SCM form, const SCM expr) { - const SCM msg_string = scm_makfrom0str (msg); + SCM msg_string = scm_from_locale_string (msg); SCM filename = SCM_BOOL_F; SCM linenr = SCM_BOOL_F; const char *format; @@ -524,7 +524,7 @@ is_self_quoting_p (const SCM expr) { if (SCM_CONSP (expr)) return 0; - else if (SCM_SYMBOLP (expr)) + else if (scm_is_symbol (expr)) return 0; else if (SCM_NULLP (expr)) return 0; @@ -651,7 +651,7 @@ m_body (SCM op, SCM exprs) static SCM try_macro_lookup (const SCM expr, const SCM env) { - if (SCM_SYMBOLP (expr)) + if (scm_is_symbol (expr)) { const SCM variable = lookup_symbol (expr, env); if (SCM_VARIABLEP (variable)) @@ -848,7 +848,7 @@ macroexp (SCM x, SCM env) macro_tail: orig_sym = SCM_CAR (x); - if (!SCM_SYMBOLP (orig_sym)) + if (!scm_is_symbol (orig_sym)) return x; { @@ -1178,7 +1178,7 @@ canonicalize_define (const SCM expr) body = scm_list_1 (lambda); variable = SCM_CAR (variable); } - ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr); ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr); SCM_SETCAR (cdr_expr, variable); @@ -1313,7 +1313,7 @@ scm_m_do (SCM expr, SCM env SCM_UNUSED) const SCM name = SCM_CAR (binding); const SCM init = SCM_CADR (binding); const SCM step = (length == 2) ? name : SCM_CADDR (binding); - ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr); + ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr); ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, variables)), s_duplicate_binding, name, expr); @@ -1455,7 +1455,7 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED) } else { - ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals) || SCM_NULLP (formals), + ASSERT_SYNTAX_2 (scm_is_symbol (formals) || SCM_NULLP (formals), s_bad_formals, formals, expr); } @@ -1466,12 +1466,12 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED) { const SCM formal = SCM_CAR (formals_idx); const SCM next_idx = SCM_CDR (formals_idx); - ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal), s_bad_formal, formal, expr); + ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal, expr); ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx), s_duplicate_formal, formal, expr); formals_idx = next_idx; } - ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || SCM_SYMBOLP (formals_idx), + ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || scm_is_symbol (formals_idx), s_bad_formal, formals_idx, expr); /* Memoize the body. Keep a potential documentation string. */ @@ -1525,7 +1525,7 @@ check_bindings (const SCM bindings, const SCM expr) s_bad_binding, binding, expr); name = SCM_CAR (binding); - ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr); + ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr); } } @@ -1611,7 +1611,7 @@ scm_m_let (SCM expr, SCM env) ASSERT_SYNTAX (length >= 2, s_missing_expression, expr); bindings = SCM_CAR (cdr_expr); - if (SCM_SYMBOLP (bindings)) + if (scm_is_symbol (bindings)) { ASSERT_SYNTAX (length >= 3, s_missing_expression, expr); return memoize_named_let (expr, env); @@ -1944,7 +1944,7 @@ scm_m_set_x (SCM expr, SCM env SCM_UNUSED) variable = SCM_CAR (cdr_expr); /* Memoize the variable form. */ - ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr); new_variable = lookup_symbol (variable, env); /* Leave the memoization of unbound symbols to lazy memoization: */ if (SCM_UNBNDP (new_variable)) @@ -2140,7 +2140,7 @@ scm_m_generalized_set_x (SCM expr, SCM env) && SCM_NULLP (SCM_CDDR (exp_target))) { exp_target= SCM_CADR (exp_target); - ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target) + ASSERT_SYNTAX_2 (scm_is_symbol (exp_target) || SCM_VARIABLEP (exp_target), s_bad_variable, exp_target, expr); return scm_cons (SCM_IM_SET_X, scm_cons (exp_target, @@ -2276,7 +2276,7 @@ scm_m_atfop (SCM expr, SCM env SCM_UNUSED) ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_missing_expression, expr); symbol = SCM_CAR (cdr_expr); - ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol), s_bad_variable, symbol, expr); + ASSERT_SYNTAX_2 (scm_is_symbol (symbol), s_bad_variable, symbol, expr); location = scm_symbol_fref (symbol); ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr); @@ -2284,7 +2284,7 @@ scm_m_atfop (SCM expr, SCM env SCM_UNUSED) /* The elisp function `defalias' allows to define aliases for symbols. To * look up such definitions, the chain of symbol definitions has to be * followed up to the terminal symbol. */ - while (SCM_SYMBOLP (SCM_VARIABLE_REF (location))) + while (scm_is_symbol (SCM_VARIABLE_REF (location))) { const SCM alias = SCM_VARIABLE_REF (location); location = scm_symbol_fref (alias); @@ -2460,7 +2460,7 @@ scm_m_undefine (SCM expr, SCM env) ("`undefine' is deprecated.\n"); variable = SCM_CAR (cdr_expr); - ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr); location = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_F); ASSERT_SYNTAX_2 (scm_is_true (location) && !SCM_UNBNDP (SCM_VARIABLE_REF (location)), @@ -2622,7 +2622,7 @@ static SCM deval (SCM x, SCM env); ? (scm_debug_mode_p \ ? deval (SCM_CAR (x), (env)) \ : ceval (SCM_CAR (x), (env))) \ - : (!SCM_SYMBOLP (SCM_CAR (x)) \ + : (!scm_is_symbol (SCM_CAR (x)) \ ? SCM_CAR (x) \ : *scm_lookupcar ((x), (env), 1))))) @@ -2642,7 +2642,7 @@ static SCM deval (SCM x, SCM env); ? SCM_VARIABLE_REF (SCM_CAR (x)) \ : (SCM_CONSP (SCM_CAR (x)) \ ? CEVAL (SCM_CAR (x), (env)) \ - : (!SCM_SYMBOLP (SCM_CAR (x)) \ + : (!scm_is_symbol (SCM_CAR (x)) \ ? SCM_CAR (x) \ : *scm_lookupcar ((x), (env), 1))))) @@ -3345,7 +3345,7 @@ dispatch: RETURN (SCM_I_EVALIM (last_form, env)); else if (SCM_VARIABLEP (last_form)) RETURN (SCM_VARIABLE_REF (last_form)); - else if (SCM_SYMBOLP (last_form)) + else if (scm_is_symbol (last_form)) RETURN (*scm_lookupcar (x, env, 1)); else RETURN (last_form); @@ -3603,7 +3603,7 @@ dispatch: location = SCM_VARIABLE_LOC (variable); else { - /* (SCM_SYMBOLP (variable)) is known to be true */ + /* (scm_is_symbol (variable)) is known to be true */ variable = lazy_memoize_variable (variable, env); SCM_SETCAR (x, variable); location = SCM_VARIABLE_LOC (variable); @@ -3945,7 +3945,7 @@ dispatch: proc = *scm_ilookup (SCM_CAR (x), env); else if (SCM_CONSP (SCM_CAR (x))) proc = CEVAL (SCM_CAR (x), env); - else if (SCM_SYMBOLP (SCM_CAR (x))) + else if (scm_is_symbol (SCM_CAR (x))) { SCM orig_sym = SCM_CAR (x); { @@ -4160,14 +4160,15 @@ dispatch: RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + SCM_ARG1, + scm_i_symbol_chars (SCM_SNAME (proc))); case scm_tc7_cxr: { unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc); do { SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1, - SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + scm_i_symbol_chars (SCM_SNAME (proc))); arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1); pattern >>= 2; } while (pattern); @@ -4847,7 +4848,7 @@ tail: RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc))); case scm_tc7_cxr: if (SCM_UNBNDP (arg1) || !SCM_NULLP (args)) scm_wrong_num_args (proc); @@ -4856,7 +4857,7 @@ tail: do { SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1, - SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + scm_i_symbol_chars (SCM_SNAME (proc))); arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1); pattern >>= 2; } while (pattern); @@ -5199,7 +5200,7 @@ call_dsubr_1 (SCM proc, SCM arg1) RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc))); } static SCM @@ -5209,7 +5210,7 @@ call_cxr_1 (SCM proc, SCM arg1) do { SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1, - SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + scm_i_symbol_chars (SCM_SNAME (proc))); arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1); pattern >>= 2; } while (pattern); @@ -5854,7 +5855,7 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, SCM scm_i_eval_x (SCM exp, SCM env) { - if (SCM_SYMBOLP (exp)) + if (scm_is_symbol (exp)) return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1); else return SCM_I_XEVAL (exp, env); @@ -5864,7 +5865,7 @@ SCM scm_i_eval (SCM exp, SCM env) { exp = scm_copy_tree (exp); - if (SCM_SYMBOLP (exp)) + if (scm_is_symbol (exp)) return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1); else return SCM_I_XEVAL (exp, env); @@ -5980,7 +5981,7 @@ SCM scm_ceval (SCM x, SCM env) { if (SCM_CONSP (x)) return ceval (x, env); - else if (SCM_SYMBOLP (x)) + else if (scm_is_symbol (x)) return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1); else return SCM_I_XEVAL (x, env); @@ -5991,7 +5992,7 @@ SCM scm_deval (SCM x, SCM env) { if (SCM_CONSP (x)) return deval (x, env); - else if (SCM_SYMBOLP (x)) + else if (scm_is_symbol (x)) return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1); else return SCM_I_XEVAL (x, env); diff --git a/libguile/feature.c b/libguile/feature.c index e6b212351..ec51a07a9 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -41,7 +41,7 @@ void scm_add_feature (const char *str) { SCM old = SCM_VARIABLE_REF (features_var); - SCM new = scm_cons (scm_str2symbol (str), old); + SCM new = scm_cons (scm_from_locale_symbol (str), old); SCM_VARIABLE_SET (features_var, new); } @@ -71,7 +71,7 @@ scm_set_program_arguments (int argc, char **argv, char *first) { scm_progargs = scm_makfromstrs (argc, argv); if (first) - scm_progargs = scm_cons (scm_makfrom0str (first), scm_progargs); + scm_progargs = scm_cons (scm_from_locale_string (first), scm_progargs); } diff --git a/libguile/filesys.c b/libguile/filesys.c index 403996d04..af3ddc514 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -863,7 +863,7 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0, if (errno != 0) SCM_SYSERROR; - return (rdent ? scm_mem2string (rdent->d_name, NAMLEN (rdent)) + return (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent)) : SCM_EOF_VAL); } } @@ -977,7 +977,7 @@ SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0, errno = save_errno; SCM_SYSERROR; } - result = scm_mem2string (wd, strlen (wd)); + result = scm_from_locale_stringn (wd, strlen (wd)); free (wd); return result; } @@ -1501,14 +1501,14 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, "component, @code{.} is returned.") #define FUNC_NAME s_scm_dirname { - char *s; + const char *s; long int i; unsigned long int len; SCM_VALIDATE_STRING (1, filename); - s = SCM_I_STRING_CHARS (filename); - len = SCM_I_STRING_LENGTH (filename); + s = scm_i_string_chars (filename); + len = scm_i_string_length (filename); i = len - 1; #ifdef __MINGW32__ @@ -1527,12 +1527,12 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, #else if (len > 0 && s[0] == '/') #endif /* ndef __MINGW32__ */ - return scm_substring (filename, SCM_INUM0, scm_from_int (1)); + return scm_c_substring (filename, 0, 1); else return scm_dot_string; } else - return scm_substring (filename, SCM_INUM0, scm_from_int (i + 1)); + return scm_c_substring (filename, 0, i + 1); } #undef FUNC_NAME @@ -1544,20 +1544,20 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, "@var{basename}, it is removed also.") #define FUNC_NAME s_scm_basename { - char *f, *s = 0; + const char *f, *s = 0; int i, j, len, end; SCM_VALIDATE_STRING (1, filename); - f = SCM_I_STRING_CHARS (filename); - len = SCM_I_STRING_LENGTH (filename); + f = scm_i_string_chars (filename); + len = scm_i_string_length (filename); if (SCM_UNBNDP (suffix)) j = -1; else { SCM_VALIDATE_STRING (2, suffix); - s = SCM_I_STRING_CHARS (suffix); - j = SCM_I_STRING_LENGTH (suffix) - 1; + s = scm_i_string_chars (suffix); + j = scm_i_string_length (suffix) - 1; } i = len - 1; #ifdef __MINGW32__ @@ -1581,12 +1581,12 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, #else if (len > 0 && f[0] == '/') #endif /* ndef __MINGW32__ */ - return scm_substring (filename, SCM_INUM0, scm_from_int (1)); + return scm_c_substring (filename, 0, 1); else return scm_dot_string; } else - return scm_substring (filename, scm_from_int (i+1), scm_from_int (end+1)); + return scm_c_substring (filename, i+1, end+1); } #undef FUNC_NAME @@ -1601,7 +1601,7 @@ scm_init_filesys () scm_set_smob_free (scm_tc16_dir, scm_dir_free); scm_set_smob_print (scm_tc16_dir, scm_dir_print); - scm_dot_string = scm_permanent_object (scm_makfrom0str (".")); + scm_dot_string = scm_permanent_object (scm_from_locale_string (".")); #ifdef O_RDONLY scm_c_define ("O_RDONLY", scm_from_long (O_RDONLY)); diff --git a/libguile/fports.c b/libguile/fports.c index ad03ad913..35789ff6e 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -501,7 +501,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { int fdes; SCM name = SCM_FILENAME (exp); - if (scm_is_string (name) || SCM_SYMBOLP (name)) + if (scm_is_string (name) || scm_is_symbol (name)) scm_display (name, port); else scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); diff --git a/libguile/gdbint.c b/libguile/gdbint.c index fe7cd7c94..0a31bf34d 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -285,18 +285,18 @@ scm_init_gdbint () scm_print_carefully_p = 0; port = scm_mkstrport (SCM_INUM0, - scm_make_string (scm_from_int (0), SCM_UNDEFINED), + scm_c_make_string (0, SCM_UNDEFINED), SCM_OPN | SCM_WRTNG, s); gdb_output_port = scm_permanent_object (port); port = scm_mkstrport (SCM_INUM0, - scm_make_string (scm_from_int (0), SCM_UNDEFINED), + scm_c_make_string (0, SCM_UNDEFINED), SCM_OPN | SCM_RDNG | SCM_WRTNG, s); gdb_input_port = scm_permanent_object (port); - tok_buf = scm_permanent_object (scm_allocate_string (30)); + tok_buf = scm_permanent_object (scm_c_make_string (30, SCM_UNDEFINED)); } /* diff --git a/libguile/goops.c b/libguile/goops.c index cc4c98e04..6a595f9d0 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -61,13 +61,14 @@ (v), SCM_BOOL_F))) /* Fixme: Should use already interned symbols */ -#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_str2symbol (name)), \ + +#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \ a)) -#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_str2symbol (name)), \ +#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \ a, b)) -#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_str2symbol (name)), \ +#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \ a, b, c)) -#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_str2symbol (name)), \ +#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \ a, b, c, d)) /* Class redefinition protocol: @@ -218,7 +219,7 @@ remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen) return res; tmp = SCM_CAAR (l); - if (!SCM_SYMBOLP (tmp)) + if (!scm_is_symbol (tmp)) scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp)); if (scm_is_false (scm_c_memq (tmp, slots_already_seen))) { @@ -479,6 +480,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, SCM slots, getters_n_setters, nfields; unsigned long int n, i; char *s; + SCM layout; SCM_VALIDATE_INSTANCE (1, class); slots = SCM_SLOT (class, scm_si_slots); @@ -493,7 +495,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, SCM_MISC_ERROR ("class object doesn't have enough fields: ~S", scm_list_1 (nfields)); - s = n > 0 ? scm_malloc (n) : 0; + layout = scm_i_make_string (n, &s); i = 0; while (SCM_CONSP (getters_n_setters)) { @@ -519,11 +521,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, else { if (!SCM_CLASSP (type)) - { - if (s) - free (s); - SCM_MISC_ERROR ("bad slot class", SCM_EOL); - } + SCM_MISC_ERROR ("bad slot class", SCM_EOL); else if (SCM_SUBCLASSP (type, scm_class_foreign_slot)) { if (SCM_SUBCLASSP (type, scm_class_self)) @@ -564,13 +562,9 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, if (!SCM_NULLP (slots)) { inconsistent: - if (s) - free (s); SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL); } - SCM_SET_SLOT (class, scm_si_layout, scm_mem2symbol (s, n)); - if (s) - free (s); + SCM_SET_SLOT (class, scm_si_layout, scm_string_to_symbol (layout)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -763,9 +757,9 @@ create_basic_classes (void) /* SCM slots_of_class = build_class_class_slots (); */ /**** ****/ - SCM cs = scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT - + 2 * scm_vtable_offset_user); - SCM name = scm_str2symbol (""); + SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT + + 2 * scm_vtable_offset_user); + SCM name = scm_from_locale_symbol (""); scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL)); @@ -791,7 +785,7 @@ create_basic_classes (void) DEFVAR(name, scm_class_class); /**** ****/ - name = scm_str2symbol (""); + name = scm_from_locale_symbol (""); scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class, name, SCM_EOL, @@ -800,7 +794,7 @@ create_basic_classes (void) DEFVAR(name, scm_class_top); /**** ****/ - name = scm_str2symbol (""); + name = scm_from_locale_symbol (""); scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class, name, scm_list_1 (scm_class_top), @@ -977,7 +971,7 @@ SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0, #define FUNC_NAME s_scm_method_generic_function { SCM_VALIDATE_METHOD (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("generic-function")); + return scm_slot_ref (obj, scm_from_locale_symbol ("generic-function")); } #undef FUNC_NAME @@ -987,7 +981,7 @@ SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0, #define FUNC_NAME s_scm_method_specializers { SCM_VALIDATE_METHOD (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("specializers")); + return scm_slot_ref (obj, scm_from_locale_symbol ("specializers")); } #undef FUNC_NAME @@ -1007,7 +1001,7 @@ SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definitio #define FUNC_NAME s_scm_accessor_method_slot_definition { SCM_VALIDATE_ACCESSOR (1, obj); - return scm_slot_ref (obj, scm_str2symbol ("slot-definition")); + return scm_slot_ref (obj, scm_from_locale_symbol ("slot-definition")); } #undef FUNC_NAME @@ -2139,7 +2133,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, scm_i_get_keyword (k_name, args, len - 1, - scm_str2symbol ("???"), + scm_from_locale_symbol ("???"), FUNC_NAME)); SCM_SET_SLOT (z, scm_si_direct_supers, scm_i_get_keyword (k_dsupers, @@ -2234,7 +2228,7 @@ fix_cpl (SCM c, SCM before, SCM after) static void make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) { - SCM tmp = scm_str2symbol (name); + SCM tmp = scm_from_locale_symbol (name); *var = scm_permanent_object (scm_basic_make_class (meta, tmp, @@ -2252,32 +2246,32 @@ static void create_standard_classes (void) { SCM slots; - SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"), - scm_str2symbol ("specializers"), + SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"), + scm_from_locale_symbol ("specializers"), sym_procedure, - scm_str2symbol ("code-table")); - SCM amethod_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"), + scm_from_locale_symbol ("code-table")); + SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"), k_init_keyword, k_slot_definition)); - SCM mutex_slot = scm_list_1 (scm_str2symbol ("make-mutex")); + SCM mutex_slot = scm_list_1 (scm_from_locale_symbol ("make-mutex")); SCM mutex_closure = scm_i_eval_x (scm_list_3 (scm_sym_lambda, SCM_EOL, mutex_slot), SCM_EOL); - SCM gf_slots = scm_list_5 (scm_str2symbol ("methods"), - scm_list_3 (scm_str2symbol ("n-specialized"), + SCM gf_slots = scm_list_5 (scm_from_locale_symbol ("methods"), + scm_list_3 (scm_from_locale_symbol ("n-specialized"), k_init_value, SCM_INUM0), - scm_list_3 (scm_str2symbol ("used-by"), + scm_list_3 (scm_from_locale_symbol ("used-by"), k_init_value, SCM_BOOL_F), - scm_list_3 (scm_str2symbol ("cache-mutex"), + scm_list_3 (scm_from_locale_symbol ("cache-mutex"), k_init_thunk, mutex_closure), - scm_list_3 (scm_str2symbol ("extended-by"), + scm_list_3 (scm_from_locale_symbol ("extended-by"), k_init_value, SCM_EOL)); - SCM egf_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("extends"), + SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"), k_init_value, SCM_EOL)); /* Foreign class slot classes */ @@ -2320,10 +2314,10 @@ create_standard_classes (void) make_stdcls (&scm_class_foreign_class, "", scm_class_class, scm_class_class, - scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"), + scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"), k_class, scm_class_opaque), - scm_list_3 (scm_str2symbol ("destructor"), + scm_list_3 (scm_from_locale_symbol ("destructor"), k_class, scm_class_opaque))); make_stdcls (&scm_class_foreign_object, "", @@ -2450,7 +2444,7 @@ make_class_from_template (char const *template, char const *type_name, SCM super { char buffer[100]; sprintf (buffer, template, type_name); - name = scm_str2symbol (buffer); + name = scm_from_locale_symbol (buffer); } else name = SCM_GOOPS_UNBOUND; @@ -2580,7 +2574,7 @@ make_struct_class (void *closure SCM_UNUSED, if (scm_is_true (SCM_STRUCT_TABLE_NAME (data))) SCM_SET_STRUCT_TABLE_CLASS (data, scm_make_extended_class - (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data)), + (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data)), SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR)); return SCM_UNSPECIFIED; } @@ -2632,7 +2626,7 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, size_t (*destructor) (void *)) { SCM name, class; - name = scm_str2symbol (s_name); + name = scm_from_locale_symbol (s_name); if (SCM_NULLP (supers)) supers = scm_list_1 (scm_class_foreign_object); class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL); @@ -2649,7 +2643,7 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, SCM_SET_CLASS_INSTANCE_SIZE (class, size); } - SCM_SET_SLOT (class, scm_si_layout, scm_str2symbol ("")); + SCM_SET_SLOT (class, scm_si_layout, scm_from_locale_symbol ("")); SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor); return class; @@ -2692,8 +2686,8 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, SCM_EOL); { - SCM name = scm_str2symbol (slot_name); - SCM aname = scm_str2symbol (accessor_name); + SCM name = scm_from_locale_symbol (slot_name); + SCM aname = scm_from_locale_symbol (accessor_name); SCM gf = scm_ensure_accessor (aname); SCM slot = scm_list_5 (name, k_class, @@ -2840,7 +2834,7 @@ scm_init_goops_builtins (void) create_port_classes (); { - SCM name = scm_str2symbol ("no-applicable-method"); + SCM name = scm_from_locale_symbol ("no-applicable-method"); scm_no_applicable_method = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic, k_name, diff --git a/libguile/hash.c b/libguile/hash.c index b2c7fa592..5123c2c15 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -110,13 +110,13 @@ scm_hasher(SCM obj, unsigned long n, size_t d) /* Fall through */ case scm_tc7_string: { - unsigned long hash = scm_string_hash (SCM_I_STRING_UCHARS (obj), - SCM_I_STRING_LENGTH (obj)) % n; + unsigned long hash = scm_string_hash (scm_i_string_chars (obj), + scm_i_string_length (obj)) % n; scm_remember_upto_here_1 (obj); return hash; } case scm_tc7_symbol: - return SCM_SYMBOL_HASH (obj) % n; + return scm_i_symbol_hash (obj) % n; case scm_tc7_wvect: case scm_tc7_vector: { diff --git a/libguile/init.c b/libguile/init.c index 9e09e2587..313f3ff04 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -224,7 +224,7 @@ stream_body (void *data) { stream_body_data *body_data = (stream_body_data *) data; SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode, - scm_makfrom0str (body_data->name)); + scm_from_locale_string (body_data->name)); SCM_REVEALED (port) = 1; return port; @@ -309,12 +309,13 @@ scm_load_startup_files () /* We want a path only containing directories from GUILE_LOAD_PATH, SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init file, so we do this before loading Ice-9. */ - SCM init_path = scm_sys_search_load_path (scm_makfrom0str ("init.scm")); + SCM init_path = + scm_sys_search_load_path (scm_from_locale_string ("init.scm")); /* Load Ice-9. */ if (!scm_ice_9_already_loaded) { - scm_primitive_load_path (scm_makfrom0str ("ice-9/boot-9.scm")); + scm_primitive_load_path (scm_from_locale_string ("ice-9/boot-9.scm")); /* Load the init.scm file. */ if (scm_is_true (init_path)) diff --git a/libguile/keywords.c b/libguile/keywords.c index fb29bb081..fd75d7274 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -28,6 +28,8 @@ #include "libguile/validate.h" #include "libguile/keywords.h" +#include "libguile/strings.h" + scm_t_bits scm_tc16_keyword; @@ -38,8 +40,8 @@ keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) SCM symbol = SCM_KEYWORDSYM (exp); scm_puts ("#:", port); - scm_print_symbol_name (SCM_SYMBOL_CHARS (symbol) + 1, - SCM_SYMBOL_LENGTH (symbol) - 1, + scm_print_symbol_name (scm_i_symbol_chars (symbol) + 1, + scm_i_symbol_length (symbol) - 1, port); scm_remember_upto_here_1 (symbol); return 1; @@ -52,8 +54,8 @@ SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", { SCM keyword; - SCM_ASSERT (SCM_SYMBOLP (symbol) - && ('-' == SCM_SYMBOL_CHARS(symbol)[0]), + SCM_ASSERT (scm_is_symbol (symbol) + && ('-' == scm_i_symbol_chars(symbol)[0]), symbol, SCM_ARG1, FUNC_NAME); SCM_DEFER_INTS; @@ -71,14 +73,15 @@ SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", SCM scm_c_make_keyword (char *s) { - char *buf = scm_malloc (strlen (s) + 2); - SCM symbol; + char *buf; + size_t len; + SCM string, symbol; + len = strlen (s) + 1; + string = scm_i_make_string (len, &buf); buf[0] = '-'; strcpy (buf + 1, s); - symbol = scm_str2symbol (buf); - free (buf); - + symbol = scm_string_to_symbol (string); return scm_make_keyword_from_dash_symbol (symbol); } diff --git a/libguile/load.c b/libguile/load.c index d50211dcf..345f309c8 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -105,7 +105,7 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, { /* scope */ SCM port, save_port; - port = scm_open_file (filename, scm_mem2string ("r", sizeof (char))); + port = scm_open_file (filename, scm_from_locale_string ("r")); save_port = port; scm_internal_dynamic_wind (swap_port, load, @@ -121,7 +121,7 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, SCM scm_c_primitive_load (const char *filename) { - return scm_primitive_load (scm_makfrom0str (filename)); + return scm_primitive_load (scm_from_locale_string (filename)); } @@ -134,7 +134,7 @@ SCM_DEFINE (scm_sys_package_data_dir, "%package-data-dir", 0, 0, 0, "@samp{/usr/local/share/guile}.") #define FUNC_NAME s_scm_sys_package_data_dir { - return scm_makfrom0str (SCM_PKGDATA_DIR); + return scm_from_locale_string (SCM_PKGDATA_DIR); } #undef FUNC_NAME #endif /* SCM_PKGDATA_DIR */ @@ -146,7 +146,7 @@ SCM_DEFINE (scm_sys_library_dir, "%library-dir", 0,0,0, "E.g., may return \"/usr/share/guile/1.3.5\".") #define FUNC_NAME s_scm_sys_library_dir { - return scm_makfrom0str(SCM_LIBRARY_DIR); + return scm_from_locale_string (SCM_LIBRARY_DIR); } #undef FUNC_NAME #endif /* SCM_LIBRARY_DIR */ @@ -158,7 +158,7 @@ SCM_DEFINE (scm_sys_site_dir, "%site-dir", 0,0,0, "E.g., may return \"/usr/share/guile/site\".") #define FUNC_NAME s_scm_sys_site_dir { - return scm_makfrom0str(SCM_SITE_DIR); + return scm_from_locale_string (SCM_SITE_DIR); } #undef FUNC_NAME #endif /* SCM_SITE_DIR */ @@ -208,9 +208,9 @@ scm_init_load_path () SCM path = SCM_EOL; #ifdef SCM_LIBRARY_DIR - path = scm_list_3 (scm_makfrom0str (SCM_SITE_DIR), - scm_makfrom0str (SCM_LIBRARY_DIR), - scm_makfrom0str (SCM_PKGDATA_DIR)); + path = scm_list_3 (scm_from_locale_string (SCM_SITE_DIR), + scm_from_locale_string (SCM_LIBRARY_DIR), + scm_from_locale_string (SCM_PKGDATA_DIR)); #endif /* SCM_LIBRARY_DIR */ env = getenv ("GUILE_LOAD_PATH"); @@ -483,7 +483,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, SCM scm_c_primitive_load_path (const char *filename) { - return scm_primitive_load_path (scm_makfrom0str (filename)); + return scm_primitive_load_path (scm_from_locale_string (filename)); } @@ -499,12 +499,13 @@ init_build_info () unsigned long i; for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++) - *loc = scm_acons (scm_str2symbol (info[i].name), - scm_makfrom0str (info[i].value), - *loc); + { + SCM key = scm_from_locale_symbol (info[i].name); + SCM val = scm_from_locale_string (info[i].value); + *loc = scm_acons (key, val, *loc); + } } - void scm_init_load () @@ -513,8 +514,8 @@ scm_init_load () scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL)); scm_loc_load_extensions = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions", - scm_list_2 (scm_makfrom0str (".scm"), - scm_nullstr))); + scm_list_2 (scm_from_locale_string (".scm"), + scm_nullstr))); scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F)); init_build_info (); diff --git a/libguile/modules.c b/libguile/modules.c index 98f5b8ea6..5049a186c 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998,2000,2001,2002, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1998,2000,2001,2002, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -111,7 +111,8 @@ convert_module_name (const char *name) ptr++; if (ptr > name) { - *tail = scm_cons (scm_mem2symbol (name, ptr-name), SCM_EOL); + SCM sym = scm_from_locale_symboln (name, ptr-name); + *tail = scm_cons (sym, SCM_EOL); tail = SCM_CDRLOC (*tail); } name = ptr; @@ -185,7 +186,7 @@ scm_c_export (const char *name, ...) if (name) { va_list ap; - SCM names = scm_cons (scm_str2symbol (name), SCM_EOL); + SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL); SCM *tail = SCM_CDRLOC (names); va_start (ap, name); while (1) @@ -193,7 +194,7 @@ scm_c_export (const char *name, ...) const char *n = va_arg (ap, const char *); if (n == NULL) break; - *tail = scm_cons (scm_str2symbol (n), SCM_EOL); + *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL); tail = SCM_CDRLOC (*tail); } va_end (ap); @@ -485,7 +486,7 @@ scm_sym2var (SCM sym, SCM proc, SCM definep) SCM scm_c_module_lookup (SCM module, const char *name) { - return scm_module_lookup (module, scm_str2symbol (name)); + return scm_module_lookup (module, scm_from_locale_symbol (name)); } SCM @@ -505,7 +506,7 @@ scm_module_lookup (SCM module, SCM sym) SCM scm_c_lookup (const char *name) { - return scm_lookup (scm_str2symbol (name)); + return scm_lookup (scm_from_locale_symbol (name)); } SCM @@ -521,7 +522,7 @@ scm_lookup (SCM sym) SCM scm_c_module_define (SCM module, const char *name, SCM value) { - return scm_module_define (module, scm_str2symbol (name), value); + return scm_module_define (module, scm_from_locale_symbol (name), value); } SCM @@ -540,7 +541,7 @@ scm_module_define (SCM module, SCM sym, SCM value) SCM scm_c_define (const char *name, SCM value) { - return scm_define (scm_str2symbol (name), value); + return scm_define (scm_from_locale_symbol (name), value); } SCM diff --git a/libguile/net_db.c b/libguile/net_db.c index 41f05a9d7..8b2562d4a 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -174,7 +174,7 @@ SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0, if (!entry) scm_resolv_error (FUNC_NAME, host); - SCM_VECTOR_SET(result, 0, scm_mem2string (entry->h_name, strlen (entry->h_name))); + SCM_VECTOR_SET(result, 0, scm_from_locale_string (entry->h_name)); SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->h_aliases)); SCM_VECTOR_SET(result, 2, scm_from_int (entry->h_addrtype)); SCM_VECTOR_SET(result, 3, scm_from_int (entry->h_length)); @@ -248,7 +248,7 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, if (!entry) SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net), eno); - SCM_VECTOR_SET(result, 0, scm_mem2string (entry->n_name, strlen (entry->n_name))); + SCM_VECTOR_SET(result, 0, scm_from_locale_string (entry->n_name)); SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->n_aliases)); SCM_VECTOR_SET(result, 2, scm_from_int (entry->n_addrtype)); SCM_VECTOR_SET(result, 3, scm_from_ulong (entry->n_net)); @@ -300,7 +300,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, if (!entry) SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol), eno); - SCM_VECTOR_SET(result, 0, scm_mem2string (entry->p_name, strlen (entry->p_name))); + SCM_VECTOR_SET(result, 0, scm_from_locale_string (entry->p_name)); SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->p_aliases)); SCM_VECTOR_SET(result, 2, scm_from_int (entry->p_proto)); return result; @@ -314,10 +314,10 @@ scm_return_entry (struct servent *entry) { SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED); - SCM_VECTOR_SET(result, 0, scm_mem2string (entry->s_name, strlen (entry->s_name))); + SCM_VECTOR_SET(result, 0, scm_from_locale_string (entry->s_name)); SCM_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->s_aliases)); SCM_VECTOR_SET(result, 2, scm_from_uint16 (ntohs (entry->s_port))); - SCM_VECTOR_SET(result, 3, scm_mem2string (entry->s_proto, strlen (entry->s_proto))); + SCM_VECTOR_SET(result, 3, scm_from_locale_string (entry->s_proto)); return result; } diff --git a/libguile/numbers.c b/libguile/numbers.c index a50ca8889..966aa0d33 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2286,25 +2286,25 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, { char num_buf [SCM_INTBUFLEN]; size_t length = scm_iint2str (SCM_I_INUM (n), base, num_buf); - return scm_mem2string (num_buf, length); + return scm_from_locale_stringn (num_buf, length); } else if (SCM_BIGP (n)) { char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n)); scm_remember_upto_here_1 (n); - return scm_take0str (str); + return scm_take_locale_string (str); } else if (SCM_FRACTIONP (n)) { scm_i_fraction_reduce (n); return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix), - scm_mem2string ("/", 1), + scm_from_locale_string ("/"), scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix))); } else if (SCM_INEXACTP (n)) { char num_buf [FLOBUFLEN]; - return scm_mem2string (num_buf, iflo2str (n, num_buf, base)); + return scm_from_locale_stringn (num_buf, iflo2str (n, num_buf, base)); } else SCM_WRONG_TYPE_ARG (1, n); @@ -2338,7 +2338,7 @@ scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) SCM str; scm_i_fraction_reduce (sexp); str = scm_number_to_string (sexp, SCM_UNDEFINED); - scm_lfwrite (SCM_I_STRING_CHARS (str), SCM_I_STRING_LENGTH (str), port); + scm_lfwrite (scm_i_string_chars (str), scm_i_string_length (str), port); scm_remember_upto_here_1 (str); return !0; } @@ -2596,7 +2596,7 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, if (exponent > SCM_MAXEXP) { size_t exp_len = idx - start; - SCM exp_string = scm_mem2string (&mem[start], exp_len); + SCM exp_string = scm_from_locale_stringn (&mem[start], exp_len); SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED); scm_out_of_range ("string->number", exp_num); } @@ -2967,8 +2967,8 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, else base = scm_to_unsigned_integer (radix, 2, INT_MAX); - answer = scm_i_mem2number (SCM_I_STRING_CHARS (string), - SCM_I_STRING_LENGTH (string), + answer = scm_i_mem2number (scm_i_string_chars (string), + scm_i_string_length (string), base); scm_remember_upto_here_1 (string); return answer; diff --git a/libguile/objects.c b/libguile/objects.c index 519a7ecf5..449976a1d 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1999,2000,2001, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -170,7 +170,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, { SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle)); SCM class = scm_make_extended_class (scm_is_true (name) - ? SCM_SYMBOL_CHARS (name) + ? scm_i_symbol_chars (name) : 0, SCM_I_OPERATORP (x)); SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); @@ -468,8 +468,7 @@ SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, SCM_VALIDATE_STRUCT (1, class); SCM_VALIDATE_STRING (2, layout); pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]); - /* Convert symbol->string */ - pl = scm_mem2string (SCM_SYMBOL_CHARS (pl), SCM_SYMBOL_LENGTH (pl)); + pl = scm_symbol_to_string (pl); return scm_i_make_class_object (SCM_STRUCT_VTABLE (class), scm_string_append (scm_list_2 (pl, layout)), SCM_CLASS_FLAGS (class)); @@ -479,15 +478,15 @@ SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, void scm_init_objects () { - SCM ms = scm_makfrom0str (SCM_METACLASS_STANDARD_LAYOUT); + SCM ms = scm_from_locale_string (SCM_METACLASS_STANDARD_LAYOUT); SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0, scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); - SCM os = scm_makfrom0str (SCM_METACLASS_OPERATOR_LAYOUT); + SCM os = scm_from_locale_string (SCM_METACLASS_OPERATOR_LAYOUT); SCM ot = scm_make_vtable_vtable (os, SCM_INUM0, scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); - SCM es = scm_makfrom0str (SCM_ENTITY_LAYOUT); + SCM es = scm_from_locale_string (SCM_ENTITY_LAYOUT); SCM el = scm_make_struct_layout (es); SCM et = scm_make_struct (mt, SCM_INUM0, scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL)); diff --git a/libguile/options.c b/libguile/options.c index 4c53611a3..34e0bef99 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -130,7 +130,7 @@ get_documented_option_setting (const scm_t_option options[], unsigned int n) for (i = 0; i != n; ++i) { - SCM ls = scm_cons (scm_str2string (options[i].doc), SCM_EOL); + SCM ls = scm_cons (scm_from_locale_string (options[i].doc), SCM_EOL); switch (options[i].type) { case SCM_OPTION_BOOLEAN: @@ -252,7 +252,7 @@ scm_init_opts (SCM (*func) (SCM), scm_t_option options[], unsigned int n) for (i = 0; i != n; ++i) { - SCM name = scm_str2symbol (options[i].name); + SCM name = scm_from_locale_symbol (options[i].name); options[i].name = (char *) SCM_UNPACK (name); scm_permanent_object (name); } diff --git a/libguile/posix.c b/libguile/posix.c index 37b46bdaf..bb78a18ae 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -355,19 +355,19 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, if (!entry) SCM_MISC_ERROR ("entry not found", SCM_EOL); - SCM_VECTOR_SET(result, 0, scm_makfrom0str (entry->pw_name)); - SCM_VECTOR_SET(result, 1, scm_makfrom0str (entry->pw_passwd)); + SCM_VECTOR_SET(result, 0, scm_from_locale_string (entry->pw_name)); + SCM_VECTOR_SET(result, 1, scm_from_locale_string (entry->pw_passwd)); SCM_VECTOR_SET(result, 2, scm_from_ulong (entry->pw_uid)); SCM_VECTOR_SET(result, 3, scm_from_ulong (entry->pw_gid)); - SCM_VECTOR_SET(result, 4, scm_makfrom0str (entry->pw_gecos)); + SCM_VECTOR_SET(result, 4, scm_from_locale_string (entry->pw_gecos)); if (!entry->pw_dir) - SCM_VECTOR_SET(result, 5, scm_makfrom0str ("")); + SCM_VECTOR_SET(result, 5, scm_from_locale_string ("")); else - SCM_VECTOR_SET(result, 5, scm_makfrom0str (entry->pw_dir)); + SCM_VECTOR_SET(result, 5, scm_from_locale_string (entry->pw_dir)); if (!entry->pw_shell) - SCM_VECTOR_SET(result, 6, scm_makfrom0str ("")); + SCM_VECTOR_SET(result, 6, scm_from_locale_string ("")); else - SCM_VECTOR_SET(result, 6, scm_makfrom0str (entry->pw_shell)); + SCM_VECTOR_SET(result, 6, scm_from_locale_string (entry->pw_shell)); return result; } #undef FUNC_NAME @@ -420,8 +420,8 @@ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0, if (!entry) SCM_SYSERROR; - SCM_VECTOR_SET(result, 0, scm_makfrom0str (entry->gr_name)); - SCM_VECTOR_SET(result, 1, scm_makfrom0str (entry->gr_passwd)); + SCM_VECTOR_SET(result, 0, scm_from_locale_string (entry->gr_name)); + SCM_VECTOR_SET(result, 1, scm_from_locale_string (entry->gr_passwd)); SCM_VECTOR_SET(result, 2, scm_from_ulong (entry->gr_gid)); SCM_VECTOR_SET(result, 3, scm_makfromstrs (-1, entry->gr_mem)); return result; @@ -820,7 +820,7 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0, scm_mutex_lock (&scm_i_misc_mutex); SCM_SYSCALL (result = ttyname (fd)); err = errno; - ret = scm_makfrom0str (result); + ret = scm_from_locale_string (result); scm_mutex_unlock (&scm_i_misc_mutex); if (!result) @@ -850,7 +850,7 @@ SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0, char *result = ctermid (buf); if (*result == '\0') SCM_SYSERROR; - return scm_makfrom0str (result); + return scm_from_locale_string (result); } #undef FUNC_NAME #endif /* HAVE_CTERMID */ @@ -1051,14 +1051,14 @@ SCM_DEFINE (scm_uname, "uname", 0, 0, 0, SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED); if (uname (&buf) < 0) SCM_SYSERROR; - SCM_VECTOR_SET(result, 0, scm_makfrom0str (buf.sysname)); - SCM_VECTOR_SET(result, 1, scm_makfrom0str (buf.nodename)); - SCM_VECTOR_SET(result, 2, scm_makfrom0str (buf.release)); - SCM_VECTOR_SET(result, 3, scm_makfrom0str (buf.version)); - SCM_VECTOR_SET(result, 4, scm_makfrom0str (buf.machine)); + SCM_VECTOR_SET(result, 0, scm_from_locale_string (buf.sysname)); + SCM_VECTOR_SET(result, 1, scm_from_locale_string (buf.nodename)); + SCM_VECTOR_SET(result, 2, scm_from_locale_string (buf.release)); + SCM_VECTOR_SET(result, 3, scm_from_locale_string (buf.version)); + SCM_VECTOR_SET(result, 4, scm_from_locale_string (buf.machine)); /* a linux special? - SCM_VECTOR_SET(result, 5, scm_makfrom0str (buf.domainname)); + SCM_VECTOR_SET(result, 5, scm_from_locale_string (buf.domainname)); */ return result; } @@ -1116,7 +1116,7 @@ SCM_DEFINE (scm_tmpnam, "tmpnam", 0, 0, 0, if (rv == NULL) /* not SCM_SYSERROR since errno probably not set. */ SCM_MISC_ERROR ("tmpnam failed", SCM_EOL); - return scm_makfrom0str (name); + return scm_from_locale_string (name); } #undef FUNC_NAME @@ -1369,13 +1369,13 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, #define FUNC_NAME s_scm_mknod { int val; - char *p; + const char *p; int ctype = 0; SCM_VALIDATE_STRING (1, path); SCM_VALIDATE_SYMBOL (2, type); - p = SCM_SYMBOL_CHARS (type); + p = scm_i_symbol_chars (type); if (strcmp (p, "regular") == 0) ctype = S_IFREG; else if (strcmp (p, "directory") == 0) @@ -1530,7 +1530,7 @@ SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0, p = getlogin (); if (!p || !*p) return SCM_BOOL_F; - return scm_makfrom0str (p); + return scm_from_locale_string (p); } #undef FUNC_NAME #endif /* HAVE_GETLOGIN */ @@ -1549,7 +1549,7 @@ SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0, p = cuserid (buf); if (!p || !*p) return SCM_BOOL_F; - return scm_makfrom0str (p); + return scm_from_locale_string (p); } #undef FUNC_NAME #endif /* HAVE_CUSERID */ @@ -1839,8 +1839,8 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, } else { - /* scm_makfrom0str may throw an exception. */ - const SCM name = scm_makfrom0str (p); + /* scm_from_locale_string may throw an exception. */ + const SCM name = scm_from_locale_string (p); // No guile exceptions can occur before we have freed p's memory. scm_frame_end (); diff --git a/libguile/print.c b/libguile/print.c index 0b69ebd0e..cfae921bd 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-1999,2000,2001, 2002, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -484,12 +484,15 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_string: if (SCM_WRITINGP (pstate)) { - size_t i; + size_t i, len; + const char *data; scm_putc ('"', port); - for (i = 0; i < SCM_I_STRING_LENGTH (exp); ++i) + len = scm_i_string_length (exp); + data = scm_i_string_chars (exp); + for (i = 0; i < len; ++i) { - unsigned char ch = SCM_I_STRING_CHARS (exp)[i]; + unsigned char ch = data[i]; if ((ch < 32 && ch != '\n') || (127 <= ch && ch < 148)) { static char const hex[]="0123456789abcdef"; @@ -506,25 +509,26 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) } } scm_putc ('"', port); + scm_remember_upto_here_1 (exp); } else - scm_lfwrite (SCM_I_STRING_CHARS (exp), SCM_I_STRING_LENGTH (exp), + scm_lfwrite (scm_i_string_chars (exp), scm_i_string_length (exp), port); scm_remember_upto_here_1 (exp); break; case scm_tc7_symbol: - if (SCM_SYMBOL_INTERNED_P (exp)) + if (scm_i_symbol_is_interned (exp)) { - scm_print_symbol_name (SCM_SYMBOL_CHARS (exp), - SCM_SYMBOL_LENGTH (exp), + scm_print_symbol_name (scm_i_symbol_chars (exp), + scm_i_symbol_length (exp), port); scm_remember_upto_here_1 (exp); } else { scm_puts ("#', port); break; #ifdef CCLO @@ -607,7 +611,7 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) if (scm_is_true (name)) { scm_putc (' ', port); - scm_puts (SCM_SYMBOL_CHARS (name), port); + scm_puts (scm_i_symbol_chars (name), port); } } else @@ -913,9 +917,9 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, SCM port, answer = SCM_UNSPECIFIED; int fReturnString = 0; int writingp; - char *start; - char *end; - char *p; + const char *start; + const char *end; + const char *p; if (scm_is_eq (destination, SCM_BOOL_T)) { @@ -938,8 +942,8 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, SCM_VALIDATE_STRING (2, message); SCM_VALIDATE_REST_ARGUMENT (args); - start = SCM_I_STRING_CHARS (message); - end = start + SCM_I_STRING_LENGTH (message); + start = scm_i_string_chars (message); + end = start + scm_i_string_length (message); for (p = start; p != end; ++p) if (*p == '~') { @@ -1102,9 +1106,10 @@ scm_init_print () scm_gc_register_root (&print_state_pool); scm_gc_register_root (&scm_print_state_vtable); vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); - layout = scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)); + layout = + scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT)); type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout)); - scm_set_struct_vtable_name_x (type, scm_str2symbol ("print-state")); + scm_set_struct_vtable_name_x (type, scm_from_locale_symbol ("print-state")); scm_print_state_vtable = type; /* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */ diff --git a/libguile/procs.c b/libguile/procs.c index a625b6e30..4a233dde6 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -63,7 +63,7 @@ scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) entry = scm_subr_table_size; z = scm_cell ((entry << 8) + type, (scm_t_bits) fcn); scm_subr_table[entry].handle = z; - scm_subr_table[entry].name = scm_str2symbol (name); + scm_subr_table[entry].name = scm_from_locale_symbol (name); scm_subr_table[entry].generic = 0; scm_subr_table[entry].properties = SCM_EOL; scm_subr_table_size++; diff --git a/libguile/ramap.c b/libguile/ramap.c index 49ec40f11..fc88a824e 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -468,8 +468,12 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) break; case scm_tc7_string: SCM_ASRTGO (SCM_CHARP (fill), badarg2); - for (i = base; n--; i += inc) - SCM_I_STRING_CHARS (ra)[i] = SCM_CHAR (fill); + { + char *data = scm_i_string_writable_chars (ra); + for (i = base; n--; i += inc) + data[i] = SCM_CHAR (fill); + scm_i_string_stop_writing (); + } break; case scm_tc7_byvect: if (SCM_CHARP (fill)) @@ -630,8 +634,13 @@ racp (SCM src, SCM dst) case scm_tc7_string: if (SCM_TYP7 (src) != scm_tc7_string) goto gencase; - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - SCM_I_STRING_CHARS (dst)[i_d] = SCM_I_STRING_CHARS (src)[i_s]; + { + char *dst_data = scm_i_string_writable_chars (dst); + const char *src_data = scm_i_string_chars (src); + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + dst_data[i_d] = src_data[i_s]; + scm_i_string_stop_writing (); + } break; case scm_tc7_byvect: if (SCM_TYP7 (src) != scm_tc7_byvect) @@ -1791,8 +1800,8 @@ raeql_1 (SCM ra0, SCM as_equal, SCM ra1) return 1; case scm_tc7_string: { - char *v0 = SCM_I_STRING_CHARS (ra0) + i0; - char *v1 = SCM_I_STRING_CHARS (ra1) + i1; + const char *v0 = scm_i_string_chars (ra0) + i0; + const char *v1 = scm_i_string_chars (ra1) + i1; for (; n--; v0 += inc0, v1 += inc1) if (*v0 != *v1) return 0; @@ -2015,7 +2024,7 @@ init_raprocs (ra_iproc *subra) { for (; subra->name; subra++) { - SCM sym = scm_str2symbol (subra->name); + SCM sym = scm_from_locale_symbol (subra->name); SCM var = scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F); if (var != SCM_BOOL_F) diff --git a/libguile/random.c b/libguile/random.c index bb8d48355..6efde1be5 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -119,7 +119,7 @@ scm_i_uniform32 (scm_t_i_rstate *state) #endif void -scm_i_init_rstate (scm_t_i_rstate *state, char *seed, int n) +scm_i_init_rstate (scm_t_i_rstate *state, const char *seed, int n) { scm_t_int32 w = 0L; scm_t_int32 c = 0L; @@ -153,7 +153,7 @@ scm_i_copy_rstate (scm_t_i_rstate *state) */ scm_t_rstate * -scm_c_make_rstate (char *seed, int n) +scm_c_make_rstate (const char *seed, int n) { scm_t_rstate *state = scm_malloc (scm_the_rng.rstate_size); if (state == 0) @@ -328,7 +328,7 @@ rstate_free (SCM rstate) * Scheme level interface. */ -SCM_GLOBAL_VARIABLE_INIT (scm_var_random_state, "*random-state*", scm_seed_to_random_state (scm_makfrom0str ("URL:http://stat.fsu.edu/~geo/diehard.html"))); +SCM_GLOBAL_VARIABLE_INIT (scm_var_random_state, "*random-state*", scm_seed_to_random_state (scm_from_locale_string ("URL:http://stat.fsu.edu/~geo/diehard.html"))); SCM_DEFINE (scm_random, "random", 1, 1, 0, (SCM n, SCM state), @@ -387,8 +387,8 @@ SCM_DEFINE (scm_seed_to_random_state, "seed->random-state", 1, 0, 0, if (SCM_NUMBERP (seed)) seed = scm_number_to_string (seed, SCM_UNDEFINED); SCM_VALIDATE_STRING (1, seed); - res = make_rstate (scm_c_make_rstate (SCM_I_STRING_CHARS (seed), - SCM_I_STRING_LENGTH (seed))); + res = make_rstate (scm_c_make_rstate (scm_i_string_chars (seed), + scm_i_string_length (seed))); scm_remember_upto_here_1 (seed); return res; diff --git a/libguile/random.h b/libguile/random.h index 8620c3738..ff0b08c6f 100644 --- a/libguile/random.h +++ b/libguile/random.h @@ -46,7 +46,7 @@ typedef struct scm_t_rstate { typedef struct scm_t_rng { size_t rstate_size; /* size of random state */ unsigned long (*random_bits) (scm_t_rstate *state); /* gives 32 random bits */ - void (*init_rstate) (scm_t_rstate *state, char *seed, int n); + void (*init_rstate) (scm_t_rstate *state, const char *seed, int n); scm_t_rstate *(*copy_rstate) (scm_t_rstate *state); } scm_t_rng; @@ -63,14 +63,14 @@ typedef struct scm_t_i_rstate { } scm_t_i_rstate; SCM_API unsigned long scm_i_uniform32 (scm_t_i_rstate *); -SCM_API void scm_i_init_rstate (scm_t_i_rstate *, char *seed, int n); +SCM_API void scm_i_init_rstate (scm_t_i_rstate *, const char *seed, int n); SCM_API scm_t_i_rstate *scm_i_copy_rstate (scm_t_i_rstate *); /* * Random number library functions */ -SCM_API scm_t_rstate *scm_c_make_rstate (char *, int); +SCM_API scm_t_rstate *scm_c_make_rstate (const char *, int); SCM_API scm_t_rstate *scm_c_default_rstate (void); #define scm_c_uniform32(RSTATE) scm_the_rng.random_bits (RSTATE) SCM_API double scm_c_uniform01 (scm_t_rstate *); diff --git a/libguile/rdelim.c b/libguile/rdelim.c index 3967a1d72..98e88779e 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -56,20 +56,18 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, #define FUNC_NAME s_scm_read_delimited_x { size_t j; - char *buf; size_t cstart; size_t cend; int c; - char *cdelims; + const char *cdelims; size_t num_delims; SCM_VALIDATE_STRING (1, delims); - cdelims = SCM_I_STRING_CHARS (delims); - num_delims = SCM_I_STRING_LENGTH (delims); + cdelims = scm_i_string_chars (delims); + num_delims = scm_i_string_length (delims); SCM_VALIDATE_STRING (2, str); - buf = SCM_I_STRING_CHARS (str); - scm_i_get_substring_spec (SCM_I_STRING_LENGTH (str), + scm_i_get_substring_spec (scm_i_string_length (str), start, &cstart, end, &cend); if (SCM_UNBNDP (port)) @@ -97,7 +95,7 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, return scm_cons (SCM_EOF_VAL, scm_from_size_t (j - cstart)); - buf[j] = c; + scm_c_string_set_x (str, j, SCM_MAKE_CHAR (c)); } return scm_cons (SCM_BOOL_F, scm_from_size_t (j - cstart)); } @@ -227,14 +225,14 @@ SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0, { term = SCM_MAKE_CHAR ('\n'); s[slen-1] = '\0'; - line = scm_take_str (s, slen-1); + line = scm_take_locale_stringn (s, slen-1); SCM_INCLINE (port); } else { /* Fix: we should check for eof on the port before assuming this. */ term = SCM_EOF_VAL; - line = scm_take_str (s, slen); + line = scm_take_locale_stringn (s, slen); SCM_COL (port) += slen; } } diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index a79fde6c6..9587dfa0e 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -82,32 +82,21 @@ regex_free (SCM obj) SCM_SYMBOL (scm_regexp_error_key, "regular-expression-syntax"); -static char * +static SCM scm_regexp_error_msg (int regerrno, regex_t *rx) { - SCM errmsg; + char *errmsg; int l; - /* FIXME: must we wrap any external calls in SCM_DEFER_INTS...SCM_ALLOW_INTS? - Or are these only necessary when a SCM object may be left in an - undetermined state (half-formed)? If the latter then I believe we - may do without the critical section code. -twp */ - - /* We could simply make errmsg a char pointer, and allocate space with - malloc. But since we are about to pass the pointer to scm_error, which - never returns, we would never have the opportunity to free it. Creating - it as a SCM object means that the system will GC it at some point. */ - - errmsg = scm_make_string (scm_from_int (80), SCM_UNDEFINED); - SCM_DEFER_INTS; - l = regerror (regerrno, rx, SCM_I_STRING_CHARS (errmsg), 80); + errmsg = scm_malloc (80); + l = regerror (regerrno, rx, errmsg, 80); if (l > 80) { - errmsg = scm_make_string (scm_from_int (l), SCM_UNDEFINED); - regerror (regerrno, rx, SCM_I_STRING_CHARS (errmsg), l); + free (errmsg); + errmsg = scm_malloc (l); + regerror (regerrno, rx, errmsg, l); } - SCM_ALLOW_INTS; - return SCM_I_STRING_CHARS (errmsg); + return scm_take_locale_string (errmsg); } SCM_DEFINE (scm_regexp_p, "regexp?", 1, 0, 0, @@ -164,6 +153,7 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, SCM flag; regex_t *rx; int status, cflags; + char *c_pat; SCM_VALIDATE_STRING (1, pat); SCM_VALIDATE_REST_ARGUMENT (flags); @@ -182,19 +172,21 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, } rx = scm_gc_malloc (sizeof(regex_t), "regex"); - status = regcomp (rx, SCM_I_STRING_CHARS (pat), + c_pat = scm_to_locale_string (pat); + status = regcomp (rx, c_pat, /* Make sure they're not passing REG_NOSUB; regexp-exec assumes we're getting match data. */ cflags & ~REG_NOSUB); + free (c_pat); if (status != 0) { - char *errmsg = scm_regexp_error_msg (status, rx); + SCM errmsg = scm_regexp_error_msg (status, rx); scm_gc_free (rx, sizeof(regex_t), "regex"); - scm_error (scm_regexp_error_key, - FUNC_NAME, - errmsg, - SCM_BOOL_F, - SCM_BOOL_F); + scm_error_scm (scm_regexp_error_key, + scm_from_locale_string (FUNC_NAME), + errmsg, + SCM_BOOL_F, + SCM_BOOL_F); /* never returns */ } SCM_RETURN_NEWSMOB (scm_tc16_regex, rx); @@ -234,7 +226,7 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, if (SCM_UNBNDP (start)) offset = 0; else - offset = scm_to_signed_integer (start, 0, SCM_I_STRING_LENGTH (str)); + offset = scm_to_signed_integer (start, 0, scm_i_string_length (str)); if (SCM_UNBNDP (flags)) flags = SCM_INUM0; @@ -245,7 +237,7 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, nmatches = SCM_RGX(rx)->re_nsub + 1; SCM_DEFER_INTS; matches = scm_malloc (sizeof (regmatch_t) * nmatches); - status = regexec (SCM_RGX (rx), SCM_I_STRING_CHARS (str) + offset, + status = regexec (SCM_RGX (rx), scm_i_string_chars (str) + offset, nmatches, matches, scm_to_int (flags)); if (!status) @@ -268,11 +260,11 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, SCM_ALLOW_INTS; if (status != 0 && status != REG_NOMATCH) - scm_error (scm_regexp_error_key, - FUNC_NAME, - scm_regexp_error_msg (status, SCM_RGX (rx)), - SCM_BOOL_F, - SCM_BOOL_F); + scm_error_scm (scm_regexp_error_key, + scm_from_locale_string (FUNC_NAME), + scm_regexp_error_msg (status, SCM_RGX (rx)), + SCM_BOOL_F, + SCM_BOOL_F); return mvec; } #undef FUNC_NAME diff --git a/libguile/rw.c b/libguile/rw.c index 23b562d8f..06b683fd8 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -111,8 +111,7 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, size_t last; SCM_VALIDATE_STRING (1, str); - dest = SCM_I_STRING_CHARS (str); - scm_i_get_substring_spec (SCM_I_STRING_LENGTH (str), + scm_i_get_substring_spec (scm_i_string_length (str), start, &offset, end, &last); dest += offset; read_len = last - offset; @@ -131,14 +130,18 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0, don't touch the file descriptor. otherwise the "return immediately if something is available" rule may be violated. */ + dest = scm_i_string_writable_chars (str); chars_read = scm_take_from_input_buffers (port, dest, read_len); + scm_i_string_stop_writing (); fdes = SCM_FPORT_FDES (port); } if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with EOF. */ { + dest = scm_i_string_writable_chars (str); SCM_SYSCALL (chars_read = read (fdes, dest, read_len)); + scm_i_string_stop_writing (); if (chars_read == -1) { if (SCM_EBLOCK (errno)) @@ -202,7 +205,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, "@end itemize") #define FUNC_NAME s_scm_write_string_partial { - char *src; + const char *src; long write_len; int fdes; @@ -211,8 +214,8 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, size_t last; SCM_VALIDATE_STRING (1, str); - src = SCM_I_STRING_CHARS (str); - scm_i_get_substring_spec (SCM_I_STRING_LENGTH (str), + src = scm_i_string_chars (str); + scm_i_get_substring_spec (scm_i_string_length (str), start, &offset, end, &last); src += offset; write_len = last - offset; diff --git a/libguile/script.c b/libguile/script.c index a8a84185f..5b62d65ce 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -451,13 +451,13 @@ scm_compile_shell_switches (int argc, char **argv) (i.e., the #f) with the script name. */ if (!SCM_NULLP (do_script)) { - SCM_SETCAR (do_script, scm_makfrom0str (argv[i])); + SCM_SETCAR (do_script, scm_from_locale_string (argv[i])); do_script = SCM_EOL; } else /* Construct an application of LOAD to the script name. */ tail = scm_cons (scm_cons2 (sym_load, - scm_makfrom0str (argv[i]), + scm_from_locale_string (argv[i]), SCM_EOL), tail); argv0 = argv[i]; @@ -471,7 +471,7 @@ scm_compile_shell_switches (int argc, char **argv) if (++i >= argc) scm_shell_usage (1, "missing argument to `-c' switch"); tail = scm_cons (scm_cons2 (sym_eval_string, - scm_makfrom0str (argv[i]), + scm_from_locale_string (argv[i]), SCM_EOL), tail); i++; @@ -489,7 +489,7 @@ scm_compile_shell_switches (int argc, char **argv) { if (++i < argc) tail = scm_cons (scm_cons2 (sym_load, - scm_makfrom0str (argv[i]), + scm_from_locale_string (argv[i]), SCM_EOL), tail); else diff --git a/libguile/snarf.h b/libguile/snarf.h index b9cbb056c..4ec1c3342 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -3,7 +3,7 @@ #ifndef SCM_SNARF_H #define SCM_SNARF_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -175,11 +175,11 @@ SCM_SNARF_INIT(scm_make_synt (RANAME, TYPE, CFN)) #define SCM_SYMBOL(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (scm_str2symbol (scheme_name))) +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_symbol (scheme_name))) #define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \ SCM_SNARF_HERE(SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (scm_str2symbol (scheme_name))) +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_symbol (scheme_name))) #define SCM_KEYWORD(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ diff --git a/libguile/socket.c b/libguile/socket.c index 374c162c7..a092962b1 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -163,7 +163,7 @@ SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0, SCM answer; addr.s_addr = htonl (SCM_NUM2ULONG (1, inetid)); s = inet_ntoa (addr); - answer = scm_mem2string (s, strlen (s)); + answer = scm_from_locale_string (s); return answer; } #undef FUNC_NAME @@ -453,7 +453,7 @@ SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0, scm_to_ipv6 (addr6, address); if (inet_ntop (af, &addr6, dst, sizeof dst) == NULL) SCM_SYSERROR; - return scm_makfrom0str (dst); + return scm_from_locale_string (dst); } #undef FUNC_NAME #endif @@ -1000,8 +1000,7 @@ scm_addr_vector (const struct sockaddr *address, int addr_size, if (addr_size <= offsetof (struct sockaddr_un, sun_path)) SCM_VECTOR_SET(result, 1, SCM_BOOL_F); else - SCM_VECTOR_SET(result, 1, scm_mem2string (nad->sun_path, - strlen (nad->sun_path))); + SCM_VECTOR_SET(result, 1, scm_from_locale_string (nad->sun_path)); } break; #endif @@ -1134,6 +1133,8 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, int rv; int fd; int flg; + char *dest; + size_t len; SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_STRING (2, buf); @@ -1143,9 +1144,11 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, flg = scm_to_int (flags); fd = SCM_FPORT_FDES (sock); - SCM_SYSCALL (rv = recv (fd, - SCM_I_STRING_CHARS (buf), SCM_I_STRING_LENGTH (buf), - flg)); + len = scm_i_string_length (buf); + dest = scm_i_string_writable_chars (buf); + SCM_SYSCALL (rv = recv (fd, dest, len, flg)); + scm_i_string_stop_writing (); + if (rv == -1) SCM_SYSERROR; @@ -1173,6 +1176,8 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, int rv; int fd; int flg; + const char *src; + size_t len; sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); @@ -1183,10 +1188,11 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, flg = scm_to_int (flags); fd = SCM_FPORT_FDES (sock); - SCM_SYSCALL (rv = send (fd, - SCM_I_STRING_CHARS (message), - SCM_I_STRING_LENGTH (message), - flg)); + len = scm_i_string_length (message); + src = scm_i_string_writable_chars (message); + SCM_SYSCALL (rv = send (fd, src, len, flg)); + scm_i_string_stop_writing (); + if (rv == -1) SCM_SYSERROR; @@ -1233,8 +1239,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, fd = SCM_FPORT_FDES (sock); SCM_VALIDATE_STRING (2, str); - buf = SCM_I_STRING_CHARS (str); - scm_i_get_substring_spec (SCM_I_STRING_LENGTH (str), + scm_i_get_substring_spec (scm_i_string_length (str), start, &offset, end, &cend); if (SCM_UNBNDP (flags)) @@ -1244,10 +1249,13 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, /* recvfrom will not necessarily return an address. usually nothing is returned for stream sockets. */ + buf = scm_i_string_writable_chars (str); addr->sa_family = AF_UNSPEC; SCM_SYSCALL (rv = recvfrom (fd, buf + offset, cend - offset, flg, addr, &addr_size)); + scm_i_string_stop_writing (); + if (rv == -1) SCM_SYSERROR; if (addr->sa_family != AF_UNSPEC) @@ -1301,8 +1309,8 @@ SCM_DEFINE (scm_sendto, "sendto", 4, 0, 1, flg = SCM_NUM2ULONG (5, SCM_CAR (args_and_flags)); } SCM_SYSCALL (rv = sendto (fd, - SCM_I_STRING_CHARS (message), - SCM_I_STRING_LENGTH (message), + scm_i_string_chars (message), + scm_i_string_length (message), flg, soka, size)); if (rv == -1) { diff --git a/libguile/stacks.c b/libguile/stacks.c index 387fc57fd..c6c316fad 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -744,13 +744,14 @@ scm_init_stacks () { SCM vtable; SCM stack_layout - = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT)); + = scm_make_struct_layout (scm_from_locale_string (SCM_STACK_LAYOUT)); vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); scm_stack_type = scm_permanent_object (scm_make_struct (vtable, SCM_INUM0, scm_cons (stack_layout, SCM_EOL))); - scm_set_struct_vtable_name_x (scm_stack_type, scm_str2symbol ("stack")); + scm_set_struct_vtable_name_x (scm_stack_type, + scm_from_locale_symbol ("stack")); #include "libguile/stacks.x" } diff --git a/libguile/stime.c b/libguile/stime.c index f08ae28b5..b850dc2b1 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -32,6 +32,7 @@ #include "libguile/feature.h" #include "libguile/strings.h" #include "libguile/vectors.h" +#include "libguile/dynwind.h" #include "libguile/validate.h" #include "libguile/stime.h" @@ -274,7 +275,9 @@ filltime (struct tm *bd_time, int zoff, const char *zname) SCM_VECTOR_SET (result,7, scm_from_int (bd_time->tm_yday)); SCM_VECTOR_SET (result,8, scm_from_int (bd_time->tm_isdst)); SCM_VECTOR_SET (result,9, scm_from_int (zoff)); - SCM_VECTOR_SET (result,10, zname ? scm_makfrom0str (zname) : SCM_BOOL_F); + SCM_VECTOR_SET (result,10, (zname + ? scm_from_locale_string (zname) + : SCM_BOOL_F)); return result; } @@ -480,7 +483,7 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) if (scm_is_false (velts[10])) lt->tm_zone = NULL; else - lt->tm_zone = SCM_STRING_CHARS (velts[10]); + lt->tm_zone = scm_to_locale_string (velts[10]); #endif } @@ -503,7 +506,10 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, char **oldenv; int err; + scm_frame_begin (0); + bdtime2c (sbd_time, <, SCM_ARG1, FUNC_NAME); + scm_frame_free ((char *)lt.tm_zone); SCM_DEFER_INTS; oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); @@ -560,6 +566,8 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, SCM_ALLOW_INTS; if (zname) free (zname); + + scm_frame_end (); return result; } #undef FUNC_NAME @@ -594,15 +602,16 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, char *tbuf; int size = 50; - char *fmt, *myfmt; + const char *fmt; + char *myfmt; int len; SCM result; SCM_VALIDATE_STRING (1, format); bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME); - fmt = SCM_STRING_CHARS (format); - len = SCM_STRING_LENGTH (format); + fmt = scm_i_string_chars (format); + len = scm_i_string_length (format); /* Ugly hack: strftime can return 0 if its buffer is too small, but some valid time strings (e.g. "%p") can sometimes produce @@ -665,7 +674,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, #endif } - result = scm_mem2string (tbuf + 1, len - 1); + result = scm_from_locale_stringn (tbuf + 1, len - 1); free (tbuf); free (myfmt); return result; @@ -688,13 +697,13 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, #define FUNC_NAME s_scm_strptime { struct tm t; - char *fmt, *str, *rest; + const char *fmt, *str, *rest; SCM_VALIDATE_STRING (1, format); SCM_VALIDATE_STRING (2, string); - fmt = SCM_STRING_CHARS (format); - str = SCM_STRING_CHARS (string); + fmt = scm_i_string_chars (format); + str = scm_i_string_chars (string); /* initialize the struct tm */ #define tm_init(field) t.field = 0 diff --git a/libguile/strop.c b/libguile/strop.c index 1d7483d97..b4a7063cf 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -57,24 +57,24 @@ scm_i_index (SCM str, SCM chr, int direction, SCM sub_start, long upper; int ch; - SCM_ASSERT (SCM_I_STRINGP (str), str, SCM_ARG1, why); + SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, why); SCM_ASSERT (SCM_CHARP (chr), chr, SCM_ARG2, why); if (scm_is_false (sub_start)) lower = 0; else - lower = scm_to_signed_integer (sub_start, 0, SCM_I_STRING_LENGTH(str)); + lower = scm_to_signed_integer (sub_start, 0, scm_i_string_length(str)); if (scm_is_false (sub_end)) - upper = SCM_I_STRING_LENGTH (str); + upper = scm_i_string_length (str); else - upper = scm_to_signed_integer (sub_end, lower, SCM_I_STRING_LENGTH(str)); + upper = scm_to_signed_integer (sub_end, lower, scm_i_string_length(str)); x = -1; if (direction > 0) { - p = SCM_I_STRING_UCHARS (str) + lower; + p = (unsigned char *) scm_i_string_chars (str) + lower; ch = SCM_CHAR (chr); for (x = lower; x < upper; ++x, ++p) @@ -83,7 +83,7 @@ scm_i_index (SCM str, SCM chr, int direction, SCM sub_start, } else { - p = upper - 1 + SCM_I_STRING_UCHARS (str); + p = upper - 1 + (unsigned char *)scm_i_string_chars (str); ch = SCM_CHAR (chr); for (x = upper - 1; x >= lower; --x, --p) if (*p == ch) @@ -164,17 +164,20 @@ SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, #define FUNC_NAME s_scm_substring_move_x { unsigned long s1, s2, e, len; + const char *src; + char *dst; SCM_VALIDATE_STRING (1, str1); SCM_VALIDATE_STRING (4, str2); - s1 = scm_to_unsigned_integer (start1, 0, SCM_I_STRING_LENGTH(str1)); - e = scm_to_unsigned_integer (end1, s1, SCM_I_STRING_LENGTH(str1)); + s1 = scm_to_unsigned_integer (start1, 0, scm_i_string_length(str1)); + e = scm_to_unsigned_integer (end1, s1, scm_i_string_length(str1)); len = e - s1; - s2 = scm_to_unsigned_integer (start2, 0, SCM_I_STRING_LENGTH(str2)-len); + s2 = scm_to_unsigned_integer (start2, 0, scm_i_string_length(str2)-len); - SCM_SYSCALL(memmove((void *)(&(SCM_I_STRING_CHARS(str2)[s2])), - (void *)(&(SCM_I_STRING_CHARS(str1)[s1])), - len)); + src = scm_i_string_chars (str2); + dst = scm_i_string_writable_chars (str1); + SCM_SYSCALL (memmove (dst+s2, src+s1, len)); + scm_i_string_stop_writing (); scm_remember_upto_here_2 (str1, str2); return SCM_UNSPECIFIED; @@ -197,12 +200,17 @@ SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, { size_t i, e; char c; + char *dst; + SCM_VALIDATE_STRING (1, str); - i = scm_to_unsigned_integer (start, 0, SCM_I_STRING_LENGTH (str)); - e = scm_to_unsigned_integer (end, i, SCM_I_STRING_LENGTH (str)); + i = scm_to_unsigned_integer (start, 0, scm_i_string_length (str)); + e = scm_to_unsigned_integer (end, i, scm_i_string_length (str)); SCM_VALIDATE_CHAR_COPY (4, fill, c); + dst = scm_i_string_writable_chars (str); while (ilist", 1, 0, 0, { long i; SCM res = SCM_EOL; - unsigned char *src; + const unsigned char *src; SCM_VALIDATE_STRING (1, str); - src = SCM_I_STRING_UCHARS (str); - for (i = SCM_I_STRING_LENGTH (str)-1;i >= 0;i--) + src = scm_i_string_chars (str); + for (i = scm_i_string_length (str)-1;i >= 0;i--) res = scm_cons (SCM_MAKE_CHAR (src[i]), res); scm_remember_upto_here_1 (src); return res; @@ -251,10 +259,11 @@ SCM_DEFINE (scm_string_to_list, "string->list", 1, 0, 0, static SCM string_copy (SCM str) { - const char* chars = SCM_I_STRING_CHARS (str); - size_t length = SCM_I_STRING_LENGTH (str); - SCM new_string = scm_allocate_string (length); - memcpy (SCM_I_STRING_CHARS (new_string), chars, length+1); + const char* chars = scm_i_string_chars (str); + size_t length = scm_i_string_length (str); + char *dst; + SCM new_string = scm_i_make_string (length, &dst); + memcpy (dst, chars, length); scm_remember_upto_here_1 (str); return new_string; } @@ -282,9 +291,10 @@ SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0, long k; SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_CHAR_COPY (2, chr, c); - dst = SCM_I_STRING_CHARS (str); - for (k = SCM_I_STRING_LENGTH (str)-1;k >= 0;k--) + dst = scm_i_string_writable_chars (str); + for (k = scm_i_string_length (str)-1;k >= 0;k--) dst[k] = c; + scm_i_string_stop_writing (); scm_remember_upto_here_1 (str); return SCM_UNSPECIFIED; } @@ -296,11 +306,14 @@ SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0, static SCM string_upcase_x (SCM v) { - unsigned long k; - - for (k = 0; k < SCM_I_STRING_LENGTH (v); ++k) - SCM_I_STRING_UCHARS (v) [k] = scm_c_upcase (SCM_I_STRING_UCHARS (v) [k]); + size_t k, len; + char *dst; + len = scm_i_string_length (v); + dst = scm_i_string_writable_chars (v); + for (k = 0; k < len; ++k) + dst[k] = scm_c_upcase (dst[k]); + scm_i_string_stop_writing (); return v; } @@ -341,10 +354,14 @@ SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0, static SCM string_downcase_x (SCM v) { - unsigned long k; + size_t k, len; + char *dst; - for (k = 0; k < SCM_I_STRING_LENGTH (v); ++k) - SCM_I_STRING_UCHARS (v) [k] = scm_c_downcase (SCM_I_STRING_UCHARS (v) [k]); + len = scm_i_string_length (v); + dst = scm_i_string_writable_chars (v); + for (k = 0; k < len; ++k) + dst[k] = scm_c_downcase (dst[k]); + scm_i_string_stop_writing (); return v; } @@ -387,22 +404,29 @@ static SCM string_capitalize_x (SCM str) { unsigned char *sz; - long i, len; + size_t i, len; int in_word=0; - len = SCM_I_STRING_LENGTH(str); - sz = SCM_I_STRING_UCHARS (str); - for(i=0; i= 0) { @@ -480,7 +504,8 @@ SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, idx--; if (idx >= 0) { - res = scm_cons (scm_mem2string (p + idx, last_idx - idx), res); + res = scm_cons (scm_c_substring (str, idx, last_idx), res); + p = scm_i_string_chars (str); idx--; } } diff --git a/libguile/strorder.c b/libguile/strorder.c index 6e8b647d3..3601c90bc 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -43,11 +43,11 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, SCM_VALIDATE_STRING (1, s1); SCM_VALIDATE_STRING (2, s2); - length = SCM_I_STRING_LENGTH (s2); - if (SCM_I_STRING_LENGTH (s1) == length) + length = scm_i_string_length (s2); + if (scm_i_string_length (s1) == length) { - unsigned char *c1 = SCM_I_STRING_UCHARS (s1) + length - 1; - unsigned char *c2 = SCM_I_STRING_UCHARS (s2) + length - 1; + const unsigned char *c1 = scm_i_string_chars (s1) + length - 1; + const unsigned char *c2 = scm_i_string_chars (s2) + length - 1; size_t i; /* comparing from back to front typically finds mismatches faster */ @@ -82,11 +82,11 @@ SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, SCM_VALIDATE_STRING (1, s1); SCM_VALIDATE_STRING (2, s2); - length = SCM_I_STRING_LENGTH (s2); - if (SCM_I_STRING_LENGTH (s1) == length) + length = scm_i_string_length (s2); + if (scm_i_string_length (s1) == length) { - unsigned char *c1 = SCM_I_STRING_UCHARS (s1) + length - 1; - unsigned char *c2 = SCM_I_STRING_UCHARS (s2) + length - 1; + const unsigned char *c1 = scm_i_string_chars (s1) + length - 1; + const unsigned char *c2 = scm_i_string_chars (s2) + length - 1; size_t i; /* comparing from back to front typically finds mismatches faster */ @@ -114,13 +114,13 @@ static SCM string_less_p (SCM s1, SCM s2) { size_t i, length1, length2, lengthm; - unsigned char *c1, *c2; + const unsigned char *c1, *c2; - length1 = SCM_I_STRING_LENGTH (s1); - length2 = SCM_I_STRING_LENGTH (s2); + length1 = scm_i_string_length (s1); + length2 = scm_i_string_length (s2); lengthm = min (length1, length2); - c1 = SCM_I_STRING_UCHARS (s1); - c2 = SCM_I_STRING_UCHARS (s2); + c1 = scm_i_string_chars (s1); + c2 = scm_i_string_chars (s2); for (i = 0; i != lengthm; ++i, ++c1, ++c2) { int c = *c1 - *c2; @@ -196,13 +196,13 @@ static SCM string_ci_less_p (SCM s1, SCM s2) { size_t i, length1, length2, lengthm; - unsigned char *c1, *c2; + const unsigned char *c1, *c2; - length1 = SCM_I_STRING_LENGTH (s1); - length2 = SCM_I_STRING_LENGTH (s2); + length1 = scm_i_string_length (s1); + length2 = scm_i_string_length (s2); lengthm = min (length1, length2); - c1 = SCM_I_STRING_UCHARS (s1); - c2 = SCM_I_STRING_UCHARS (s2); + c1 = scm_i_string_chars (s1); + c2 = scm_i_string_chars (s2); for (i = 0; i != lengthm; ++i, ++c1, ++c2) { int c = scm_c_upcase (*c1) - scm_c_upcase (*c2); diff --git a/libguile/strports.c b/libguile/strports.c index aa9844bc7..f7b4013b8 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -52,6 +52,14 @@ */ /* NOTES: + + We break the rules set forth by strings.h about accessing the + internals of strings here. We can do this since we can guarantee + that the string used as pt->stream is not in use by anyone else. + Thus, it's representation will not change asynchronously. + + (Ports aren't thread-safe yet anyway...) + write_buf/write_end point to the ends of the allocated string. read_buf/read_end in principle point to the part of the string which has been written to, but this is only updated after a flush. @@ -79,8 +87,10 @@ static void st_resize_port (scm_t_port *pt, off_t new_size) { SCM old_stream = SCM_PACK (pt->stream); - SCM new_stream = scm_allocate_string (new_size); - unsigned long int old_size = SCM_I_STRING_LENGTH (old_stream); + const char *src = scm_i_string_chars (old_stream); + char *dst; + SCM new_stream = scm_i_make_string (new_size, &dst); + unsigned long int old_size = scm_i_string_length (old_stream); unsigned long int min_size = min (old_size, new_size); unsigned long int i; @@ -89,14 +99,14 @@ st_resize_port (scm_t_port *pt, off_t new_size) pt->write_buf_size = new_size; for (i = 0; i != min_size; ++i) - SCM_I_STRING_CHARS (new_stream) [i] = SCM_I_STRING_CHARS (old_stream) [i]; + dst[i] = src[i]; scm_remember_upto_here_1 (old_stream); /* reset buffer. */ { pt->stream = SCM_UNPACK (new_stream); - pt->read_buf = pt->write_buf = SCM_I_STRING_UCHARS (new_stream); + pt->read_buf = pt->write_buf = dst; pt->read_pos = pt->write_pos = pt->write_buf + index; pt->write_end = pt->write_buf + pt->write_buf_size; pt->read_end = pt->read_buf + pt->read_buf_size; @@ -254,19 +264,37 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) scm_t_port *pt; size_t str_len, c_pos; - SCM_ASSERT (SCM_I_STRINGP (str), str, SCM_ARG1, caller); - str_len = SCM_I_STRING_LENGTH (str); + SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller); + + str_len = scm_i_string_length (str); c_pos = scm_to_unsigned_integer (pos, 0, str_len); if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG))) scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL); + /* XXX + + Make a new string to isolate us from changes to the original. + This is done so that we can rely on scm_i_string_chars to stay in + place even across SCM_TICKs. + + Additionally, when we are going to write to the string, we make a + copy so that we can write to it without having to use + scm_i_string_writable_chars. + */ + + if (modes & SCM_WRTNG) + str = scm_c_substring_copy (str, 0, str_len); + else + str = scm_c_substring (str, 0, str_len); + scm_mutex_lock (&scm_i_port_table_mutex); z = scm_new_port_table_entry (scm_tc16_strport); pt = SCM_PTAB_ENTRY(z); SCM_SETSTREAM (z, SCM_UNPACK (str)); SCM_SET_CELL_TYPE(z, scm_tc16_strport|modes); - pt->write_buf = pt->read_buf = SCM_I_STRING_UCHARS (str); + /* see above why we can use scm_i_string_chars here. */ + pt->write_buf = pt->read_buf = (char *)scm_i_string_chars (str); pt->read_pos = pt->write_pos = pt->read_buf + c_pos; pt->write_buf_size = pt->read_buf_size = str_len; pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size; @@ -286,11 +314,13 @@ SCM scm_strport_to_string (SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); SCM str; - + char *dst; + if (pt->rw_active == SCM_PORT_WRITE) st_flush (port); - str = scm_mem2string ((char *) pt->read_buf, pt->read_buf_size); + str = scm_i_make_string (pt->read_buf_size, &dst); + memcpy (dst, (char *) pt->read_buf, pt->read_buf_size); scm_remember_upto_here_1 (port); return str; } @@ -307,7 +337,7 @@ SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0, if (!SCM_UNBNDP (printer)) SCM_VALIDATE_PROC (2, printer); - str = scm_allocate_string (0); + str = scm_c_make_string (0, SCM_UNDEFINED); port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, FUNC_NAME); if (SCM_UNBNDP (printer)) @@ -401,7 +431,7 @@ SCM scm_c_read_string (const char *expr) { SCM port = scm_mkstrport (SCM_INUM0, - scm_makfrom0str (expr), + scm_from_locale_string (expr), SCM_OPN | SCM_RDNG, "scm_c_read_string"); SCM form; @@ -418,13 +448,13 @@ scm_c_read_string (const char *expr) SCM scm_c_eval_string (const char *expr) { - return scm_eval_string (scm_makfrom0str (expr)); + return scm_eval_string (scm_from_locale_string (expr)); } SCM scm_c_eval_string_in_module (const char *expr, SCM module) { - return scm_eval_string_in_module (scm_makfrom0str (expr), module); + return scm_eval_string_in_module (scm_from_locale_string (expr), module); } diff --git a/libguile/struct.c b/libguile/struct.c index efb17d3a4..8be254e73 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -59,16 +59,16 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, SCM_VALIDATE_STRING (1, fields); { /* scope */ - char * field_desc; + const char * field_desc; size_t len; int x; - len = SCM_I_STRING_LENGTH (fields); + len = scm_i_string_length (fields); if (len % 2 == 1) SCM_MISC_ERROR ("odd length field specification: ~S", scm_list_1 (fields)); - field_desc = SCM_I_STRING_CHARS (fields); + field_desc = scm_i_string_chars (fields); for (x = 0; x < len; x += 2) { @@ -120,7 +120,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, } #endif } - new_sym = scm_mem2symbol (field_desc, len); + new_sym = scm_string_to_symbol (fields); } scm_remember_upto_here_1 (fields); return new_sym; @@ -134,9 +134,10 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, static void scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM inits) { - unsigned char * fields_desc = (unsigned char *) SCM_SYMBOL_CHARS (layout) - 2; + unsigned const char *fields_desc = + (unsigned const char *) scm_i_symbol_chars (layout) - 2; unsigned char prot = 0; - int n_fields = SCM_SYMBOL_LENGTH (layout) / 2; + int n_fields = scm_i_symbol_length (layout) / 2; int tailp = 0; while (n_fields) @@ -239,20 +240,20 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, layout = SCM_STRUCT_LAYOUT (x); - if (SCM_SYMBOL_LENGTH (layout) - < SCM_I_STRING_LENGTH (required_vtable_fields)) + if (scm_i_symbol_length (layout) + < scm_i_string_length (required_vtable_fields)) return SCM_BOOL_F; - tmp = strncmp (SCM_SYMBOL_CHARS (layout), - SCM_I_STRING_CHARS (required_vtable_fields), - SCM_I_STRING_LENGTH (required_vtable_fields)); + tmp = strncmp (scm_i_symbol_chars (layout), + scm_i_string_chars (required_vtable_fields), + scm_i_string_length (required_vtable_fields)); scm_remember_upto_here_1 (required_vtable_fields); if (tmp) return SCM_BOOL_F; mem = SCM_STRUCT_DATA (x); - return scm_from_bool (SCM_SYMBOLP (SCM_PACK (mem[scm_vtable_index_layout]))); + return scm_from_bool (scm_is_symbol (SCM_PACK (mem[scm_vtable_index_layout]))); } #undef FUNC_NAME @@ -426,7 +427,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, SCM_VALIDATE_REST_ARGUMENT (init); layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]); - basic_size = SCM_SYMBOL_LENGTH (layout) / 2; + basic_size = scm_i_symbol_length (layout) / 2; tail_elts = scm_to_size_t (tail_array_size); SCM_DEFER_INTS; if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) @@ -513,7 +514,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, fields = scm_string_append (scm_list_2 (required_vtable_fields, user_fields)); layout = scm_make_struct_layout (fields); - basic_size = SCM_SYMBOL_LENGTH (layout) / 2; + basic_size = scm_i_symbol_length (layout) / 2; tail_elts = scm_to_size_t (tail_array_size); SCM_DEFER_INTS; data = scm_alloc_struct (basic_size + tail_elts, @@ -543,9 +544,10 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, SCM answer = SCM_UNDEFINED; scm_t_bits * data; SCM layout; + size_t layout_len; size_t p; scm_t_bits n_fields; - char * fields_desc; + const char *fields_desc; char field_type = 0; @@ -555,12 +557,13 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, data = SCM_STRUCT_DATA (handle); p = scm_to_size_t (pos); - fields_desc = SCM_SYMBOL_CHARS (layout); + fields_desc = scm_i_symbol_chars (layout); + layout_len = scm_i_symbol_length (layout); n_fields = data[scm_struct_i_n_words]; SCM_ASSERT_RANGE(1, pos, p < n_fields); - if (p * 2 < SCM_SYMBOL_LENGTH (layout)) + if (p * 2 < layout_len) { char ref; field_type = fields_desc[p * 2]; @@ -573,8 +576,8 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos)); } } - else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] != 'O') - field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2]; + else if (fields_desc[layout_len - 1] != 'O') + field_type = fields_desc[layout_len - 2]; else SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos)); @@ -619,9 +622,10 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, { scm_t_bits * data; SCM layout; + size_t layout_len; size_t p; int n_fields; - char * fields_desc; + const char *fields_desc; char field_type = 0; SCM_VALIDATE_STRUCT (1, handle); @@ -630,12 +634,13 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, data = SCM_STRUCT_DATA (handle); p = scm_to_size_t (pos); - fields_desc = SCM_SYMBOL_CHARS (layout); + fields_desc = scm_i_symbol_chars (layout); + layout_len = scm_i_symbol_length (layout); n_fields = data[scm_struct_i_n_words]; SCM_ASSERT_RANGE (1, pos, p < n_fields); - if (p * 2 < SCM_SYMBOL_LENGTH (layout)) + if (p * 2 < layout_len) { char set_x; field_type = fields_desc[p * 2]; @@ -643,8 +648,8 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, if (set_x != 'w') SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos)); } - else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] == 'W') - field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2]; + else if (fields_desc[layout_len - 1] == 'W') + field_type = fields_desc[layout_len - 2]; else SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos)); @@ -794,7 +799,7 @@ scm_init_struct () { scm_struct_table = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31))); - required_vtable_fields = scm_makfrom0str ("prsrpw"); + required_vtable_fields = scm_from_locale_string ("prsrpw"); scm_permanent_object (required_vtable_fields); scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout)); scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable)); diff --git a/libguile/throw.c b/libguile/throw.c index 94affdeb4..8c8380c3c 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -444,7 +444,7 @@ handler_message (void *handler_data, SCM tag, SCM args) SCM scm_handle_by_message (void *handler_data, SCM tag, SCM args) { - if (scm_is_true (scm_eq_p (tag, scm_str2symbol ("quit")))) + if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit")))) { exit (scm_exit_status (args)); } @@ -502,7 +502,7 @@ SCM_DEFINE (scm_catch, "catch", 3, 0, 0, { struct scm_body_thunk_data c; - SCM_ASSERT (SCM_SYMBOLP (key) || scm_is_eq (key, SCM_BOOL_T), + SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T), key, SCM_ARG1, FUNC_NAME); c.tag = key; @@ -530,7 +530,7 @@ SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0, { struct scm_body_thunk_data c; - SCM_ASSERT (SCM_SYMBOLP (key) || scm_is_eq (key, SCM_BOOL_T), + SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T), key, SCM_ARG1, FUNC_NAME); c.tag = key; diff --git a/libguile/unif.c b/libguile/unif.c index 7936f2491..cc9e6ee04 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -169,7 +169,7 @@ scm_make_uve (long k, SCM prot) else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0')) return make_uve (scm_tc7_byvect, k, sizeof (char)); else if (SCM_CHARP (prot)) - return scm_allocate_string (sizeof (char) * k); + return scm_c_make_string (sizeof (char) * k, SCM_UNDEFINED); else if (SCM_I_INUMP (prot)) return make_uve (SCM_I_INUM (prot) > 0 ? scm_tc7_uvect : scm_tc7_ivect, k, @@ -179,11 +179,11 @@ scm_make_uve (long k, SCM prot) if (scm_num_eq_p (exactly_one_third, prot)) goto dvect; } - else if (SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot))) + else if (scm_is_symbol (prot) && (1 == scm_i_symbol_length (prot))) { char s; - s = SCM_SYMBOL_CHARS (prot)[0]; + s = scm_i_symbol_chars (prot)[0]; if (s == 's') return make_uve (scm_tc7_svect, k, sizeof (short)); #if SCM_SIZEOF_LONG_LONG != 0 @@ -220,7 +220,7 @@ SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, case scm_tc7_wvect: return scm_from_size_t (SCM_VECTOR_LENGTH (v)); case scm_tc7_string: - return scm_from_size_t (SCM_I_STRING_LENGTH (v)); + return scm_from_size_t (scm_i_string_length (v)); case scm_tc7_bvect: return scm_from_size_t (SCM_BITVECTOR_LENGTH (v)); case scm_tc7_byvect: @@ -286,15 +286,15 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, protp = SCM_I_INUMP(prot) && SCM_I_INUM(prot)<=0; break; case scm_tc7_svect: - protp = SCM_SYMBOLP (prot) - && (1 == SCM_SYMBOL_LENGTH (prot)) - && ('s' == SCM_SYMBOL_CHARS (prot)[0]); + protp = scm_is_symbol (prot) + && (1 == scm_i_symbol_length (prot)) + && ('s' == scm_i_symbol_chars (prot)[0]); break; #if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: - protp = SCM_SYMBOLP (prot) - && (1 == SCM_SYMBOL_LENGTH (prot)) - && ('l' == SCM_SYMBOL_CHARS (prot)[0]); + protp = scm_is_symbol (prot) + && (1 == scm_i_symbol_length (prot)) + && ('l' == scm_i_symbol_chars (prot)[0]); break; #endif case scm_tc7_fvect: @@ -564,7 +564,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, SCM answer = scm_make_uve (scm_to_long (dims), prot); if (!SCM_UNBNDP (fill)) scm_array_fill_x (answer, fill); - else if (SCM_SYMBOLP (prot)) + else if (scm_is_symbol (prot)) scm_array_fill_x (answer, scm_from_int (0)); else scm_array_fill_x (answer, prot); @@ -589,7 +589,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, if (!SCM_UNBNDP (fill)) scm_array_fill_x (ra, fill); - else if (SCM_SYMBOLP (prot)) + else if (scm_is_symbol (prot)) scm_array_fill_x (ra, scm_from_int (0)); else scm_array_fill_x (ra, prot); @@ -880,6 +880,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, #define FUNC_NAME s_scm_enclose_array { SCM axv, res, ra_inr; + const char *c_axv; scm_t_array_dim vdim, *s = &vdim; int ndim, j, k, ninr, noutr; @@ -939,16 +940,18 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd; SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd; SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc; - SCM_I_STRING_CHARS (axv)[j] = 1; + scm_c_string_set_x (axv, j, SCM_MAKE_CHAR (1)); } + c_axv = scm_i_string_chars (axv); for (j = 0, k = 0; k < noutr; k++, j++) { - while (SCM_I_STRING_CHARS (axv)[j]) + while (c_axv[j]) j++; SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd; SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd; SCM_ARRAY_DIMS (res)[k].inc = s[j].inc; } + scm_remember_upto_here_1 (axv); scm_ra_set_contp (ra_inr); scm_ra_set_contp (res); return res; @@ -1109,7 +1112,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, else return SCM_BOOL_F; case scm_tc7_string: - return SCM_MAKE_CHAR (SCM_I_STRING_UCHARS (v)[pos]); + return scm_c_string_ref (v, pos); case scm_tc7_byvect: return scm_from_schar (((char *) SCM_UVECTOR_BASE (v))[pos]); case scm_tc7_uvect: @@ -1155,7 +1158,7 @@ scm_cvref (SCM v, unsigned long pos, SCM last) else return SCM_BOOL_F; case scm_tc7_string: - return SCM_MAKE_CHAR (SCM_I_STRING_UCHARS (v)[pos]); + return scm_c_string_ref (v, pos); case scm_tc7_byvect: return scm_from_char (((char *) SCM_UVECTOR_BASE (v))[pos]); case scm_tc7_uvect: @@ -1269,7 +1272,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, break; case scm_tc7_string: SCM_ASRTGO (SCM_CHARP (obj), badobj); - SCM_I_STRING_UCHARS (v)[pos] = SCM_CHAR (obj); + scm_c_string_set_x (v, pos, obj); break; case scm_tc7_byvect: if (SCM_CHARP (obj)) @@ -1478,7 +1481,7 @@ loop: v = SCM_ARRAY_V (cra); goto loop; case scm_tc7_string: - base = SCM_I_STRING_CHARS (v); + base = NULL; /* writing to strings is special, see below. */ sz = sizeof (char); break; case scm_tc7_bvect: @@ -1544,7 +1547,7 @@ loop: { scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd); int remaining = (cend - offset) * sz; - char *dest = base + (cstart + offset) * sz; + size_t off = (cstart + offset) * sz; if (pt->rw_active == SCM_PORT_WRITE) scm_flush (port_or_fd); @@ -1557,10 +1560,18 @@ loop: int to_copy = min (pt->read_end - pt->read_pos, remaining); - memcpy (dest, pt->read_pos, to_copy); + if (base == NULL) + { + /* strings */ + char *b = scm_i_string_writable_chars (v); + memcpy (b + off, pt->read_pos, to_copy); + scm_i_string_stop_writing (); + } + else + memcpy (base + off, pt->read_pos, to_copy); pt->read_pos += to_copy; remaining -= to_copy; - dest += to_copy; + off += to_copy; } else { @@ -1581,9 +1592,19 @@ loop: } else /* file descriptor. */ { - SCM_SYSCALL (ans = read (scm_to_int (port_or_fd), - base + (cstart + offset) * sz, - (sz * (cend - offset)))); + if (base == NULL) + { + /* strings */ + char *b = scm_i_string_writable_chars (v); + SCM_SYSCALL (ans = read (scm_to_int (port_or_fd), + b + (cstart + offset) * sz, + (sz * (cend - offset)))); + scm_i_string_stop_writing (); + } + else + SCM_SYSCALL (ans = read (scm_to_int (port_or_fd), + base + (cstart + offset) * sz, + (sz * (cend - offset)))); if (ans == -1) SCM_SYSERROR; } @@ -1615,7 +1636,7 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, long offset = 0; long cstart = 0; long cend; - char *base; + const char *base; port_or_fd = SCM_COERCE_OUTPORT (port_or_fd); @@ -1644,7 +1665,7 @@ loop: v = SCM_ARRAY_V (v); goto loop; case scm_tc7_string: - base = SCM_I_STRING_CHARS (v); + base = scm_i_string_chars (v); sz = sizeof (char); break; case scm_tc7_bvect: @@ -1708,7 +1729,7 @@ loop: if (SCM_NIMP (port_or_fd)) { - char *source = base + (cstart + offset) * sz; + const char *source = base + (cstart + offset) * sz; ans = cend - offset; scm_lfwrite (source, ans * sz, port_or_fd); @@ -2014,13 +2035,16 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, SCM -scm_istr2bve (char *str, long len) +scm_istr2bve (SCM str) { + size_t len = scm_i_string_length (str); SCM v = scm_make_uve (len, SCM_BOOL_T); long *data = (long *) SCM_VELTS (v); register unsigned long mask; register long k; register long j; + const char *c_str = scm_i_string_chars (str); + for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++) { data[k] = 0L; @@ -2028,7 +2052,7 @@ scm_istr2bve (char *str, long len) if (j > SCM_LONG_BIT) j = SCM_LONG_BIT; for (mask = 1L; j--; mask <<= 1) - switch (*str++) + switch (*c_str++) { case '0': break; @@ -2320,17 +2344,22 @@ tail: } break; case scm_tc7_string: - if (n-- > 0) - scm_iprin1 (SCM_MAKE_CHAR (SCM_I_STRING_UCHARS (ra)[j]), port, pstate); - if (SCM_WRITINGP (pstate)) - for (j += inc; n-- > 0; j += inc) - { - scm_putc (' ', port); - scm_iprin1 (SCM_MAKE_CHAR (SCM_I_STRING_UCHARS (ra)[j]), port, pstate); - } - else - for (j += inc; n-- > 0; j += inc) - scm_putc (SCM_I_STRING_CHARS (ra)[j], port); + { + const char *src; + src = scm_i_string_chars (ra); + if (n-- > 0) + scm_iprin1 (SCM_MAKE_CHAR (src[j]), port, pstate); + if (SCM_WRITINGP (pstate)) + for (j += inc; n-- > 0; j += inc) + { + scm_putc (' ', port); + scm_iprin1 (SCM_MAKE_CHAR (src[j]), port, pstate); + } + else + for (j += inc; n-- > 0; j += inc) + scm_putc (src[j], port); + scm_remember_upto_here_1 (ra); + } break; case scm_tc7_byvect: if (n-- > 0) @@ -2560,10 +2589,10 @@ loop: case scm_tc7_ivect: return scm_from_int (-1); case scm_tc7_svect: - return scm_str2symbol ("s"); + return scm_from_locale_symbol ("s"); #if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: - return scm_str2symbol ("l"); + return scm_from_locale_symbol ("l"); #endif case scm_tc7_fvect: return scm_from_double (1.0); diff --git a/libguile/unif.h b/libguile/unif.h index a5b6b9d15..80eaa674e 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -115,7 +115,7 @@ SCM_API SCM scm_bit_position (SCM item, SCM v, SCM k); SCM_API SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj); SCM_API SCM scm_bit_count_star (SCM v, SCM kv, SCM obj); SCM_API SCM scm_bit_invert_x (SCM v); -SCM_API SCM scm_istr2bve (char *str, long len); +SCM_API SCM scm_istr2bve (SCM str); SCM_API SCM scm_array_to_list (SCM v); SCM_API SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst); SCM_API int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate); diff --git a/libguile/validate.h b/libguile/validate.h index 886a4d646..5fd016dcb 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -3,7 +3,7 @@ #ifndef SCM_VALIDATE_H #define SCM_VALIDATE_H -/* Copyright (C) 1999,2000,2001, 2002 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001, 2002, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -152,7 +152,10 @@ cvar = SCM_CHAR (scm); \ } while (0) -#define SCM_VALIDATE_STRING(pos, str) SCM_MAKE_VALIDATE_MSG (pos, str, I_STRINGP, "string") +#define SCM_VALIDATE_STRING(pos, str) \ + do { \ + SCM_ASSERT_TYPE (scm_is_string (str), str, pos, FUNC_NAME, "string"); \ + } while (0) #define SCM_VALIDATE_REAL(pos, z) SCM_MAKE_VALIDATE_MSG (pos, z, REALP, "real") @@ -270,7 +273,10 @@ SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), thunk, pos, FUNC_NAME); \ } while (0) -#define SCM_VALIDATE_SYMBOL(pos, sym) SCM_MAKE_VALIDATE_MSG (pos, sym, SYMBOLP, "symbol") +#define SCM_VALIDATE_SYMBOL(pos, str) \ + do { \ + SCM_ASSERT_TYPE (scm_is_symbol (str), str, pos, FUNC_NAME, "symbol"); \ + } while (0) #define SCM_VALIDATE_VARIABLE(pos, var) SCM_MAKE_VALIDATE_MSG (pos, var, VARIABLEP, "variable") diff --git a/libguile/values.c b/libguile/values.c index d67b45926..88aef2bf6 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -76,8 +76,10 @@ scm_init_values (void) print_values); scm_values_vtable - = scm_permanent_object (scm_make_vtable_vtable (scm_makfrom0str ("pr"), - SCM_INUM0, SCM_EOL)); + = scm_permanent_object ( + scm_make_vtable_vtable (scm_from_locale_string ("pr"), + SCM_INUM0, SCM_EOL)); + SCM_SET_STRUCT_PRINTER (scm_values_vtable, print); scm_add_feature ("values"); diff --git a/libguile/version.c b/libguile/version.c index 3a811f01e..d9e00be9a 100644 --- a/libguile/version.c +++ b/libguile/version.c @@ -95,7 +95,7 @@ SCM_DEFINE (scm_version, "version", 0, 0, 0, SCM_MAJOR_VERSION, SCM_MINOR_VERSION, SCM_MICRO_VERSION); - return scm_makfrom0str (version_str); + return scm_from_locale_string (version_str); } #undef FUNC_NAME @@ -120,7 +120,7 @@ SCM_DEFINE (scm_effective_version, "effective-version", 0, 0, 0, # error version string may overflow buffer #endif sprintf (version_str, "%d.%d", SCM_MAJOR_VERSION, SCM_MINOR_VERSION); - return scm_makfrom0str (version_str); + return scm_from_locale_string (version_str); } #undef FUNC_NAME diff --git a/libguile/vports.c b/libguile/vports.c index e99d7961c..199c27a0a 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -76,7 +76,7 @@ sf_write (SCM port, const void *data, size_t size) { SCM p = SCM_PACK (SCM_STREAM (port)); - scm_call_1 (SCM_VELTS (p)[1], scm_mem2string ((char *) data, size)); + scm_call_1 (SCM_VELTS (p)[1], scm_from_locale_stringn ((char *) data, size)); } /* calling the flush proc (element 2) is in case old code needs it, From 1934b612112092d05ea0b3251001524d198958de Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:20:44 +0000 Subject: [PATCH 014/100] (substring/shared): Export as replacement since we now have a version in the core. --- srfi/srfi-13.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm index 00d5d937b..b9b8d03ca 100644 --- a/srfi/srfi-13.scm +++ b/srfi/srfi-13.scm @@ -1,6 +1,6 @@ ;;; srfi-13.scm --- String Library -;; Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2003, 2004 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -117,7 +117,7 @@ ) :replace (string->list string-copy string-fill! string-upcase! string-upcase string-downcase! string-downcase - string-index) + string-index substring/shared) ) (cond-expand-provide (current-module) '(srfi-13)) From 7d8e050bc6ef015f1e3ef64ac060cb8ca4da94cf Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:21:22 +0000 Subject: [PATCH 015/100] Adapted to new internal string and symbol API. --- srfi/srfi-14.c | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index f9e961c9c..4c7812512 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -1,6 +1,6 @@ /* srfi-14.c --- SRFI-14 procedures for Guile * - * Copyright (C) 2001 Free Software Foundation, Inc. + * Copyright (C) 2001, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -525,8 +525,8 @@ SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, { SCM cs; long * p; - char * s; - size_t k = 0; + const char * s; + size_t k = 0, len; SCM_VALIDATE_STRING (1, str); if (SCM_UNBNDP (base_cs)) @@ -537,12 +537,14 @@ SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, cs = scm_char_set_copy (base_cs); } p = (long *) SCM_SMOB_DATA (cs); - s = SCM_STRING_CHARS (str); - while (k < SCM_STRING_LENGTH (str)) + s = scm_i_string_chars (str); + len = scm_i_string_length (str); + while (k < len) { int c = s[k++]; p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); } + scm_remember_upto_here_1 (str); return cs; } #undef FUNC_NAME @@ -556,18 +558,20 @@ SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0, #define FUNC_NAME s_scm_string_to_char_set_x { long * p; - char * s; - size_t k = 0; + const char * s; + size_t k = 0, len; SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_SMOB (2, base_cs, charset); p = (long *) SCM_SMOB_DATA (base_cs); - s = SCM_STRING_CHARS (str); - while (k < SCM_STRING_LENGTH (str)) + s = scm_i_string_chars (str); + len = scm_i_string_length (str); + while (k < len) { int c = s[k++]; p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); } + scm_remember_upto_here_1 (str); return base_cs; } #undef FUNC_NAME @@ -807,8 +811,7 @@ SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0, 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); + result = scm_i_make_string (count, &p); for (k = 0; k < SCM_CHARSET_SIZE; k++) if (SCM_CHARSET_GET (cs, k)) p[idx++] = k; From e040afa5a927b11eed763d61444104f1d0d5b991 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:22:20 +0000 Subject: [PATCH 016/100] * srfi-13.h, srfi-13.c: (scm_substring_shared): Renamed to scm_substring_sharedS. * srfi-14.c, srfi-13.c: Adapted to new internal string and symbol API. --- srfi/srfi-13.c | 731 +++++++++++++++++++++++++------------------------ srfi/srfi-13.h | 4 +- 2 files changed, 379 insertions(+), 356 deletions(-) diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index 2698095d3..e362b8fad 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -33,22 +33,30 @@ */ #define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \ - pos_start, start, c_start, \ - pos_end, end, c_end) \ + pos_start, start, c_start, \ + pos_end, end, c_end) \ do { \ SCM_VALIDATE_STRING (pos_str, str); \ - c_str = SCM_I_STRING_CHARS (str); \ - scm_i_get_substring_spec (SCM_I_STRING_LENGTH (str), \ + c_str = scm_i_string_chars (str); \ + scm_i_get_substring_spec (scm_i_string_length (str), \ start, &c_start, end, &c_end); \ } while (0) +#define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \ + pos_start, start, c_start, \ + pos_end, end, c_end) \ + do { \ + SCM_VALIDATE_STRING (pos_str, str); \ + scm_i_get_substring_spec (scm_i_string_length (str), \ + start, &c_start, end, &c_end); \ + } while (0) /* Likewise for SCM_VALIDATE_STRING_COPY. */ #define MY_VALIDATE_STRING_COPY(pos, str, cvar) \ do { \ - SCM_VALIDATE_STRING (pos, str); \ - cvar = SCM_I_STRING_CHARS(str); \ + scm_validate_string (pos, str); \ + cvar = scm_i_string_chars (str); \ } while (0) @@ -67,7 +75,7 @@ SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, "case.") #define FUNC_NAME s_scm_string_any { - char * cstr; + const char *cstr; int cstart, cend; SCM res; @@ -126,7 +134,7 @@ SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0, "case.") #define FUNC_NAME s_scm_string_every { - char * cstr; + const char *cstr; int cstart, cend; SCM res; @@ -181,17 +189,19 @@ SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0, size_t clen, i; SCM res; SCM ch; - char * p; + char *p; SCM_VALIDATE_PROC (1, proc); clen = scm_to_size_t (len); SCM_ASSERT_RANGE (2, len, clen >= 0); - res = scm_allocate_string (clen); - p = SCM_STRING_CHARS (res); + res = scm_i_make_string (clen, &p); i = 0; while (i < clen) { + /* The RES string remains untouched since nobody knows about it + yet. No need to refetch P. + */ ch = scm_call_1 (proc, scm_from_int (i)); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); @@ -208,7 +218,7 @@ SCM_DEFINE (scm_string_to_listS, "string->list", 1, 2, 0, "Convert the string @var{str} into a list of characters.") #define FUNC_NAME s_scm_string_to_listS { - char * cstr; + const char *cstr; int cstart, cend; SCM result = SCM_EOL; @@ -236,14 +246,15 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0, { SCM result; long i = scm_ilength (chrs); + char *data; if (i < 0) SCM_WRONG_TYPE_ARG (1, chrs); - result = scm_allocate_string (i); + result = scm_i_make_string (i, &data); { - unsigned char *data = SCM_STRING_UCHARS (result) + i; - + + data += i; while (!SCM_NULLP (chrs)) { SCM elt = SCM_CAR (chrs); @@ -305,13 +316,13 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, /* Validate the delimiter and record its length. */ if (SCM_UNBNDP (delimiter)) { - delimiter = scm_makfrom0str (" "); + delimiter = scm_from_locale_string (" "); del_len = 1; } else { SCM_VALIDATE_STRING (2, delimiter); - del_len = SCM_STRING_LENGTH (delimiter); + del_len = scm_i_string_length (delimiter); } /* Validate the grammar symbol and remember the grammar. */ @@ -352,12 +363,11 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, { SCM elt = SCM_CAR (tmp); SCM_VALIDATE_STRING (1, elt); - len += SCM_STRING_LENGTH (elt); + len += scm_i_string_length (elt); tmp = SCM_CDR (tmp); } - result = scm_allocate_string (len + extra_len); - p = SCM_STRING_CHARS (result); + result = scm_i_make_string (len + extra_len, &p); tmp = ls; switch (gram) @@ -367,13 +377,12 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, 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); + memmove (p, scm_i_string_chars (elt), + scm_i_string_length (elt)); + p += scm_i_string_length (elt); if (!SCM_NULLP (SCM_CDR (tmp)) && del_len > 0) { - memmove (p, SCM_STRING_CHARS (delimiter), - SCM_STRING_LENGTH (delimiter) * sizeof (char)); + memmove (p, scm_i_string_chars (delimiter), del_len); p += del_len; } tmp = SCM_CDR (tmp); @@ -383,13 +392,12 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, 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); + memmove (p, scm_i_string_chars (elt), + scm_i_string_length (elt)); + p += scm_i_string_length (elt); if (del_len > 0) { - memmove (p, SCM_STRING_CHARS (delimiter), - SCM_STRING_LENGTH (delimiter) * sizeof (char)); + memmove (p, scm_i_string_chars (delimiter), del_len); p += del_len; } tmp = SCM_CDR (tmp); @@ -401,13 +409,12 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, SCM elt = SCM_CAR (tmp); if (del_len > 0) { - memmove (p, SCM_STRING_CHARS (delimiter), - SCM_STRING_LENGTH (delimiter) * sizeof (char)); + memmove (p, scm_i_string_chars (delimiter), del_len); p += del_len; } - memmove (p, SCM_STRING_CHARS (elt), - SCM_STRING_LENGTH (elt) * sizeof (char)); - p += SCM_STRING_LENGTH (elt); + memmove (p, scm_i_string_chars (elt), + scm_i_string_length (elt)); + p += scm_i_string_length (elt); tmp = SCM_CDR (tmp); } break; @@ -428,39 +435,32 @@ SCM_DEFINE (scm_string_copyS, "string-copy", 1, 2, 0, "@var{str} which is copied.") #define FUNC_NAME s_scm_string_copyS { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, 2, start, cstart, 3, end, cend); - return scm_mem2string (cstr + cstart, cend - cstart); - + return scm_c_substring_copy (str, cstart, cend); } #undef FUNC_NAME - -SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0, +SCM_DEFINE (scm_substring_sharedS, "substring/shared", 2, 1, 0, (SCM str, SCM start, SCM end), "Like @code{substring}, but the result may share memory with the\n" "argument @var{str}.") -#define FUNC_NAME s_scm_substring_shared +#define FUNC_NAME s_scm_substring_sharedS { - size_t s, e; - SCM_VALIDATE_STRING (1, str); - s = scm_to_size_t (start); - if (SCM_UNBNDP (end)) - e = SCM_STRING_LENGTH (str); - else - e = scm_to_size_t (end); - if (s == 0 && e == SCM_STRING_LENGTH (str)) - return str; - else - return scm_substring (str, start, end); + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return scm_c_substring_shared (str, cstart, cend); } #undef FUNC_NAME - SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0, (SCM target, SCM tstart, SCM s, SCM start, SCM end), "Copy the sequence of characters from index range [@var{start},\n" @@ -472,23 +472,24 @@ SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0, "string.") #define FUNC_NAME s_scm_string_copy_x { - char * cstr, * ctarget; - int cstart, cend, ctstart, dummy; - int len; + const char *cstr; + char *ctarget; + size_t cstart, cend, ctstart, dummy, len; SCM sdummy = SCM_UNDEFINED; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, target, ctarget, - 2, tstart, ctstart, - 2, sdummy, dummy); + MY_VALIDATE_SUBSTRING_SPEC (1, target, + 2, tstart, ctstart, + 2, sdummy, dummy); MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, 4, start, cstart, 5, end, cend); len = cend - cstart; - SCM_ASSERT_RANGE (3, s, len <= SCM_STRING_LENGTH (target) - ctstart); + SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart); + + ctarget = scm_i_string_writable_chars (target); + memmove (ctarget + ctstart, cstr + cstart, len); + scm_i_string_stop_writing (); - memmove (SCM_STRING_CHARS (target) + ctstart, - SCM_STRING_CHARS (s) + cstart, - len * sizeof (char)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -499,13 +500,7 @@ SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0, "Return the @var{n} first characters of @var{s}.") #define FUNC_NAME s_scm_string_take { - char * cstr; - size_t cn; - - MY_VALIDATE_STRING_COPY (1, s, cstr); - cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s)); - - return scm_mem2string (cstr, cn); + return scm_substring (s, SCM_INUM0, n); } #undef FUNC_NAME @@ -515,13 +510,7 @@ SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0, "Return all but the first @var{n} characters of @var{s}.") #define FUNC_NAME s_scm_string_drop { - char * cstr; - size_t cn; - - MY_VALIDATE_STRING_COPY (1, s, cstr); - cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s)); - - return scm_mem2string (cstr + cn, SCM_STRING_LENGTH (s) - cn); + return scm_substring (s, n, SCM_UNDEFINED); } #undef FUNC_NAME @@ -531,13 +520,9 @@ SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0, "Return the @var{n} last characters of @var{s}.") #define FUNC_NAME s_scm_string_take_right { - char * cstr; - size_t cn; - - MY_VALIDATE_STRING_COPY (1, s, cstr); - cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s)); - - return scm_mem2string (cstr + SCM_STRING_LENGTH (s) - cn, cn); + return scm_substring (s, + scm_difference (scm_string_length (s), n), + SCM_UNDEFINED); } #undef FUNC_NAME @@ -547,13 +532,9 @@ SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0, "Return all but the last @var{n} characters of @var{s}.") #define FUNC_NAME s_scm_string_drop_right { - char * cstr; - size_t cn; - - MY_VALIDATE_STRING_COPY (1, s, cstr); - cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s)); - - return scm_mem2string (cstr, SCM_STRING_LENGTH (s) - cn); + return scm_substring (s, + SCM_INUM0, + scm_difference (scm_string_length (s), n)); } #undef FUNC_NAME @@ -567,9 +548,8 @@ SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0, #define FUNC_NAME s_scm_string_pad { char cchr; - char * cstr; + const char *cstr; size_t cstart, cend, clen; - SCM result; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 4, start, cstart, @@ -583,20 +563,18 @@ SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0, 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)); + return scm_c_substring (s, cend - clen, cend); 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)); + SCM result; + char *dst; + + result = scm_i_make_string (clen, &dst); + memset (dst, cchr, (clen - (cend - cstart))); + memmove (dst + clen - (cend - cstart), cstr + cstart, cend - cstart); + return result; } - return result; } #undef FUNC_NAME @@ -610,9 +588,8 @@ SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0, #define FUNC_NAME s_scm_string_pad_right { char cchr; - char * cstr; + const char *cstr; size_t cstart, cend, clen; - SCM result; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 4, start, cstart, @@ -626,17 +603,18 @@ SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0, 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)); + return scm_c_substring (s, cstart, cstart + clen); 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)); + SCM result; + char *dst; + + result = scm_i_make_string (clen, &dst); + memset (dst + (cend - cstart), cchr, clen - (cend - cstart)); + memmove (dst, cstr + cstart, cend - cstart); + return result; } - return result; } #undef FUNC_NAME @@ -663,7 +641,7 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, "trimmed.") #define FUNC_NAME s_scm_string_trim { - char * cstr; + const char *cstr; size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, @@ -707,10 +685,11 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (scm_is_false (res)) break; + cstr = scm_i_string_chars (s); cstart++; } } - return scm_mem2string (cstr + cstart, cend - cstart); + return scm_c_substring (s, cstart, cend); } #undef FUNC_NAME @@ -738,7 +717,7 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, "trimmed.") #define FUNC_NAME s_scm_string_trim_right { - char * cstr; + const char *cstr; int cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, @@ -782,10 +761,11 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1])); if (scm_is_false (res)) break; + cstr = scm_i_string_chars (s); cend--; } } - return scm_mem2string (cstr + cstart, cend - cstart); + return scm_c_substring (s, cstart, cend); } #undef FUNC_NAME @@ -813,8 +793,8 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, "trimmed.") #define FUNC_NAME s_scm_string_trim_both { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 3, start, cstart, @@ -875,6 +855,7 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (scm_is_false (res)) break; + cstr = scm_i_string_chars (s); cstart++; } while (cstart < cend) @@ -884,10 +865,11 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1])); if (scm_is_false (res)) break; + cstr = scm_i_string_chars (s); cend--; } } - return scm_mem2string (cstr + cstart, cend - cstart); + return scm_c_substring (s, cstart, cend); } #undef FUNC_NAME @@ -898,17 +880,20 @@ SCM_DEFINE (scm_string_fill_xS, "string-fill!", 2, 2, 0, "returns an unspecified value.") #define FUNC_NAME s_scm_string_fill_xS { - char * cstr; - int cstart, cend; + char *cstr; + size_t cstart, cend; int c; - long k; + size_t k; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 3, start, cstart, + 4, end, cend); SCM_VALIDATE_CHAR_COPY (2, chr, c); + + cstr = scm_i_string_writable_chars (str); for (k = cstart; k < cend; k++) cstr[k] = c; + scm_i_string_stop_writing (); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -924,8 +909,8 @@ SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0, "@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; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 6, start1, cstart1, @@ -940,18 +925,18 @@ SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (cstr1[cstart1] < cstr2[cstart2]) - return scm_call_1 (proc_lt, SCM_I_MAKINUM (cstart1)); + return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); else if (cstr1[cstart1] > cstr2[cstart2]) - return scm_call_1 (proc_gt, SCM_I_MAKINUM (cstart1)); + return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); cstart1++; cstart2++; } if (cstart1 < cend1) - return scm_call_1 (proc_gt, SCM_I_MAKINUM (cstart1)); + return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); else if (cstart2 < cend2) - return scm_call_1 (proc_lt, SCM_I_MAKINUM (cstart1)); + return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); else - return scm_call_1 (proc_eq, SCM_I_MAKINUM (cstart1)); + return scm_call_1 (proc_eq, scm_from_size_t (cstart1)); } #undef FUNC_NAME @@ -967,8 +952,8 @@ SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0, "character comparison is done case-insensitively.") #define FUNC_NAME s_scm_string_compare_ci { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 6, start1, cstart1, @@ -983,18 +968,18 @@ SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - return scm_call_1 (proc_lt, SCM_I_MAKINUM (cstart1)); + return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - return scm_call_1 (proc_gt, SCM_I_MAKINUM (cstart1)); + return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); cstart1++; cstart2++; } if (cstart1 < cend1) - return scm_call_1 (proc_gt, SCM_I_MAKINUM (cstart1)); + return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); else if (cstart2 < cend2) - return scm_call_1 (proc_lt, SCM_I_MAKINUM (cstart1)); + return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); else - return scm_call_1 (proc_eq, SCM_I_MAKINUM (cstart1)); + return scm_call_1 (proc_eq, scm_from_size_t (cstart1)); } #undef FUNC_NAME @@ -1005,8 +990,8 @@ SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0, "value otherwise.") #define FUNC_NAME s_scm_string_eq { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1029,7 +1014,7 @@ SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0, else if (cstart2 < cend2) return SCM_BOOL_F; else - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); } #undef FUNC_NAME @@ -1040,8 +1025,8 @@ SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0, "value otherwise.") #define FUNC_NAME s_scm_string_neq { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1053,16 +1038,16 @@ SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (cstr1[cstart1] < cstr2[cstart2]) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else if (cstr1[cstart1] > cstr2[cstart2]) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); cstart1++; cstart2++; } if (cstart1 < cend1) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else if (cstart2 < cend2) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else return SCM_BOOL_F; } @@ -1075,8 +1060,8 @@ SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0, "true value otherwise.") #define FUNC_NAME s_scm_string_lt { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1088,7 +1073,7 @@ SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (cstr1[cstart1] < cstr2[cstart2]) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else if (cstr1[cstart1] > cstr2[cstart2]) return SCM_BOOL_F; cstart1++; @@ -1097,7 +1082,7 @@ SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0, if (cstart1 < cend1) return SCM_BOOL_F; else if (cstart2 < cend2) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else return SCM_BOOL_F; } @@ -1110,8 +1095,8 @@ SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0, "true value otherwise.") #define FUNC_NAME s_scm_string_gt { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1125,12 +1110,12 @@ SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0, if (cstr1[cstart1] < cstr2[cstart2]) return SCM_BOOL_F; else if (cstr1[cstart1] > cstr2[cstart2]) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); cstart1++; cstart2++; } if (cstart1 < cend1) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else if (cstart2 < cend2) return SCM_BOOL_F; else @@ -1145,8 +1130,8 @@ SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0, "value otherwise.") #define FUNC_NAME s_scm_string_le { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1158,7 +1143,7 @@ SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (cstr1[cstart1] < cstr2[cstart2]) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else if (cstr1[cstart1] > cstr2[cstart2]) return SCM_BOOL_F; cstart1++; @@ -1167,9 +1152,9 @@ SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0, if (cstart1 < cend1) return SCM_BOOL_F; else if (cstart2 < cend2) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); } #undef FUNC_NAME @@ -1180,8 +1165,8 @@ SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0, "otherwise.") #define FUNC_NAME s_scm_string_ge { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1195,16 +1180,16 @@ SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0, if (cstr1[cstart1] < cstr2[cstart2]) return SCM_BOOL_F; else if (cstr1[cstart1] > cstr2[cstart2]) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); cstart1++; cstart2++; } if (cstart1 < cend1) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else if (cstart2 < cend2) return SCM_BOOL_F; else - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); } #undef FUNC_NAME @@ -1216,8 +1201,8 @@ SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_ci_eq { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1240,7 +1225,7 @@ SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0, else if (cstart2 < cend2) return SCM_BOOL_F; else - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); } #undef FUNC_NAME @@ -1252,8 +1237,8 @@ SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_ci_neq { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1265,16 +1250,16 @@ SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); cstart1++; cstart2++; } if (cstart1 < cend1) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else if (cstart2 < cend2) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else return SCM_BOOL_F; } @@ -1288,8 +1273,8 @@ SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_ci_lt { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1301,7 +1286,7 @@ SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) return SCM_BOOL_F; cstart1++; @@ -1310,7 +1295,7 @@ SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0, if (cstart1 < cend1) return SCM_BOOL_F; else if (cstart2 < cend2) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else return SCM_BOOL_F; } @@ -1324,8 +1309,8 @@ SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_ci_gt { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1339,12 +1324,12 @@ SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0, if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) return SCM_BOOL_F; else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); cstart1++; cstart2++; } if (cstart1 < cend1) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else if (cstart2 < cend2) return SCM_BOOL_F; else @@ -1360,8 +1345,8 @@ SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_ci_le { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1373,7 +1358,7 @@ SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) return SCM_BOOL_F; cstart1++; @@ -1382,9 +1367,9 @@ SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0, if (cstart1 < cend1) return SCM_BOOL_F; else if (cstart2 < cend2) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); } #undef FUNC_NAME @@ -1396,8 +1381,8 @@ SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_ci_ge { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1411,16 +1396,16 @@ SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0, if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) return SCM_BOOL_F; else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); cstart1++; cstart2++; } if (cstart1 < cend1) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); else if (cstart2 < cend2) return SCM_BOOL_F; else - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); } #undef FUNC_NAME @@ -1431,9 +1416,9 @@ SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0, "strings.") #define FUNC_NAME s_scm_string_prefix_length { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; - int len = 0; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1444,12 +1429,12 @@ SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (cstr1[cstart1] != cstr2[cstart2]) - return SCM_I_MAKINUM (len); + return scm_from_size_t (len); len++; cstart1++; cstart2++; } - return SCM_I_MAKINUM (len); + return scm_from_size_t (len); } #undef FUNC_NAME @@ -1460,9 +1445,9 @@ SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0, "strings, ignoring character case.") #define FUNC_NAME s_scm_string_prefix_length_ci { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; - int len = 0; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1473,12 +1458,12 @@ SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2])) - return SCM_I_MAKINUM (len); + return scm_from_size_t (len); len++; cstart1++; cstart2++; } - return SCM_I_MAKINUM (len); + return scm_from_size_t (len); } #undef FUNC_NAME @@ -1489,9 +1474,9 @@ SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0, "strings.") #define FUNC_NAME s_scm_string_suffix_length { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; - int len = 0; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1504,10 +1489,10 @@ SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0, cend1--; cend2--; if (cstr1[cend1] != cstr2[cend2]) - return SCM_I_MAKINUM (len); + return scm_from_size_t (len); len++; } - return SCM_I_MAKINUM (len); + return scm_from_size_t (len); } #undef FUNC_NAME @@ -1518,9 +1503,9 @@ SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0, "strings, ignoring character case.") #define FUNC_NAME s_scm_string_suffix_length_ci { - char * cstr1, * cstr2; - int cstart1, cend1, cstart2, cend2; - int len = 0; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1533,10 +1518,10 @@ SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0, cend1--; cend2--; if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2])) - return SCM_I_MAKINUM (len); + return scm_from_size_t (len); len++; } - return SCM_I_MAKINUM (len); + return scm_from_size_t (len); } #undef FUNC_NAME @@ -1546,9 +1531,9 @@ SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0, "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; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0, len1; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1575,9 +1560,9 @@ SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0, "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; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0, len1; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1604,9 +1589,9 @@ SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0, "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; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0, len1; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1633,9 +1618,9 @@ SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0, "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; + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0, len1; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 3, start1, cstart1, @@ -1676,8 +1661,8 @@ SCM_DEFINE (scm_string_indexS, "string-index", 2, 2, 0, "@end itemize") #define FUNC_NAME s_scm_string_indexS { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 3, start, cstart, @@ -1688,7 +1673,7 @@ SCM_DEFINE (scm_string_indexS, "string-index", 2, 2, 0, while (cstart < cend) { if (cchr == cstr[cstart]) - return SCM_I_MAKINUM (cstart); + return scm_from_size_t (cstart); cstart++; } } @@ -1697,7 +1682,7 @@ SCM_DEFINE (scm_string_indexS, "string-index", 2, 2, 0, while (cstart < cend) { if (SCM_CHARSET_GET (char_pred, cstr[cstart])) - return SCM_I_MAKINUM (cstart); + return scm_from_size_t (cstart); cstart++; } } @@ -1709,7 +1694,8 @@ SCM_DEFINE (scm_string_indexS, "string-index", 2, 2, 0, SCM res; res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (scm_is_true (res)) - return SCM_I_MAKINUM (cstart); + return scm_from_size_t (cstart); + cstr = scm_i_string_chars (s); cstart++; } } @@ -1735,8 +1721,8 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, "@end itemize") #define FUNC_NAME s_scm_string_index_right { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 3, start, cstart, @@ -1748,7 +1734,7 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, { cend--; if (cchr == cstr[cend]) - return SCM_I_MAKINUM (cend); + return scm_from_size_t (cend); } } else if (SCM_CHARSETP (char_pred)) @@ -1757,7 +1743,7 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, { cend--; if (SCM_CHARSET_GET (char_pred, cstr[cend])) - return SCM_I_MAKINUM (cend); + return scm_from_size_t (cend); } } else @@ -1769,7 +1755,8 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, cend--; res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend])); if (scm_is_true (res)) - return SCM_I_MAKINUM (cend); + return scm_from_size_t (cend); + cstr = scm_i_string_chars (s); } } return SCM_BOOL_F; @@ -1795,8 +1782,8 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, "@end itemize") #define FUNC_NAME s_scm_string_skip { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 3, start, cstart, @@ -1807,7 +1794,7 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, while (cstart < cend) { if (cchr != cstr[cstart]) - return SCM_I_MAKINUM (cstart); + return scm_from_size_t (cstart); cstart++; } } @@ -1816,7 +1803,7 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, while (cstart < cend) { if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) - return SCM_I_MAKINUM (cstart); + return scm_from_size_t (cstart); cstart++; } } @@ -1828,7 +1815,8 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, SCM res; res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (scm_is_false (res)) - return SCM_I_MAKINUM (cstart); + return scm_from_size_t (cstart); + cstr = scm_i_string_chars (s); cstart++; } } @@ -1847,7 +1835,7 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, "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" + "does not satisfy the predicate @var{char_pred}, if it is a\n" "procedure,\n" "\n" "@item\n" @@ -1855,8 +1843,8 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, "@end itemize") #define FUNC_NAME s_scm_string_skip_right { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 3, start, cstart, @@ -1868,7 +1856,7 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, { cend--; if (cchr != cstr[cend]) - return SCM_I_MAKINUM (cend); + return scm_from_size_t (cend); } } else if (SCM_CHARSETP (char_pred)) @@ -1877,7 +1865,7 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, { cend--; if (!SCM_CHARSET_GET (char_pred, cstr[cend])) - return SCM_I_MAKINUM (cend); + return scm_from_size_t (cend); } } else @@ -1889,7 +1877,8 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, cend--; res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend])); if (scm_is_false (res)) - return SCM_I_MAKINUM (cend); + return scm_from_size_t (cend); + cstr = scm_i_string_chars (s); } } return SCM_BOOL_F; @@ -1914,9 +1903,9 @@ SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0, "@end itemize") #define FUNC_NAME s_scm_string_count { - char * cstr; - int cstart, cend; - int count = 0; + const char *cstr; + size_t cstart, cend; + size_t count = 0; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 3, start, cstart, @@ -1949,10 +1938,11 @@ SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0, res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (scm_is_true (res)) count++; + cstr = scm_i_string_chars (s); cstart++; } } - return SCM_I_MAKINUM (count); + return scm_from_size_t (count); } #undef FUNC_NAME @@ -1968,9 +1958,9 @@ SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0, "indicated substrings.") #define FUNC_NAME s_scm_string_contains { - char * cs1, * cs2; - int cstart1, cend1, cstart2, cend2; - int len2, i, j; + const char *cs1, * cs2; + size_t cstart1, cend1, cstart2, cend2; + size_t len2, i, j; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, 3, start1, cstart1, @@ -1989,7 +1979,7 @@ SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0, j++; } if (j == cend2) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); cstart1++; } return SCM_BOOL_F; @@ -2009,9 +1999,9 @@ SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_contains_ci { - char * cs1, * cs2; - int cstart1, cend1, cstart2, cend2; - int len2, i, j; + const char *cs1, * cs2; + size_t cstart1, cend1, cstart2, cend2; + size_t len2, i, j; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, 3, start1, cstart1, @@ -2031,7 +2021,7 @@ SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0, j++; } if (j == cend2) - return SCM_I_MAKINUM (cstart1); + return scm_from_size_t (cstart1); cstart1++; } return SCM_BOOL_F; @@ -2044,10 +2034,13 @@ SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0, static SCM string_upcase_x (SCM v, int start, int end) { - unsigned long k; + size_t k; + char *dst; + dst = scm_i_string_writable_chars (v); for (k = start; k < end; ++k) - SCM_STRING_UCHARS (v) [k] = scm_c_upcase (SCM_STRING_UCHARS (v) [k]); + dst[k] = scm_c_upcase (dst[k]); + scm_i_string_stop_writing (); return v; } @@ -2067,8 +2060,8 @@ SCM_DEFINE (scm_string_upcase_xS, "string-upcase!", 1, 2, 0, "@end lisp") #define FUNC_NAME s_scm_string_upcase_xS { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, 2, start, cstart, @@ -2085,8 +2078,8 @@ SCM_DEFINE (scm_string_upcaseS, "string-upcase", 1, 2, 0, "Upcase every character in @code{str}.") #define FUNC_NAME s_scm_string_upcaseS { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, 2, start, cstart, @@ -2101,10 +2094,13 @@ SCM_DEFINE (scm_string_upcaseS, "string-upcase", 1, 2, 0, static SCM string_downcase_x (SCM v, int start, int end) { - unsigned long k; + size_t k; + char *dst; + dst = scm_i_string_writable_chars (v); for (k = start; k < end; ++k) - SCM_STRING_UCHARS (v) [k] = scm_c_downcase (SCM_STRING_UCHARS (v) [k]); + dst[k] = scm_c_downcase (dst[k]); + scm_i_string_stop_writing (); return v; } @@ -2126,8 +2122,8 @@ SCM_DEFINE (scm_string_downcase_xS, "string-downcase!", 1, 2, 0, "@end lisp") #define FUNC_NAME s_scm_string_downcase_xS { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, 2, start, cstart, @@ -2144,8 +2140,8 @@ SCM_DEFINE (scm_string_downcaseS, "string-downcase", 1, 2, 0, "Downcase every character in @var{str}.") #define FUNC_NAME s_scm_string_downcaseS { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, 2, start, cstart, @@ -2160,10 +2156,11 @@ SCM_DEFINE (scm_string_downcaseS, "string-downcase", 1, 2, 0, static SCM string_titlecase_x (SCM str, int start, int end) { - unsigned char * sz; - int i, in_word = 0; + unsigned char *sz; + size_t i; + int in_word = 0; - sz = SCM_STRING_UCHARS (str); + sz = scm_i_string_writable_chars (str); for(i = start; i < end; i++) { if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i])))) @@ -2181,6 +2178,8 @@ string_titlecase_x (SCM str, int start, int end) else in_word = 0; } + scm_i_string_stop_writing (); + return str; } @@ -2191,8 +2190,8 @@ SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0, "@var{str}.") #define FUNC_NAME s_scm_string_titlecase_x { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, 2, start, cstart, @@ -2207,8 +2206,8 @@ SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0, "Titlecase every first character in a word in @var{str}.") #define FUNC_NAME s_scm_string_titlecase { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, 2, start, cstart, @@ -2244,16 +2243,18 @@ SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0, "operate on.") #define FUNC_NAME s_scm_string_reverse { - char * cstr; - int cstart; - int cend; + const char *cstr; + char *ctarget; + size_t cstart, cend; SCM result; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, 2, start, cstart, 3, end, cend); result = scm_string_copy (str); - string_reverse_x (SCM_STRING_CHARS (result), cstart, cend); + ctarget = scm_i_string_writable_chars (result); + string_reverse_x (ctarget, cstart, cend); + scm_i_string_stop_writing (); return result; } #undef FUNC_NAME @@ -2266,14 +2267,18 @@ SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0, "operate on. The return value is unspecified.") #define FUNC_NAME s_scm_string_reverse_x { - char * cstr; - int cstart; - int cend; + char *cstr; + size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - string_reverse_x (SCM_STRING_CHARS (str), cstart, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 2, start, cstart, + 3, end, cend); + + cstr = scm_i_string_writable_chars (str); + string_reverse_x (cstr, cstart, cend); + scm_i_string_stop_writing (); + + scm_remember_upto_here_1 (str); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -2308,8 +2313,8 @@ SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0, { long strings = scm_ilength (ls); SCM tmp, result; - int len = 0; - char * p; + size_t len = 0; + char *p; /* Validate the string list. */ if (strings < 0) @@ -2321,20 +2326,19 @@ SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0, { SCM elt = SCM_CAR (tmp); SCM_VALIDATE_STRING (1, elt); - len += SCM_STRING_LENGTH (elt); + len += scm_i_string_length (elt); tmp = SCM_CDR (tmp); } - result = scm_allocate_string (len); + result = scm_i_make_string (len, &p); /* 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); + memmove (p, scm_i_string_chars (elt), + scm_i_string_length (elt)); + p += scm_i_string_length (elt); tmp = SCM_CDR (tmp); } return result; @@ -2373,11 +2377,12 @@ SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, if (!SCM_UNBNDP (end)) { cend = scm_to_unsigned_integer (end, - 0, SCM_STRING_LENGTH (final_string)); + 0, + scm_i_string_length (final_string)); } else { - cend = SCM_STRING_LENGTH (final_string); + cend = scm_i_string_length (final_string); } len += cend; } @@ -2392,28 +2397,28 @@ SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, { SCM elt = SCM_CAR (tmp); SCM_VALIDATE_STRING (1, elt); - len += SCM_STRING_LENGTH (elt); + len += scm_i_string_length (elt); tmp = SCM_CDR (tmp); } - result = scm_allocate_string (len); + result = scm_i_make_string (len, &p); - p = SCM_STRING_CHARS (result) + len; + p += 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)); + memmove (p, scm_i_string_chars (final_string), cend); } 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)); + p -= scm_i_string_length (elt); + memmove (p, scm_i_string_chars (elt), + scm_i_string_length (elt)); tmp = SCM_CDR (tmp); } return result; @@ -2458,22 +2463,23 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, "string elements is not specified.") #define FUNC_NAME s_scm_string_map { - char * cstr, *p; - int cstart, cend; + const char *cstr; + char *p; + size_t cstart, cend; SCM result; SCM_VALIDATE_PROC (1, proc); MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, 3, start, cstart, 4, end, cend); - result = scm_allocate_string (cend - cstart); - p = SCM_STRING_CHARS (result); + result = scm_i_make_string (cend - cstart, &p); while (cstart < cend) { unsigned int c = (unsigned char) cstr[cstart]; SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (c)); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); + cstr = scm_i_string_chars (s); cstart++; *p++ = SCM_CHAR (ch); } @@ -2490,22 +2496,19 @@ SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0, "modified in-place, the return value is not specified.") #define FUNC_NAME s_scm_string_map_x { - char * cstr, *p; - int cstart, cend; + size_t cstart, cend; SCM_VALIDATE_PROC (1, proc); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); - p = SCM_STRING_CHARS (s) + cstart; + MY_VALIDATE_SUBSTRING_SPEC (2, s, + 3, start, cstart, + 4, end, cend); while (cstart < cend) { - unsigned int c = (unsigned char) cstr[cstart]; - SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (c)); + SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart)); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); + scm_c_string_set_x (s, cstart, ch); cstart++; - *p++ = SCM_CHAR (ch); } return SCM_UNSPECIFIED; } @@ -2520,8 +2523,8 @@ SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0, "result of @var{kons}' application.") #define FUNC_NAME s_scm_string_fold { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; SCM result; SCM_VALIDATE_PROC (1, kons); @@ -2533,6 +2536,7 @@ SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0, { unsigned int c = (unsigned char) cstr[cstart]; result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result); + cstr = scm_i_string_chars (s); cstart++; } return result; @@ -2548,8 +2552,8 @@ SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0, "result of @var{kons}' application.") #define FUNC_NAME s_scm_string_fold_right { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; SCM result; SCM_VALIDATE_PROC (1, kons); @@ -2561,6 +2565,7 @@ SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0, { unsigned int c = (unsigned char) cstr[cend - 1]; result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result); + cstr = scm_i_string_chars (s); cend--; } return result; @@ -2601,7 +2606,7 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0, ans = base; } else - ans = scm_allocate_string (0); + ans = scm_i_make_string (0, NULL); if (!SCM_UNBNDP (make_final)) SCM_VALIDATE_PROC (6, make_final); @@ -2609,11 +2614,12 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0, while (scm_is_false (res)) { SCM str; + char *ptr; SCM ch = scm_call_1 (f, seed); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); - str = scm_allocate_string (1); - *SCM_STRING_CHARS (str) = SCM_CHAR (ch); + str = scm_i_make_string (1, &ptr); + *ptr = SCM_CHAR (ch); ans = scm_string_append (scm_list_2 (ans, str)); seed = scm_call_1 (g, seed); @@ -2663,7 +2669,7 @@ SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0, ans = base; } else - ans = scm_allocate_string (0); + ans = scm_i_make_string (0, NULL); if (!SCM_UNBNDP (make_final)) SCM_VALIDATE_PROC (6, make_final); @@ -2671,11 +2677,12 @@ SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0, while (scm_is_false (res)) { SCM str; + char *ptr; SCM ch = scm_call_1 (f, seed); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); - str = scm_allocate_string (1); - *SCM_STRING_CHARS (str) = SCM_CHAR (ch); + str = scm_i_make_string (1, &ptr); + *ptr = SCM_CHAR (ch); ans = scm_string_append (scm_list_2 (str, ans)); seed = scm_call_1 (g, seed); @@ -2698,8 +2705,8 @@ SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0, "return value is not specified.") #define FUNC_NAME s_scm_string_for_each { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; SCM_VALIDATE_PROC (1, proc); MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, @@ -2709,6 +2716,7 @@ SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0, { unsigned int c = (unsigned char) cstr[cstart]; scm_call_1 (proc, SCM_MAKE_CHAR (c)); + cstr = scm_i_string_chars (s); cstart++; } return SCM_UNSPECIFIED; @@ -2721,8 +2729,8 @@ SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0, "return value is not specified.") #define FUNC_NAME s_scm_string_for_each { - char * cstr; - int cstart, cend; + const char *cstr; + size_t cstart, cend; SCM_VALIDATE_PROC (1, proc); MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, @@ -2730,7 +2738,7 @@ SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0, 4, end, cend); while (cstart < cend) { - scm_call_1 (proc, SCM_I_MAKINUM (cstart)); + scm_call_1 (proc, scm_from_size_t (cstart)); cstart++; } return SCM_UNSPECIFIED; @@ -2751,7 +2759,8 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, "defaults to @var{from} + (@var{end} - @var{start}).") #define FUNC_NAME s_scm_xsubstring { - char * cs, * p; + const char *cs; + char *p; size_t cstart, cend, cfrom, cto; SCM result; @@ -2766,9 +2775,8 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, if (cstart == cend && cfrom != cto) SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); - result = scm_allocate_string (cto - cfrom); + result = scm_i_make_string (cto - cfrom, &p); - p = SCM_STRING_CHARS (result); while (cfrom < cto) { int t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart); @@ -2779,6 +2787,7 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, cfrom++; p++; } + scm_remember_upto_here_1 (s); return result; } #undef FUNC_NAME @@ -2793,14 +2802,15 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, "cannot copy a string on top of itself.") #define FUNC_NAME s_scm_string_xcopy_x { - char * ctarget, * cs, * p; + char *p; + const char *cs; size_t ctstart, csfrom, csto, cstart, cend; SCM dummy = SCM_UNDEFINED; int cdummy; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, target, ctarget, - 2, tstart, ctstart, - 2, dummy, cdummy); + MY_VALIDATE_SUBSTRING_SPEC (1, target, + 2, tstart, ctstart, + 2, dummy, cdummy); MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cs, 6, start, cstart, 7, end, cend); @@ -2812,9 +2822,9 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, 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)); + ctstart + (csto - csfrom) <= scm_i_string_length (target)); - p = ctarget + ctstart; + p = scm_i_string_writable_chars (target) + ctstart; while (csfrom < csto) { int t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart); @@ -2825,6 +2835,9 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, csfrom++; p++; } + scm_i_string_stop_writing (); + + scm_remember_upto_here_2 (target, s); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -2837,7 +2850,8 @@ SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0, "@var{start2} @dots{} @var{end2} from @var{s2}.") #define FUNC_NAME s_scm_string_replace { - char * cstr1, * cstr2, * p; + const char *cstr1, *cstr2; + char *p; size_t cstart1, cend1, cstart2, cend2; SCM result; @@ -2847,14 +2861,14 @@ SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0, MY_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); + result = scm_i_make_string (cstart1 + (cend2 - cstart2) + + scm_i_string_length (s1) - cend1, &p); memmove (p, cstr1, cstart1 * sizeof (char)); memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2) * sizeof (char)); memmove (p + cstart1 + (cend2 - cstart2), cstr1 + cend1, - (SCM_STRING_LENGTH (s1) - cend1) * sizeof (char)); + (scm_i_string_length (s1) - cend1) * sizeof (char)); + scm_remember_upto_here_2 (s1, s2); return result; } #undef FUNC_NAME @@ -2871,7 +2885,7 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, "of @var{s}.") #define FUNC_NAME s_scm_string_tokenize { - char * cstr; + const char *cstr; size_t cstart, cend; SCM result = SCM_EOL; @@ -2915,10 +2929,12 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, break; cend--; } - result = scm_cons (scm_mem2string (cstr + cend, idx - cend), result); + result = scm_cons (scm_c_substring (s, cend, idx), result); + cstr = scm_i_string_chars (s); } } else SCM_WRONG_TYPE_ARG (2, token_set); + scm_remember_upto_here_1 (s); return result; } #undef FUNC_NAME @@ -2933,10 +2949,10 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, "character set, it is tested for membership.") #define FUNC_NAME s_scm_string_filter { - char * cstr; + const char *cstr; size_t cstart, cend; SCM result; - int idx; + size_t idx; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 3, start, cstart, @@ -2952,6 +2968,7 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, { if (cstr[idx] == chr) ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + cstr = scm_i_string_chars (s); idx++; } result = scm_reverse_list_to_string (ls); @@ -2965,6 +2982,7 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, { if (SCM_CHARSET_GET (char_pred, cstr[idx])) ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + cstr = scm_i_string_chars (s); idx++; } result = scm_reverse_list_to_string (ls); @@ -2981,10 +2999,12 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx])); if (scm_is_true (res)) ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + cstr = scm_i_string_chars (s); idx++; } result = scm_reverse_list_to_string (ls); } + scm_remember_upto_here_1 (s); return result; } #undef FUNC_NAME @@ -2999,10 +3019,10 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, "character set, it is tested for membership.") #define FUNC_NAME s_scm_string_delete { - char * cstr; + const char *cstr; size_t cstart, cend; SCM result; - int idx; + size_t idx; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, 3, start, cstart, @@ -3018,6 +3038,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, { if (cstr[idx] != chr) ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + cstr = scm_i_string_chars (s); idx++; } result = scm_reverse_list_to_string (ls); @@ -3031,6 +3052,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, { if (!SCM_CHARSET_GET (char_pred, cstr[idx])) ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + cstr = scm_i_string_chars (s); idx++; } result = scm_reverse_list_to_string (ls); @@ -3047,6 +3069,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx])); if (scm_is_false (res)) ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + cstr = scm_i_string_chars (s); idx++; } result = scm_reverse_list_to_string (ls); diff --git a/srfi/srfi-13.h b/srfi/srfi-13.h index 0f082b9ce..68def2842 100644 --- a/srfi/srfi-13.h +++ b/srfi/srfi-13.h @@ -2,7 +2,7 @@ #define SCM_SRFI_13_H /* srfi-13.c --- SRFI-13 procedures for Guile * - * Copyright (C) 2001 Free Software Foundation, Inc. + * Copyright (C) 2001, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -42,7 +42,7 @@ SCM_SRFI1314_API SCM scm_string_to_listS (SCM str, SCM start, SCM end); SCM_SRFI1314_API SCM scm_reverse_list_to_string (SCM chrs); SCM_SRFI1314_API SCM scm_string_join (SCM ls, SCM delimiter, SCM grammar); SCM_SRFI1314_API SCM scm_string_copyS (SCM str, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_substring_shared (SCM str, SCM start, SCM end); +SCM_SRFI1314_API SCM scm_substring_sharedS (SCM str, SCM start, SCM end); SCM_SRFI1314_API SCM scm_string_copy_x (SCM target, SCM tstart, SCM s, SCM start, SCM end); SCM_SRFI1314_API SCM scm_string_take (SCM s, SCM n); SCM_SRFI1314_API SCM scm_string_drop (SCM s, SCM n); From f26b9395457339328acd21b01713c7c3cf3b5fe4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:22:35 +0000 Subject: [PATCH 017/100] *** empty log message *** --- libguile/ChangeLog | 71 ++++++++++++++++++++++++++++++++++++++++++++++ srfi/ChangeLog | 11 +++++++ 2 files changed, 82 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c33080565..04a6fd9d4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,74 @@ +2004-08-19 Marius Vollmer + + New string implementation, with copy-on-write strings and + mutation-sharing substrings, and a new internal string API. + Symbols can now share memory with strings. + + * tags.h (scm_tc7_stringbuf): New tag. + + * strings.h, strings.c: (scm_i_string_chars, scm_i_string_length, + scm_i_string_writable_chars, scm_i_string_stop_writing): New, to + replace SCM_I_STRING_CHARS and SCM_I_STRING_LENGTH. Updated all + uses. + (scm_i_make_string, scm_c_make_string): New, to replace + scm_allocate_string. Updated all uses. + (SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_UCHARS, + SCM_STRING_LENGTH): Deprecated. + (scm_allocate_string, scm_take_str, scm_take0str, scm_mem2string, + scm_str2string, scm_makfrom0str, scm_makfrom0str_opt): + Discouraged. Replaced all uses with scm_from_locale_string or + similar, as appropriate. + (scm_c_string_length, scm_c_string_ref, scm_c_string_set_x, + scm_c_substring, scm_c_substring_shared, scm_c_substring_copy, + scm_substring_shared, scm_substring_copy): New. + + * symbols.c, symbols.h (SCM_SYMBOLP, SCM_SYMBOL_FUNC, + SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, SCM_SET_SYMBOL_PROPS, + SCM_SYMBOL_HASH, SCM_SYMBOL_INTERNED_P, scm_mem2symbol, + scm_str2symbol, scm_mem2uninterned_symbol): Discouraged. + (SCM_SYMBOL_LENGTH, SCM_SYMBOL_CHARS, scm_c_symbol2str): + Deprecated. + (SCM_MAKE_SYMBOL_TAG, SCM_SET_SYMBOL_LENGTH, SCM_SET_SYMBOL_CHARS, + SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS): Removed. + (scm_is_symbol, scm_from_locale_symbol, scm_from_locale_symboln): + New, to replace scm_str2symbol and scm_mem2symbol, respectively. + Updated all uses. + (scm_gensym): Generate only the number suffix in the buffer, just + string-append the prefix. + + * error.c (scm_memory_error): Do not try to throw, just abort. + Throwing will not work anyway. + + * gh.h, gh-data.c (gh_set_substr): Made src const. + + * ports.c (scm_i_mode_bits_n): New, for counted strings. + (scm_mode_bits): Use it. + (scm_c_port_for_each): Blocking GC does not seem to work, allocate + a vector normally and fill that instead of consing a list with a + blocked GC. + + * read.c (scm_i_casei_streq): New, for counted strings. + + * threads.c (gc_section_count): Removed, thread-sleeping can not + be nested. + (scm_i_thread_put_to_sleep): Call scm_i_leave_guile before locking + admin mutex so that we can be put to sleep by other threads while + blocking on that mutex. Lock all the heap mutex of all threads, + including ourselves. + (scm_i_thread_wake_up): Unlock all threads, including ourselves, + call scm_i_enter_guile. + (scm_thread_mark_stacks): Expect all threads to be suspended. + + * gc.h, gc.c (scm_i_gc_admin_mutex): New, to protect + scm_gc_mallocated, for now. + (scm_init_storage): Initialize it. + * gc-malloc.c (descrease_mtrigger, increase_mtrigger): Use it. + + * gc-mark.c (scm_gc_mark_dependencies): Call scm_i_string_mark, + scm_i_stringbuf_mark and scm_i_symbol_mark, as appropriate. + * gc-card.c (scm_i_sweep_card): Call scm_i_string_free, + scm_i_stringbuf_free and scm_i_symbol_free, as appropriate. + 2004-08-18 Kevin Ryde * arbiters.c (FETCH_STORE): New macro. diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 3219b470e..b91814d77 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,14 @@ +2004-08-19 Marius Vollmer + + * srfi-13.h, srfi-13.c: (scm_substring_shared): Renamed to + scm_substring_sharedS. + + * srfi-14.c, srfi-13.c: Adapted to new internal string and symbol + API. + + * srfi-13.scm (substring/shared): Export as replacement since we + now have a version in the core. + 2004-08-15 Marius Vollmer * srfi-39.scm: New, from Jose A Ortega Ruiz. Thanks! From ad6dec055f951c8571439fdfd2a30a4c3250001a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:28:53 +0000 Subject: [PATCH 018/100] Avoid the use of discouraged or deprecated things. --- guile-readline/readline.c | 49 ++++++++++++++----------- test-suite/standalone/test-conversion.c | 6 +-- test-suite/standalone/test-gh.c | 8 ++-- test-suite/standalone/test-unwind.c | 8 ++-- 4 files changed, 39 insertions(+), 32 deletions(-) diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 9f7b39df0..c0fe8ec6e 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -165,7 +165,7 @@ SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, if (!SCM_UNBNDP (text)) { - if (!SCM_STRINGP (text)) + if (!scm_is_string (text)) { --in_readline; scm_wrong_type_arg (s_scm_readline, SCM_ARG1, text); @@ -253,15 +253,17 @@ internal_readline (SCM text) { SCM ret; char *s; - char *prompt = SCM_UNBNDP (text) ? "" : SCM_STRING_CHARS (text); + char *prompt = SCM_UNBNDP (text) ? "" : scm_to_locale_string (text); promptp = 1; s = readline (prompt); if (s) - ret = scm_makfrom0str (s); + ret = scm_from_locale_string (s); else ret = SCM_EOF_VAL; + if (!SCM_UNBNDP (text)) + free (prompt); free (s); return ret; @@ -326,10 +328,9 @@ SCM_DEFINE (scm_add_history, "add-history", 1, 0, 0, #define FUNC_NAME s_scm_add_history { char* s; - SCM_VALIDATE_STRING (1,text); - s = SCM_STRING_CHARS (text); - add_history (strdup (s)); + s = scm_to_locale_string (text); + add_history (s); return SCM_UNSPECIFIED; } @@ -341,8 +342,13 @@ SCM_DEFINE (scm_read_history, "read-history", 1, 0, 0, "") #define FUNC_NAME s_scm_read_history { - SCM_VALIDATE_STRING (1,file); - return scm_from_bool (!read_history (SCM_STRING_CHARS (file))); + char *filename; + SCM ret; + + filename = scm_to_locale_string (file); + ret = scm_from_bool (!read_history (filename)); + free (filename); + return ret; } #undef FUNC_NAME @@ -352,8 +358,13 @@ SCM_DEFINE (scm_write_history, "write-history", 1, 0, 0, "") #define FUNC_NAME s_scm_write_history { - SCM_VALIDATE_STRING (1,file); - return scm_from_bool (!write_history (SCM_STRING_CHARS (file))); + char *filename; + SCM ret; + + filename = scm_to_locale_string (file); + ret = scm_from_bool (!write_history (filename)); + free (filename); + return ret; } #undef FUNC_NAME @@ -375,14 +386,14 @@ SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, { char *s; SCM ans; - SCM_VALIDATE_STRING (1,text); + char *c_text = scm_to_locale_string (text); #ifdef HAVE_RL_FILENAME_COMPLETION_FUNCTION - s = rl_filename_completion_function (SCM_STRING_CHARS (text), scm_is_true (continuep)); + s = rl_filename_completion_function (c_text, scm_is_true (continuep)); #else - s = filename_completion_function (SCM_STRING_CHARS (text), scm_is_true (continuep)); + s = filename_completion_function (c_text, scm_is_true (continuep)); #endif - ans = scm_makfrom0str (s); - free (s); + ans = scm_take_locale_string (s); + free (c_text); return ans; } #undef FUNC_NAME @@ -404,18 +415,14 @@ completion_function (char *text, int continuep) return NULL; /* #f => completion disabled */ else { - SCM t = scm_makfrom0str (text); + SCM t = scm_from_locale_string (text); SCM c = scm_from_bool (continuep); res = scm_apply (compfunc, scm_list_2 (t, c), SCM_EOL); if (scm_is_false (res)) return NULL; - if (!SCM_STRINGP (res)) - scm_misc_error (s_scm_readline, - "Completion function returned bogus value: %S", - scm_list_1 (res)); - return strdup (SCM_STRING_CHARS (res)); + return scm_to_locale_string (res); } } diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c index ff246325f..fcadde981 100644 --- a/test-suite/standalone/test-conversion.c +++ b/test-suite/standalone/test-conversion.c @@ -188,19 +188,19 @@ typedef struct { static SCM out_of_range_handler (void *data, SCM key, SCM args) { - return scm_equal_p (key, scm_str2symbol ("out-of-range")); + return scm_equal_p (key, scm_from_locale_symbol ("out-of-range")); } static SCM wrong_type_handler (void *data, SCM key, SCM args) { - return scm_equal_p (key, scm_str2symbol ("wrong-type-arg")); + return scm_equal_p (key, scm_from_locale_symbol ("wrong-type-arg")); } static SCM misc_error_handler (void *data, SCM key, SCM args) { - return scm_equal_p (key, scm_str2symbol ("misc-error")); + return scm_equal_p (key, scm_from_locale_symbol ("misc-error")); } static SCM diff --git a/test-suite/standalone/test-gh.c b/test-suite/standalone/test-gh.c index 99527376a..a00cea3d5 100644 --- a/test-suite/standalone/test-gh.c +++ b/test-suite/standalone/test-gh.c @@ -29,8 +29,8 @@ string_equal (SCM str, char *lit) int len = strlen (lit); int result; - result = ((SCM_STRING_LENGTH (str) == len) - && (!memcmp (SCM_STRING_CHARS (str), lit, len))); + result = ((scm_i_string_length (str) == len) + && (!memcmp (scm_i_string_chars (str), lit, len))); scm_remember_upto_here_1 (str); return result; } @@ -54,14 +54,14 @@ test_gh_set_substr () code if you have to copy the string just to look at it. */ /* Copy a substring to an overlapping region to its right. */ - gh_set_substr (SCM_STRING_CHARS (string), string, 4, 6); + gh_set_substr (scm_i_string_chars (string), string, 4, 6); assert (string_equal (string, "FreeFree, it!")); string = gh_str02scm ("Free, darnit!"); assert (gh_string_p (string)); /* Copy a substring to an overlapping region to its left. */ - gh_set_substr (SCM_STRING_CHARS (string) + 6, string, 2, 6); + gh_set_substr (scm_i_string_chars (string) + 6, string, 2, 6); assert (string_equal (string, "Frdarnitrnit!")); } diff --git a/test-suite/standalone/test-unwind.c b/test-suite/standalone/test-unwind.c index ca04df344..460f07ba2 100644 --- a/test-suite/standalone/test-unwind.c +++ b/test-suite/standalone/test-unwind.c @@ -177,8 +177,8 @@ check_ports () scm_frame_begin (0); { - SCM port = scm_open_file (scm_str2string (filename), - scm_str2string ("w")); + SCM port = scm_open_file (scm_from_locale_string (filename), + scm_from_locale_string ("w")); scm_frame_unwind_handler_with_scm (close_port, port, SCM_F_WIND_EXPLICITLY); @@ -189,8 +189,8 @@ check_ports () scm_frame_begin (0); { - SCM port = scm_open_file (scm_str2string (filename), - scm_str2string ("r")); + SCM port = scm_open_file (scm_from_locale_string (filename), + scm_from_locale_string ("r")); SCM res; scm_frame_unwind_handler_with_scm (close_port, port, SCM_F_WIND_EXPLICITLY); From b2988f465bd84d7b482a974fd89443786643173d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:30:03 +0000 Subject: [PATCH 019/100] *** empty log message *** --- guile-readline/ChangeLog | 5 +++++ test-suite/ChangeLog | 6 ++++++ 2 files changed, 11 insertions(+) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 8e5793efd..045ec2816 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,8 @@ +2004-08-19 Marius Vollmer + + * readline.c: Avoid the use of discouraged or + deprecated things. + 2004-07-06 Marius Vollmer * readline.c: Replaced all uses of deprecated SCM_FALSEP, diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index add8f35c9..c3ead36b2 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2004-08-19 Marius Vollmer + + * standalone/test-conversion.c, standalone/test-gh.c, + standalone/test-unwind.c: Avoid the use of discouraged or + deprecated things. + 2004-08-18 Kevin Ryde * tests/and-let-star.test, tests/arbiters.test, tests/receive.test: From 3ff9283dd63ed0cddc5a8b3dfd7725377ed2b9a2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 17:54:37 +0000 Subject: [PATCH 020/100] *** empty log message *** --- NEWS | 57 ++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 54 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 10b133173..3e0e2ebd8 100644 --- a/NEWS +++ b/NEWS @@ -163,6 +163,12 @@ be used with '-e'. For example, you can now write a script like * Changes to Scheme functions and syntax +** There is now support for copy-on-write substrings and + mutation-sharing substrings. + +Two new procedures are related to this: substring/shared and +substring/copy. See the manual for more information. + ** New syntax '@' and '@@': You can now directly refer to variables exported from a module by @@ -687,12 +693,57 @@ conventions. These functions occupy the names that scm_round_number and scm_truncate_number should have. -** The functions scm_c_string2str and scm_c_substring2str have been - deprecated. +** The functions scm_c_string2str, scm_c_substring2str, and + scm_c_symbol2str have been deprecated. Use scm_to_locale_stringbuf or similar instead, maybe together with scm_substring. +** New functions scm_c_make_string, scm_c_string_length, + scm_c_string_ref, scm_c_string_set_x, scm_c_substring, + scm_c_substring_shared, scm_c_substring_copy. + +These are like scm_make_string, scm_length, etc. but are slightly +easier to use from C. + +** The macros SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_LENGTH, + SCM_SYMBOL_CHARS, and SCM_SYMBOL_LENGTH have been deprecated. + +They export too many assumptions about the implementation of strings +and symbols that are no longer true in the presence of +mutation-sharing substrings and later, when Guile switches to some +form of Unicode. + +When working with strings, it is often best to use the normal string +functions provided by Guile, such as scm_c_string_ref, +scm_c_string_set_x, scm_string_append, etc. + +When you want to convert a SCM string to a C string, use the +scm_to_locale_string function or similar instead. For symbols, use +scm_symbol_to_string and then work with that string. Because of the +new string representation, scm_symbol_to_string does not need to copy +and is thus quite efficient. + +** Some string and symbol functions have been discouraged. + +They don't fot into the uniform naming scheme and are not explicit +about the character encoding. + +Replace according to the following table: + + scm_allocate_string -> scm_c_make_string + scm_take_str -> scm_take_locale_stringn + scm_take0str -> scm_take_locale_string + scm_mem2string -> scm_from_locale_stringn + scm_str2string -> scm_from_locale_string + scm_makfrom0str -> scm_from_locale_string + scm_mem2symbol -> scm_from_locale_symboln + scm_mem2uninterned_symbol -> scm_make_symbol + scm_from_locale_stringn + scm_str2symbol -> scm_from_locale_symbol + + SCM_SYMBOL_HASH -> scm_hashq + SCM_SYMBOL_INTERNED_P -> scm_symbol_interned_p + ** SCM_CELL_WORD_LOC has been deprecated. Use the new macro SCM_CELL_OBJECT_LOC instead, which return a pointer @@ -703,7 +754,7 @@ heap. Previously, the heap words were of type scm_t_bits and local variables and function arguments were of type SCM, making it non-standards-conformant to have a pointer that can point to both. -** New macros SCM_SMOB_DATA_2, SM_SMOB_DATA_3, etc. +** New macros SCM_SMOB_DATA_2, SCM_SMOB_DATA_3, etc. These macros should be used instead of SCM_CELL_WORD_2/3 to access the second and third words of double smobs. Likewise for From d6a1cb3cc672ac2f73fe69fd3fa33036540b1d00 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 18:41:05 +0000 Subject: [PATCH 021/100] (scm_string_copy): Use scm_c_substring to get a copy-on-write string. --- libguile/strop.c | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/libguile/strop.c b/libguile/strop.c index b4a7063cf..e964879fa 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -274,9 +274,7 @@ SCM_DEFINE (scm_string_copy, "string-copy", 1, 0, 0, "Return a newly allocated copy of the given @var{string}.") #define FUNC_NAME s_scm_string_copy { - SCM_VALIDATE_STRING (1, str); - - return string_copy (str); + return scm_c_substring (str, 0, scm_c_string_length (str)); } #undef FUNC_NAME From cd505b38ad52348aa54abc4dd195198f2d95fca9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 18:41:17 +0000 Subject: [PATCH 022/100] *** empty log message *** --- libguile/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 04a6fd9d4..af10e6b36 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -69,6 +69,9 @@ * gc-card.c (scm_i_sweep_card): Call scm_i_string_free, scm_i_stringbuf_free and scm_i_symbol_free, as appropriate. + * strop.c (scm_string_copy): Use scm_c_substring to get a + copy-on-write string. + 2004-08-18 Kevin Ryde * arbiters.c (FETCH_STORE): New macro. From c48c62d0857ebe5a939a441f35102c4df03a13c2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 18:53:40 +0000 Subject: [PATCH 023/100] (Strings): Document copy-on-write behavior and mutation-sharing substrings. (Symbols): Document scm_from_locale_symbol and scm_from_locale_symboln. --- doc/ref/api-data.texi | 112 +++++++++++++++++++++++++++++++++++------- 1 file changed, 93 insertions(+), 19 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 6601c96da..28e580ffc 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1859,10 +1859,38 @@ entered at the @acronym{REPL} or in Scheme source files. Strings always carry the information about how many characters they are composed of with them, so there is no special end-of-string character, like in C. That means that Scheme strings can contain any character, -even the @samp{NUL} character @samp{\0}. But note: Since most operating -system calls dealing with strings (such as for file operations) expect -strings to be zero-terminated, they might do unexpected things when -called with string containing unusual characters. +even the @samp{#\nul} character @samp{\0}. + +To use strings efficiently, you need to know a bit about how Guile +implements them. In Guile, a string consists of two parts, a head and +the actual memory where the characters are stored. When a string (or +a substring of it) is copied, only a new head gets created, the memory +is usually not copied. The two heads start out pointing to the same +memory. + +When one of these two strings is modified, as with @code{string-set!}, +their common memory does get copied so that each string has its own +memory and modifying one does not accidently modify the other as well. +Thus, Guile's strings are `copy on write'; the actual copying of their +memory is delayed until one string is written to. + +This implementation makes functions like @code{substring} very +efficient in the common case that no modifications are done to the +involved strings. + +If you do know that your strings are getting modified right away, you +can use @code{substring/copy} instead of @code{substring}. This +function performs the copy immediately at the time of creation. This +is more efficient, especially in a multi-threaded program. Also, +@code{substring/copy} can avoid the problem that a short substring +holds on to the memory of a very large original string that could +otherwise be recycled. + +If you want to avoid the copy altogether, so that modifications of one +string show up in the other, you can use @code{substring/shared}. The +strings created by this procedure are called @dfn{mutation sharing +substrings} since the substring and the original string share +modifications to each other. @menu * String Syntax:: Read syntax for strings. @@ -1887,9 +1915,7 @@ called with string containing unusual characters. @c special in a string (they're not). The read syntax for strings is an arbitrarily long sequence of -characters enclosed in double quotes (@nicode{"}). @footnote{Actually, -the current implementation restricts strings to a length of -@math{2^24}, or 16,777,216, characters. Sorry.} +characters enclosed in double quotes (@nicode{"}). Backslash is an escape character and can be used to insert the following special characters. @nicode{\"} and @nicode{\\} are R5RS @@ -1972,7 +1998,9 @@ y @result{} "foo" @subsubsection String Constructors The string constructor procedures create new string objects, possibly -initializing them with some specified character data. +initializing them with some specified character data. See also +@xref{String Selection}, for ways to create strings from existing +strings. @c FIXME::martin: list->string belongs into `List/String Conversion' @@ -1994,6 +2022,11 @@ the string are initialized to @var{chr}, otherwise the contents of the @var{string} are unspecified. @end deffn +@deftypefn {C Function} SCM scm_c_make_string (size_t len, SCM chr) +Like @code{scm_make_string}, but expects the length as a +@code{size_t}. +@end deftypefn + @node List/String Conversion @subsubsection List/String conversion @@ -2047,6 +2080,10 @@ Portions of strings can be extracted by these procedures. Return the number of characters in @var{string}. @end deffn +@deftypefn {C Function} size_t scm_c_string_length (SCM str) +Return the number of characters in @var{str} as a @code{size_t}. +@end deftypefn + @rnindex string-ref @deffn {Scheme Procedure} string-ref str k @deffnx {C Function} scm_string_ref (str, k) @@ -2054,24 +2091,54 @@ Return character @var{k} of @var{str} using zero-origin indexing. @var{k} must be a valid index of @var{str}. @end deffn +@deftypefn {C Function} SCM scm_c_string_ref (SCM str, size_t k) +Return character @var{k} of @var{str} using zero-origin +indexing. @var{k} must be a valid index of @var{str}. +@end deftypefn + @rnindex string-copy @deffn {Scheme Procedure} string-copy str @deffnx {C Function} scm_string_copy (str) -Return a newly allocated copy of the given @var{string}. +Return a copy of the given @var{string}. + +The returned string shares storage with @var{str} initially, but it is +copied as soon as one of the two strings is modified. @end deffn @rnindex substring @deffn {Scheme Procedure} substring str start [end] @deffnx {C Function} scm_substring (str, start, end) -Return a newly allocated string formed from the characters +Return a new string formed from the characters of @var{str} beginning with index @var{start} (inclusive) and ending with index @var{end} (exclusive). @var{str} must be a string, @var{start} and @var{end} must be exact integers satisfying: 0 <= @var{start} <= @var{end} <= @code{(string-length @var{str})}. + +The returned string shares storage with @var{str} initially, but it is +copied as soon as one of the two strings is modified. @end deffn +@deffn {Scheme Procedure} substring/shared str start [end] +@deffnx {C Function} scm_substring_shared (str, start, end) +Like @code{substring}, but the strings continue to share their storage +even if they are modified. Thus, modifications to @var{str} show up +in the new string, and vice versa. +@end deffn + +@deffn {Scheme Procedure} substring/copy str start [end] +@deffnx {C Function} scm_substring_copy (str, start, end) +Like @code{substring}, but the storage for the new string is copied +immediately. +@end deffn + +@deftypefn {C Function} SCM scm_c_substring (SCM str, size_t start, size_t end) +@deftypefnx {C Function} SCM scm_c_substring_shared (SCM str, size_t start, size_t end) +@deftypefnx {C Function} SCM scm_c_substring_copy (SCM str, size_t start, size_t end) +Like @code{scm_substring}, etc. but the bounds are given as a @code{size_t}. +@end deftypefn + @node String Modification @subsubsection String Modification @@ -2087,6 +2154,10 @@ an unspecified value. @var{k} must be a valid index of @var{str}. @end deffn +@deftypefn {C Function} void scm_c_string_set_x (SCM str, size_t k, SCM chr) +Like @code{scm_string_set_x}, but the index is given as a @code{size_t}. +@end deftypefn + @rnindex string-fill! @deffn {Scheme Procedure} string-fill! str chr @deffnx {C Function} scm_string_fill_x (str, chr) @@ -2338,9 +2409,9 @@ the bytes, only the characters. Well, ideally, anyway. Right now, Guile simply equates Scheme characters and bytes, ignoring the possibility of multi-byte encodings completely. This will change in the future, where Guile will use -Unicode codepoints as its characters and UTF-8 (or maybe UCS-4) as its -internal encoding. When you exclusively use the functions listed in -this section, you are `future-proof'. +Unicode codepoints as its characters and UTF-8 or some other encoding +as its internal encoding. When you exclusively use the functions +listed in this section, you are `future-proof'. Converting a Scheme string to a C string will often allocate fresh memory to hold the result. You must take care that this memory is @@ -3194,14 +3265,17 @@ the case-sensitivity of symbols: @end lisp From C, there are lower level functions that construct a Scheme symbol -from a null terminated C string or from a sequence of bytes whose length -is specified explicitly. +from a C string in the current locale encoding. -@deffn {C Function} scm_str2symbol (const char * name) -@deffnx {C Function} scm_mem2symbol (const char * name, size_t len) +When you want to do more from C, you should convert between symbols +and strings using @code{scm_symbol_to_string} and +@code{scm_string_to_symbol} and work with the strings. + +@deffn {C Function} scm_from_locale_symbol (const char *name) +@deffnx {C Function} scm_from_locale_symboln (const char *name, size_t len) Construct and return a Scheme symbol whose name is specified by -@var{name}. For @code{scm_str2symbol} @var{name} must be null -terminated; For @code{scm_mem2symbol} the length of @var{name} is +@var{name}. For @code{scm_from_locale_symbol}, @var{name} must be null +terminated; for @code{scm_from_locale_symboln} the length of @var{name} is specified explicitly by @var{len}. @end deffn From 323a7e80d530b9d9ea6e0fdb28cbf8cf9f40bc99 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 18:54:05 +0000 Subject: [PATCH 024/100] *** empty log message *** --- doc/ref/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 3b5014bac..6b0e8ae6d 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,10 @@ +2004-08-19 Marius Vollmer + + * api-data.texi (Strings): Document copy-on-write behavior and + mutation-sharing substrings. + (Symbols): Document scm_from_locale_symbol and + scm_from_locale_symboln. + 2004-08-18 Kevin Ryde * posix.texi (Network Sockets and Communication): Add SOCK_RDM and From ece721f0311bc2ffb65e67e251f3c715765ba686 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 20:34:58 +0000 Subject: [PATCH 025/100] Added comment about future improvements... --- libguile/procprop.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/procprop.c b/libguile/procprop.c index 03043890d..41db72535 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -134,6 +134,12 @@ scm_i_procedure_arity (SCM proc) return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r)); } +/* XXX - instead of using a stand-in value for everything except + closures, we should find other ways to store the procedure + properties for those other kinds of procedures. For example, subrs + have their own property slot, which is unused at present. +*/ + static SCM scm_stand_in_scm_proc(SCM proc) { From ba16a103a404ef6f1100cacbadb36167d2cdfb4f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 20:36:29 +0000 Subject: [PATCH 026/100] (SCM_SYMBOL_CHARS): Cast away const in return. (SCM_SYMBOL_LENGTH): It's scm_i_symbol_length, not scm_c_symbol_length. --- libguile/deprecated.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/deprecated.c b/libguile/deprecated.c index de2d6da16..1fa9558a1 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -1181,7 +1181,7 @@ SCM_SYMBOL_CHARS (SCM sym) scm_c_issue_deprecation_warning ("SCM_SYMBOL_CHARS is deprecated. Use scm_symbol_to_string."); - return scm_i_symbol_chars (sym); + return (char *)scm_i_symbol_chars (sym); } size_t @@ -1189,7 +1189,7 @@ SCM_SYMBOL_LENGTH (SCM sym) { scm_c_issue_deprecation_warning ("SCM_SYMBOL_LENGTH is deprecated. Use scm_symbol_to_string."); - return scm_c_symbol_length (sym); + return scm_i_symbol_length (sym); } void From b5247a6ba821d5a2d203bb30e8f7888623873fd7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 20:40:16 +0000 Subject: [PATCH 027/100] *** empty log message *** --- libguile/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index af10e6b36..c63cf4730 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2004-08-19 Marius Vollmer + + * deprecated.c (SCM_SYMBOL_CHARS): Cast away const in return. + (SCM_SYMBOL_LENGTH): It's scm_i_symbol_length, not + scm_c_symbol_length. + 2004-08-19 Marius Vollmer New string implementation, with copy-on-write strings and From 1c17f6b0c8786054dfc2b1ee8a3ee1f3d7fe42f2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 22:23:23 +0000 Subject: [PATCH 028/100] Two tests for substring/shared. Also, use (test-suite lib). --- test-suite/tests/strings.test | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index 432100f6f..a21553224 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -1,7 +1,7 @@ ;;;; strings.test --- test suite for Guile's string functions -*- scheme -*- ;;;; Jim Blandy --- August 1999 ;;;; -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2004 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 @@ -18,6 +18,7 @@ ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA +(use-modules (test-suite lib)) ;; FIXME: As soon as guile supports immutable strings, this has to be ;; replaced with the appropriate error type and message. @@ -86,3 +87,17 @@ (pass-if-exception "substring-move! checks start and end correctly" exception:out-of-range (substring-move! "sample" 3 0 "test" 3))) + +(with-test-prefix "substring/shared" + + (pass-if "modify indirectly" + (let ((str (string-copy "foofoofoo"))) + (string-upcase! (substring/shared str 3 6)) + (string=? str "fooFOOfoo"))) + + (pass-if "modify cow indirectly" + (let* ((str1 (string-copy "foofoofoo")) + (str2 (string-copy str1))) + (string-upcase! (substring/shared str2 3 6)) + (and (string=? str1 "foofoofoo") + (string=? str2 "fooFOOfoo"))))) \ No newline at end of file From cf3dd9498c46a149c34ec6c81c4059cd5f22efe6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 22:23:34 +0000 Subject: [PATCH 029/100] *** empty log message *** --- test-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index c3ead36b2..e6bfff3ca 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-08-20 Marius Vollmer + + * tests/strings.test: Two tests for substring/shared. Also, use + (test-suite lib). + 2004-08-19 Marius Vollmer * standalone/test-conversion.c, standalone/test-gh.c, From ea4a72fe20d8c794f03872c657fdf3ad7615f8ad Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 23:03:55 +0000 Subject: [PATCH 030/100] Updated transition section with new recommended things. --- doc/ref/gh.texi | 56 +++++++++++++------------------------------------ 1 file changed, 15 insertions(+), 41 deletions(-) diff --git a/doc/ref/gh.texi b/doc/ref/gh.texi index b1c35a406..25ffaf1c1 100644 --- a/doc/ref/gh.texi +++ b/doc/ref/gh.texi @@ -919,17 +919,16 @@ Use @code{scm_make_real} instead. Use @code{SCM_MAKE_CHAR} instead. @item @code{gh_str2scm} -Use @code{scm_mem2string} instead. +Use @code{scm_from_locale_stringn} instead. @item @code{gh_str02scm} -Use @code{scm_makfrom0str} instead. +Use @code{scm_from_locale_string} instead. @item @code{gh_set_substr} No direct scm equivalent. [FIXME] @item @code{gh_symbol2scm} -Use @code{scm_str2symbol} instead. [FIXME: inconsistent naming, -should be @code{scm_str02symbol}.] +Use @code{scm_from_locale_symbol} instead. @item @code{gh_ints2scm} and @code{gh_doubles2scm} Use @code{scm_c_ints2scm} and @code{scm_c_doubles2scm} instead. @@ -956,29 +955,20 @@ Use @code{scm_to_ulong} instead. Use @code{scm_to_long} instead. @item @code{gh_scm2double} -Replace @code{gh_scm2double (@var{obj})} by -@example -scm_num2dbl (@var{obj}, @var{str}) -@end example -where @var{str} is a C string that describes the context of the call. +Use @code{scm_to_double} instead. @item @code{gh_scm2char} Use @code{scm_to_char} instead. @item @code{gh_scm2newstr} -Instead of @code{gh_scm2newstr (@var{obj}, @var{lenp})} use -@code{scm_c_string2str (@var{obj}, @var{str}, @var{lenp})}. With the -additional @var{str} argument the user can pass a pre-allocated memory -chunk or leave it passing NULL. +Use @code{scm_to_locale_string} or similar instead. @item @code{gh_get_substr} -Use the @code{scm_c_substring2str (@var{obj}, @var{str}, @var{start}, -@var{len})} function instead. +Use @code{scm_c_substring} together with @code{scm_to_locale_string} +or similar instead. @item @code{gh_symbol2newstr} -Use the @code{scm_c_symbol2str (@var{obj}, @var{str}, @var{lenp})} function -instead. With the additional @var{str} argument the user can pass a -pre-allocated memory chunk or leave it passing NULL. +Use @code{scm_symbol_to_string} together with @code{scm_to_locale_string} or similar instead. @item @code{gh_scm2chars} Use @code{scm_c_scm2chars} instead. @@ -993,46 +983,31 @@ Use @code{scm_c_floats2scm} and @code{scm_c_doubles2scm} instead. Use @code{scm_is_bool} instead. @item @code{gh_symbol_p} -Use the @code{SCM_SYMBOLP} macro instead, or replace @code{gh_symbol_p -(@var{obj})} by -@example -scm_is_true (scm_symbol_p (@var{obj})) -@end example +Use @code{scm_is_symbol} instead. @item @code{gh_char_p} -Use the @code{SCM_CHARP} macro instead, or replace @code{gh_char_p -(@var{obj})} by +Replace @code{gh_char_p (@var{obj})} by @example scm_is_true (scm_char_p (@var{obj})) @end example @item @code{gh_vector_p} -Use the @code{SCM_VECTORP} macro instead, or replace @code{gh_vector_p -(@var{obj})} by +Replace @code{gh_vector_p (@var{obj})} by @example scm_is_true (scm_vector_p (@var{obj})) @end example @item @code{gh_pair_p} -Use the @code{SCM_CONSP} macro instead, or replace @code{gh_pair_p -(@var{obj})} by +Replace @code{gh_pair_p (@var{obj})} by @example scm_is_true (scm_pair_p (@var{obj})) @end example @item @code{gh_number_p} -Use the @code{SCM_NUMBERP} macro instead, or replace @code{gh_number_p -(@var{obj})} by -@example -scm_is_true (scm_number_p (@var{obj})) -@end example +Use @code{scm_is_number} instead. @item @code{gh_string_p} -Use the @code{SCM_STRINGP} macro instead, or replace @code{gh_string_p -(@var{obj})} by -@example -scm_is_true (scm_string_p (@var{obj})) -@end example +Use @code{scm_is_string} instead. @item @code{gh_procedure_p} Replace @code{gh_procedure_p (@var{obj})} by @@ -1047,8 +1022,7 @@ scm_is_true (scm_list_p (@var{obj})) @end example @item @code{gh_inexact_p} -Use the @code{SCM_INEXACTP} macro instead, or replace @code{gh_inexact_p -(@var{obj})} by +Replace @code{gh_inexact_p (@var{obj})} by @example scm_is_true (scm_inexact_p (@var{obj})) @end example From 61d6ed68a1bc327f917831c765c7ceaaaa2324e7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 19 Aug 2004 23:04:45 +0000 Subject: [PATCH 031/100] *** empty log message *** --- doc/ref/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 6b0e8ae6d..75fe26a86 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,7 @@ +2004-08-20 Marius Vollmer + + * gh.texi: Updated transition section with new recommended things. + 2004-08-19 Marius Vollmer * api-data.texi (Strings): Document copy-on-write behavior and From 71978ac9f69736ad7123244b293838c1d47a6fcd Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 20 Aug 2004 01:32:36 +0000 Subject: [PATCH 032/100] (scm_mkstemp): Correction to new locale_string stuff, need to modify the input string. --- libguile/posix.c | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index bb78a18ae..049709620 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1136,13 +1136,12 @@ SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, #define FUNC_NAME s_scm_mkstemp { char *c_tmpl; - int rv, eno; + int rv; - c_tmpl = scm_to_locale_string (tmpl); + SCM_VALIDATE_STRING (SCM_ARG1, tmpl); + c_tmpl = scm_i_string_writable_chars (tmpl); SCM_SYSCALL (rv = mkstemp (c_tmpl)); - eno = errno; - free (c_tmpl); - errno = eno; + scm_i_string_stop_writing (); if (rv == -1) SCM_SYSERROR; return scm_fdes_to_port (rv, "w+", tmpl); From d4f76919e62cfbf9235abf61df4a5c4c6fa699b1 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 20 Aug 2004 01:35:44 +0000 Subject: [PATCH 033/100] *** empty log message *** --- libguile/ChangeLog | 5 +++++ test-suite/ChangeLog | 4 ++++ 2 files changed, 9 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c63cf4730..fa0d16d12 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2004-08-20 Kevin Ryde + + * posix.c (scm_mkstemp): Correction to new locale_string stuff, need + to modify the input string. + 2004-08-19 Marius Vollmer * deprecated.c (SCM_SYMBOL_CHARS): Cast away const in return. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e6bfff3ca..5826ba8de 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2004-08-20 Kevin Ryde + + * tests/posix.test (mkstemp!): New tests. + 2004-08-20 Marius Vollmer * tests/strings.test: Two tests for substring/shared. Also, use From 95c098ddd9402c43b56c2f7ccdc93265a4411341 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 20 Aug 2004 01:36:28 +0000 Subject: [PATCH 034/100] (mkstemp!): New tests. --- test-suite/tests/posix.test | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index 7ed564b81..a218a4869 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -53,6 +53,29 @@ ;; (execle "./nosuchprog" '("FOO=1" "BAR=2") "./nosuchprog" "some arg"))) +;; +;; mkstemp! +;; + +(with-test-prefix "mkstemp!" + + ;; the temporary names used in the tests here are kept to 8 characters so + ;; they'll work on a DOS 8.3 file system + + (define (string-copy str) + (list->string (string->list str))) + + (pass-if-exception "number arg" exception:wrong-type-arg + (mkstemp! 123)) + + (pass-if "filename string modified" + (let* ((template "T-XXXXXX") + (str (string-copy template)) + (port (mkstemp! str)) + (result (not (string=? str template)))) + (delete-file str) + result))) + ;; ;; putenv ;; From a54264f04e60ea4b8b0037c6537ee59572b012ad Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 20 Aug 2004 12:25:09 +0000 Subject: [PATCH 035/100] (scm_substring_move_x): Store into str2, not str1. --- libguile/strop.c | 539 ----------------------------------------------- 1 file changed, 539 deletions(-) diff --git a/libguile/strop.c b/libguile/strop.c index e964879fa..e69de29bb 100644 --- a/libguile/strop.c +++ b/libguile/strop.c @@ -1,539 +0,0 @@ -/* classes: src_files */ - -/* Copyright (C) 1994,1996,1997,1999,2000,2001 Free Software Foundation, Inc. - - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - */ - - -#if HAVE_CONFIG_H -# include -#endif - -#include - -#include "libguile/_scm.h" -#include "libguile/chars.h" -#include "libguile/strings.h" - -#include "libguile/validate.h" -#include "libguile/strop.h" -#include "libguile/read.h" /*For SCM_CASE_INSENSITIVE_P*/ - -#ifdef HAVE_STRING_H -#include -#endif - - - -/* -xSCM_DEFINE (scm_i_index, "i-index", 2, 2, 0, - (SCM str, SCM chr, SCM frm, SCM to), - "@deftypefn {Internal C Function} {static int} scm_i_index (SCM *@var{str},\n" - "SCM @var{chr}, int @var{direction}, SCM @var{sub_start}, SCM @var{sub_end}, char *@var{why}) - "This is a workhorse function that performs either an @code{index} or\n" - "@code{rindex} function, depending on the value of @var{direction}." -*/ -/* implements index if direction > 0 otherwise rindex. */ -static long -scm_i_index (SCM str, SCM chr, int direction, SCM sub_start, - SCM sub_end, const char *why) -{ - unsigned char * p; - long x; - long lower; - long upper; - int ch; - - SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, why); - SCM_ASSERT (SCM_CHARP (chr), chr, SCM_ARG2, why); - - if (scm_is_false (sub_start)) - lower = 0; - else - lower = scm_to_signed_integer (sub_start, 0, scm_i_string_length(str)); - - if (scm_is_false (sub_end)) - upper = scm_i_string_length (str); - else - upper = scm_to_signed_integer (sub_end, lower, scm_i_string_length(str)); - - x = -1; - - if (direction > 0) - { - p = (unsigned char *) scm_i_string_chars (str) + lower; - ch = SCM_CHAR (chr); - - for (x = lower; x < upper; ++x, ++p) - if (*p == ch) - goto found_it; - } - else - { - p = upper - 1 + (unsigned char *)scm_i_string_chars (str); - ch = SCM_CHAR (chr); - for (x = upper - 1; x >= lower; --x, --p) - if (*p == ch) - goto found_it; - } - - found_it: - scm_remember_upto_here_1 (str); - return x; -} - -SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, - (SCM str, SCM chr, SCM frm, SCM to), - "Return the index of the first occurrence of @var{chr} in\n" - "@var{str}. The optional integer arguments @var{frm} and\n" - "@var{to} limit the search to a portion of the string. This\n" - "procedure essentially implements the @code{index} or\n" - "@code{strchr} functions from the C library.\n" - "\n" - "@lisp\n" - "(string-index \"weiner\" #\\e)\n" - "@result{} 1\n\n" - "(string-index \"weiner\" #\\e 2)\n" - "@result{} 4\n\n" - "(string-index \"weiner\" #\\e 2 4)\n" - "@result{} #f\n" - "@end lisp") -#define FUNC_NAME s_scm_string_index -{ - long pos; - - if (SCM_UNBNDP (frm)) - frm = SCM_BOOL_F; - if (SCM_UNBNDP (to)) - to = SCM_BOOL_F; - pos = scm_i_index (str, chr, 1, frm, to, FUNC_NAME); - return (pos < 0 - ? SCM_BOOL_F - : scm_from_long (pos)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0, - (SCM str, SCM chr, SCM frm, SCM to), - "Like @code{string-index}, but search from the right of the\n" - "string rather than from the left. This procedure essentially\n" - "implements the @code{rindex} or @code{strrchr} functions from\n" - "the C library.\n" - "\n" - "@lisp\n" - "(string-rindex \"weiner\" #\\e)\n" - "@result{} 4\n\n" - "(string-rindex \"weiner\" #\\e 2 4)\n" - "@result{} #f\n\n" - "(string-rindex \"weiner\" #\\e 2 5)\n" - "@result{} 4\n" - "@end lisp") -#define FUNC_NAME s_scm_string_rindex -{ - long pos; - - if (SCM_UNBNDP (frm)) - frm = SCM_BOOL_F; - if (SCM_UNBNDP (to)) - to = SCM_BOOL_F; - pos = scm_i_index (str, chr, -1, frm, to, FUNC_NAME); - return (pos < 0 - ? SCM_BOOL_F - : scm_from_long (pos)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, - (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2), - "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n" - "into @var{str2} beginning at position @var{start2}.\n" - "@var{str1} and @var{str2} can be the same string.") -#define FUNC_NAME s_scm_substring_move_x -{ - unsigned long s1, s2, e, len; - const char *src; - char *dst; - - SCM_VALIDATE_STRING (1, str1); - SCM_VALIDATE_STRING (4, str2); - s1 = scm_to_unsigned_integer (start1, 0, scm_i_string_length(str1)); - e = scm_to_unsigned_integer (end1, s1, scm_i_string_length(str1)); - len = e - s1; - s2 = scm_to_unsigned_integer (start2, 0, scm_i_string_length(str2)-len); - - src = scm_i_string_chars (str2); - dst = scm_i_string_writable_chars (str1); - SCM_SYSCALL (memmove (dst+s2, src+s1, len)); - scm_i_string_stop_writing (); - - scm_remember_upto_here_2 (str1, str2); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_substring_fill_x, "substring-fill!", 4, 0, 0, - (SCM str, SCM start, SCM end, SCM fill), - "Change every character in @var{str} between @var{start} and\n" - "@var{end} to @var{fill}.\n" - "\n" - "@lisp\n" - "(define y \"abcdefg\")\n" - "(substring-fill! y 1 3 #\\r)\n" - "y\n" - "@result{} \"arrdefg\"\n" - "@end lisp") -#define FUNC_NAME s_scm_substring_fill_x -{ - size_t i, e; - char c; - char *dst; - - SCM_VALIDATE_STRING (1, str); - i = scm_to_unsigned_integer (start, 0, scm_i_string_length (str)); - e = scm_to_unsigned_integer (end, i, scm_i_string_length (str)); - SCM_VALIDATE_CHAR_COPY (4, fill, c); - dst = scm_i_string_writable_chars (str); - while (ilist", 1, 0, 0, - (SCM str), - "Return a newly allocated list of the characters that make up\n" - "the given string @var{str}. @code{string->list} and\n" - "@code{list->string} are inverses as far as @samp{equal?} is\n" - "concerned.") -#define FUNC_NAME s_scm_string_to_list -{ - long i; - SCM res = SCM_EOL; - const unsigned char *src; - SCM_VALIDATE_STRING (1, str); - src = scm_i_string_chars (str); - for (i = scm_i_string_length (str)-1;i >= 0;i--) - res = scm_cons (SCM_MAKE_CHAR (src[i]), res); - scm_remember_upto_here_1 (src); - return res; -} -#undef FUNC_NAME - - -/* Helper function for the string copy and string conversion functions. - * No argument checking is performed. */ -static SCM -string_copy (SCM str) -{ - const char* chars = scm_i_string_chars (str); - size_t length = scm_i_string_length (str); - char *dst; - SCM new_string = scm_i_make_string (length, &dst); - memcpy (dst, chars, length); - scm_remember_upto_here_1 (str); - return new_string; -} - - -SCM_DEFINE (scm_string_copy, "string-copy", 1, 0, 0, - (SCM str), - "Return a newly allocated copy of the given @var{string}.") -#define FUNC_NAME s_scm_string_copy -{ - return scm_c_substring (str, 0, scm_c_string_length (str)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_fill_x, "string-fill!", 2, 0, 0, - (SCM str, SCM chr), - "Store @var{char} in every element of the given @var{string} and\n" - "return an unspecified value.") -#define FUNC_NAME s_scm_string_fill_x -{ - char *dst, c; - long k; - SCM_VALIDATE_STRING (1, str); - SCM_VALIDATE_CHAR_COPY (2, chr, c); - dst = scm_i_string_writable_chars (str); - for (k = scm_i_string_length (str)-1;k >= 0;k--) - dst[k] = c; - scm_i_string_stop_writing (); - scm_remember_upto_here_1 (str); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -/* Helper function for the string uppercase conversion functions. - * No argument checking is performed. */ -static SCM -string_upcase_x (SCM v) -{ - size_t k, len; - char *dst; - - len = scm_i_string_length (v); - dst = scm_i_string_writable_chars (v); - for (k = 0; k < len; ++k) - dst[k] = scm_c_upcase (dst[k]); - scm_i_string_stop_writing (); - return v; -} - - -SCM_DEFINE (scm_string_upcase_x, "string-upcase!", 1, 0, 0, - (SCM str), - "Destructively upcase every character in @var{str} and return\n" - "@var{str}.\n" - "@lisp\n" - "y @result{} \"arrdefg\"\n" - "(string-upcase! y) @result{} \"ARRDEFG\"\n" - "y @result{} \"ARRDEFG\"\n" - "@end lisp") -#define FUNC_NAME s_scm_string_upcase_x -{ - SCM_VALIDATE_STRING (1, str); - - return string_upcase_x (str); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_upcase, "string-upcase", 1, 0, 0, - (SCM str), - "Return a freshly allocated string containing the characters of\n" - "@var{str} in upper case.") -#define FUNC_NAME s_scm_string_upcase -{ - SCM_VALIDATE_STRING (1, str); - - return string_upcase_x (string_copy (str)); -} -#undef FUNC_NAME - - -/* Helper function for the string lowercase conversion functions. - * No argument checking is performed. */ -static SCM -string_downcase_x (SCM v) -{ - size_t k, len; - char *dst; - - len = scm_i_string_length (v); - dst = scm_i_string_writable_chars (v); - for (k = 0; k < len; ++k) - dst[k] = scm_c_downcase (dst[k]); - scm_i_string_stop_writing (); - - return v; -} - - -SCM_DEFINE (scm_string_downcase_x, "string-downcase!", 1, 0, 0, - (SCM str), - "Destructively downcase every character in @var{str} and return\n" - "@var{str}.\n" - "@lisp\n" - "y @result{} \"ARRDEFG\"\n" - "(string-downcase! y) @result{} \"arrdefg\"\n" - "y @result{} \"arrdefg\"\n" - "@end lisp") -#define FUNC_NAME s_scm_string_downcase_x -{ - SCM_VALIDATE_STRING (1, str); - - return string_downcase_x (str); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_downcase, "string-downcase", 1, 0, 0, - (SCM str), - "Return a freshly allocation string containing the characters in\n" - "@var{str} in lower case.") -#define FUNC_NAME s_scm_string_downcase -{ - SCM_VALIDATE_STRING (1, str); - - return string_downcase_x (string_copy (str)); -} -#undef FUNC_NAME - - -/* Helper function for the string capitalization functions. - * No argument checking is performed. */ -static SCM -string_capitalize_x (SCM str) -{ - unsigned char *sz; - size_t i, len; - int in_word=0; - - len = scm_i_string_length (str); - sz = scm_i_string_writable_chars (str); - for (i = 0; i < len; i++) - { - if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i])))) - { - if (!in_word) - { - sz[i] = scm_c_upcase (sz[i]); - in_word = 1; - } - else - { - sz[i] = scm_c_downcase (sz[i]); - } - } - else - in_word = 0; - } - scm_i_string_stop_writing (); - return str; -} - - -SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, - (SCM str), - "Upcase the first character of every word in @var{str}\n" - "destructively and return @var{str}.\n" - "\n" - "@lisp\n" - "y @result{} \"hello world\"\n" - "(string-capitalize! y) @result{} \"Hello World\"\n" - "y @result{} \"Hello World\"\n" - "@end lisp") -#define FUNC_NAME s_scm_string_capitalize_x -{ - SCM_VALIDATE_STRING (1, str); - - return string_capitalize_x (str); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0, - (SCM str), - "Return a freshly allocated string with the characters in\n" - "@var{str}, where the first character of every word is\n" - "capitalized.") -#define FUNC_NAME s_scm_string_capitalize -{ - SCM_VALIDATE_STRING (1, str); - - return string_capitalize_x (string_copy (str)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, - (SCM str, SCM chr), - "Split the string @var{str} into the a list of the substrings delimited\n" - "by appearances of the character @var{chr}. Note that an empty substring\n" - "between separator characters will result in an empty string in the\n" - "result list.\n" - "\n" - "@lisp\n" - "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n" - "@result{}\n" - "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n" - "\n" - "(string-split \"::\" #\\:)\n" - "@result{}\n" - "(\"\" \"\" \"\")\n" - "\n" - "(string-split \"\" #\\:)\n" - "@result{}\n" - "(\"\")\n" - "@end lisp") -#define FUNC_NAME s_scm_string_split -{ - long idx, last_idx; - const char * p; - int ch; - SCM res = SCM_EOL; - - SCM_VALIDATE_STRING (1, str); - SCM_VALIDATE_CHAR (2, chr); - - idx = scm_i_string_length (str); - p = scm_i_string_chars (str); - ch = SCM_CHAR (chr); - while (idx >= 0) - { - last_idx = idx; - while (idx > 0 && p[idx - 1] != ch) - idx--; - if (idx >= 0) - { - res = scm_cons (scm_c_substring (str, idx, last_idx), res); - p = scm_i_string_chars (str); - idx--; - } - } - scm_remember_upto_here_1 (str); - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, - (SCM str), - "Return the symbol whose name is @var{str}. @var{str} is\n" - "converted to lowercase before the conversion is done, if Guile\n" - "is currently reading symbols case-insensitively.") -#define FUNC_NAME s_scm_string_ci_to_symbol -{ - return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P - ? scm_string_downcase(str) - : str); -} -#undef FUNC_NAME - -void -scm_init_strop () -{ -#include "libguile/strop.x" -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ From 892065da6cd4ea56a6c946e6f0c064cd7e4fbd86 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 20 Aug 2004 12:25:20 +0000 Subject: [PATCH 036/100] (scm_mkstemp): Correction to the correction, mkstemp expects a null-terminated string in the locale encoding, but scm_i_string_writable_chars doesn't give that. Fixed by letting mkstemp modify a locale version of the tmpl argument and copying the result back into tmpl. --- libguile/posix.c | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 049709620..df743f355 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -35,6 +35,7 @@ #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/lang.h" +#include "libguile/strop.h" #include "libguile/validate.h" #include "libguile/posix.h" @@ -1138,12 +1139,20 @@ SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, char *c_tmpl; int rv; - SCM_VALIDATE_STRING (SCM_ARG1, tmpl); - c_tmpl = scm_i_string_writable_chars (tmpl); + scm_frame_begin (0); + + c_tmpl = scm_to_locale_string (tmpl); + scm_frame_free (c_tmpl); + SCM_SYSCALL (rv = mkstemp (c_tmpl)); - scm_i_string_stop_writing (); if (rv == -1) SCM_SYSERROR; + + scm_substring_move_x (scm_from_locale_string (c_tmpl), + SCM_INUM0, scm_string_length (tmpl), + tmpl, SCM_INUM0); + + scm_frame_end (); return scm_fdes_to_port (rv, "w+", tmpl); } #undef FUNC_NAME From 2d0c133f923c4cb829b4b8ed7013ed77a25a4235 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 20 Aug 2004 12:26:46 +0000 Subject: [PATCH 037/100] (scm_lookupcar1): Report an "Undefined variable" insetad of an "Unbound" one for variables that are found but still contain SCM_UNDEFINED. --- libguile/eval.c | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index a032cf8da..981f303d7 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2680,6 +2680,10 @@ scm_ilookup (SCM iloc, SCM env) SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); static void error_unbound_variable (SCM symbol) SCM_NORETURN; +static void error_defined_variable (SCM symbol) SCM_NORETURN; + +/* Call this for variables that are unfound. + */ static void error_unbound_variable (SCM symbol) { @@ -2688,6 +2692,20 @@ error_unbound_variable (SCM symbol) scm_list_1 (symbol), SCM_BOOL_F); } +/* Call this for variables that are found but contain SCM_UNDEFINED. + */ +static void +error_defined_variable (SCM symbol) +{ + /* We use the 'unbound-variable' key here as well, since it + basically is the same kind of error, with a slight variation in + the displayed message. + */ + scm_error (scm_unbound_variable_key, NULL, + "Undefined variable: ~S", + scm_list_1 (symbol), SCM_BOOL_F); +} + /* The Lookup Car Race - by Eva Luator @@ -2791,10 +2809,7 @@ scm_lookupcar1 (SCM vloc, SCM genv, int check) if (scm_is_eq (SCM_CAR (fl), var)) { if (SCM_UNBNDP (SCM_CAR (*al))) - { - env = SCM_EOL; - goto errout; - } + error_defined_variable (var); if (!scm_is_eq (SCM_CAR (vloc), var)) goto race; SCM_SETCAR (vloc, iloc); From 2146fdebd81608790d623b5a5d839e921cbb77ab Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 20 Aug 2004 12:27:11 +0000 Subject: [PATCH 038/100] *** empty log message *** --- libguile/ChangeLog | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fa0d16d12..a0e46eac2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,17 @@ +2004-08-20 Marius Vollmer + + * eval.c (scm_lookupcar1): Report an "Undefined variable" insetad + of an "Unbound" one for variables that are found but still contain + SCM_UNDEFINED. + + * posix.c (scm_mkstemp): Correction to the correction, mkstemp + expects a null-terminated string in the locale encoding, but + scm_i_string_writable_chars doesn't give that. Fixed by letting + mkstemp modify a locale version of the tmpl argument and copying + the result back into tmpl. + + * strop.c (scm_substring_move_x): Store into str2, not str1. + 2004-08-20 Kevin Ryde * posix.c (scm_mkstemp): Correction to new locale_string stuff, need From a03bad878bebd2b047a0bf16809dde50b7faad05 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 20 Aug 2004 13:33:28 +0000 Subject: [PATCH 039/100] (scm_lookupcar1): Report "Variable used before given a value" insetad of an "Unbound" one for variables that are found but still contain SCM_UNDEFINED. --- libguile/eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/eval.c b/libguile/eval.c index 981f303d7..8217c4003 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2702,7 +2702,7 @@ error_defined_variable (SCM symbol) the displayed message. */ scm_error (scm_unbound_variable_key, NULL, - "Undefined variable: ~S", + "Variable used before given a value: ~S", scm_list_1 (symbol), SCM_BOOL_F); } From c1f54b3ddaca5620fe041137d163267da8f0f0ac Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 20 Aug 2004 13:33:39 +0000 Subject: [PATCH 040/100] *** empty log message *** --- libguile/ChangeLog | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a0e46eac2..e1d8660f4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,8 +1,8 @@ 2004-08-20 Marius Vollmer - * eval.c (scm_lookupcar1): Report an "Undefined variable" insetad - of an "Unbound" one for variables that are found but still contain - SCM_UNDEFINED. + * eval.c (scm_lookupcar1): Report "Variable used before given a + value" insetad of an "Unbound" one for variables that are found + but still contain SCM_UNDEFINED. * posix.c (scm_mkstemp): Correction to the correction, mkstemp expects a null-terminated string in the locale encoding, but From 2f843c4b7a06c8a897f6b30651e7aa602c63aef5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 20 Aug 2004 15:13:56 +0000 Subject: [PATCH 041/100] (display-source): Use unmemoize-expr instead of unmemoize. (write-frame-short/expression): Likewise. --- ice-9/debugger/utils.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ice-9/debugger/utils.scm b/ice-9/debugger/utils.scm index a25290f56..367488c3c 100644 --- a/ice-9/debugger/utils.scm +++ b/ice-9/debugger/utils.scm @@ -107,7 +107,7 @@ (copy (source-property source 'copy))) (if (pair? copy) copy - (unmemoize source))))) + (unmemoize-expr source))))) (define (write-state-long state) (let ((index (state-index state))) @@ -156,7 +156,7 @@ (cond ((source-position source) => (lambda (p) (display-position p) (display ":\n")))) (display " ") - (write (or copy (unmemoize source))))) + (write (or copy (unmemoize-expr source))))) (define (source-position source) (let ((fname (source-property source 'filename)) From fac3b6bca1fd4474122281690aa0dbe6d534ecfd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 20 Aug 2004 15:14:08 +0000 Subject: [PATCH 042/100] *** empty log message *** --- ice-9/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index f34938dac..3c382df90 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2004-08-20 Marius Vollmer + + * debugger/utils.scm (display-source): Use unmemoize-expr instead + of unmemoize. + (write-frame-short/expression): Likewise. + 2004-08-18 Kevin Ryde * and-let-star.scm: Add cond-expand-provide srfi-2, since this module From 5fa0939ce5dc4eefcaa0f6ebec230352a4a96627 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 21 Aug 2004 07:28:16 +0000 Subject: [PATCH 043/100] * eval.c (unmemoize_exprs): When dropping internal body markers from the output during unmemoization, also drop those that are not immediately at the beginning of a body. --- libguile/ChangeLog | 6 ++++++ libguile/eval.c | 23 +++++++++++++---------- 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e1d8660f4..58a6e89a4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2004-08-21 Dirk Herrmann + + * eval.c (unmemoize_exprs): When dropping internal body markers + from the output during unmemoization, also drop those that are not + immediately at the beginning of a body. + 2004-08-20 Marius Vollmer * eval.c (scm_lookupcar1): Report "Variable used before given a diff --git a/libguile/eval.c b/libguile/eval.c index 8217c4003..0eebbd332 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -586,14 +586,7 @@ unmemoize_exprs (const SCM exprs, const SCM env) SCM um_expr; /* Note that due to the current lazy memoizer we may find partially memoized - * code during execution. In such code, lists of expressions that stem from - * a body form may start with an ISYM if the body itself has not yet been - * memoized. This isym is just an internal marker to indicate that the body - * still needs to be memoized. It is dropped during unmemoization. */ - if (SCM_CONSP (expr_idx) && SCM_ISYMP (SCM_CAR (expr_idx))) - expr_idx = SCM_CDR (expr_idx); - - /* Moreover, in partially memoized code we have to expect improper lists of + * code during execution. In such code we have to expect improper lists of * expressions: On the one hand, for such code syntax checks have not yet * fully been performed, on the other hand, there may be even legal code * like '(a . b) appear as an improper list of expressions as long as the @@ -603,8 +596,18 @@ unmemoize_exprs (const SCM exprs, const SCM env) for (; SCM_CONSP (expr_idx); expr_idx = SCM_CDR (expr_idx)) { const SCM expr = SCM_CAR (expr_idx); - um_expr = unmemoize_expression (expr, env); - r_result = scm_cons (um_expr, r_result); + + /* In partially memoized code, lists of expressions that stem from a + * body form may start with an ISYM if the body itself has not yet been + * memoized. This isym is just an internal marker to indicate that the + * body still needs to be memoized. An isym may occur at the very + * beginning of the body or after one or more comment strings. It is + * dropped during unmemoization. */ + if (!SCM_ISYMP (expr)) + { + um_expr = unmemoize_expression (expr, env); + r_result = scm_cons (um_expr, r_result); + } } um_expr = unmemoize_expression (expr_idx, env); if (!SCM_NULLP (r_result)) From ae0b6bf5dff2f606885e5e29456b791367790175 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 22 Aug 2004 01:49:10 +0000 Subject: [PATCH 044/100] =?UTF-8?q?Move=20variables=20to=20avoid=20c99-ism?= =?UTF-8?q?s=20in=20recent:=20=09(scm=5Ftry=5Farbiter,=20scm=5Frelease=5Fa?= =?UTF-8?q?rbiter):=20Use=20FETCH=5FSTORE=20...=20Noticed=20by=20Andreas?= =?UTF-8?q?=20V=C3=B6gele.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- libguile/arbiters.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/arbiters.c b/libguile/arbiters.c index 57f2c65cb..35011917a 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -116,8 +116,8 @@ SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_try_arbiter { - SCM_VALIDATE_SMOB (1, arb, arbiter); scm_t_bits old; + SCM_VALIDATE_SMOB (1, arb, arbiter); FETCH_STORE (old, * (scm_t_bits *) SCM_CELL_OBJECT_LOC(arb,0), SCM_LOCK_VAL); return scm_from_bool (old == SCM_UNLOCK_VAL); } @@ -142,8 +142,8 @@ SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0, "release it.") #define FUNC_NAME s_scm_release_arbiter { - SCM_VALIDATE_SMOB (1, arb, arbiter); scm_t_bits old; + SCM_VALIDATE_SMOB (1, arb, arbiter); FETCH_STORE (old, *(scm_t_bits*)SCM_CELL_OBJECT_LOC(arb,0), SCM_UNLOCK_VAL); return scm_from_bool (old == SCM_LOCK_VAL); } From caa29067e73fa48ae2eb74db418c9770eed004af Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 22 Aug 2004 19:25:51 +0000 Subject: [PATCH 045/100] (scm_compile_shell_switches): added '-L' switch to add to the %load-path. --- libguile/script.c | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/libguile/script.c b/libguile/script.c index 5b62d65ce..086b9beef 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -361,6 +361,7 @@ scm_shell_usage (int fatal, char *message) "remaining arguments as the value of (command-line).\n" "If FILE begins with `-' the -s switch is mandatory.\n" "\n" + " -L DIRECTORY add DIRECTORY to the front of the module load path\n" " -l FILE load Scheme source code from FILE\n" " -e FUNCTION after reading script, apply FUNCTION to\n" " command line arguments\n" @@ -395,7 +396,9 @@ SCM_SYMBOL (sym_load_user_init, "load-user-init"); SCM_SYMBOL (sym_top_repl, "top-repl"); SCM_SYMBOL (sym_quit, "quit"); SCM_SYMBOL (sym_use_srfis, "use-srfis"); - +SCM_SYMBOL (sym_load_path, "%load-path"); +SCM_SYMBOL (sym_set_x, "set!"); +SCM_SYMBOL (sym_cons, "cons"); /* Given an array of command-line switches, return a Scheme expression to carry out the actions specified by the switches. @@ -418,6 +421,7 @@ scm_compile_shell_switches (int argc, char **argv) the "load" command, in case we get the "-ds" switch. */ SCM entry_point = SCM_EOL; /* for -e switch */ + SCM user_load_path = SCM_EOL; /* for -L switch */ int interactive = 1; /* Should we go interactive when done? */ int inhibit_user_init = 0; /* Don't load user init file */ int use_emacs_interface = 0; @@ -496,6 +500,19 @@ scm_compile_shell_switches (int argc, char **argv) scm_shell_usage (1, "missing argument to `-l' switch"); } + else if (! strcmp (argv[i], "-L")) /* add to %load-path */ + { + if (++i < argc) + user_load_path = scm_cons (scm_list_3 (sym_set_x, + sym_load_path, + scm_list_3(sym_cons, + scm_makfrom0str (argv[i]), + sym_load_path)), + user_load_path); + else + scm_shell_usage (1, "missing argument to `-L' switch"); + } + else if (! strcmp (argv[i], "-e")) /* entry point */ { if (++i < argc) @@ -629,6 +646,13 @@ scm_compile_shell_switches (int argc, char **argv) /* After the following line, actions will be added to the front. */ tail = scm_reverse_x (tail, SCM_UNDEFINED); + + /* add the user-specified load path here, so it won't be in effect + during the loading of the user's customization file. */ + if(!SCM_NULLP(user_load_path)) + { + tail = scm_append_x( scm_cons2(user_load_path, tail, SCM_EOL) ); + } /* If we didn't end with a -c or a -s and didn't supply a -q, load the user's customization file. */ From e1b29f6a58b7c59441db35082284f3ed74515f6d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 22 Aug 2004 19:29:19 +0000 Subject: [PATCH 046/100] (get_str_buf_start): New helper function. (scm_i_substring, scm_i_substring_copy, scm_i_substring_shared, scm_i_string_char, scm_i_string_writable_chars): Use it. (scm_i_substring_copy): Make START argument optional for C callers, for upcoming SRFI-13 integration. --- libguile/strings.c | 112 +++++++++++++++++++++++++-------------------- 1 file changed, 63 insertions(+), 49 deletions(-) diff --git a/libguile/strings.c b/libguile/strings.c index 1035244db..614f4da9c 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -152,6 +152,16 @@ SCM_MUTEX (stringbuf_write_mutex); #define IS_STRING(str) (SCM_NIMP(str) && SCM_TYP7(str) == STRING_TAG) +/* Mutation-sharing substrings + */ + +#define SH_STRING_TAG (scm_tc7_string + 0x100) + +#define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh)) +/* START and LENGTH as for STRINGs. */ + +#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG) + SCM scm_i_make_string (size_t len, char **charsp) { @@ -175,29 +185,65 @@ validate_substring_args (SCM str, size_t start, size_t end) scm_out_of_range (NULL, scm_from_size_t (end)); } +static inline void +get_str_buf_start (SCM *str, SCM *buf, size_t *start) +{ + *start = STRING_START (*str); + if (IS_SH_STRING (*str)) + { + *str = SH_STRING_STRING (*str); + *start += STRING_START (*str); + } + *buf = STRING_STRINGBUF (*str); +} + SCM scm_i_substring (SCM str, size_t start, size_t end) { - SCM buf = STRING_STRINGBUF (str); + SCM buf; + size_t str_start; + get_str_buf_start (&str, &buf, &str_start); scm_i_plugin_mutex_lock (&stringbuf_write_mutex); SET_STRINGBUF_SHARED (buf); scm_i_plugin_mutex_unlock (&stringbuf_write_mutex); return scm_double_cell (STRING_TAG, SCM_UNPACK(buf), - (scm_t_bits)start, (scm_t_bits) end - start); + (scm_t_bits)str_start + start, + (scm_t_bits) end - start); } SCM scm_i_substring_copy (SCM str, size_t start, size_t end) { size_t len = end - start; - SCM buf = STRING_STRINGBUF (str); + SCM buf; + size_t str_start; + get_str_buf_start (&str, &buf, &str_start); SCM my_buf = make_stringbuf (len); - memcpy (STRINGBUF_CHARS (my_buf), STRINGBUF_CHARS (buf) + start, len); + memcpy (STRINGBUF_CHARS (my_buf), + STRINGBUF_CHARS (buf) + str_start + start, len); scm_remember_upto_here_1 (buf); return scm_double_cell (STRING_TAG, SCM_UNPACK(my_buf), (scm_t_bits)0, (scm_t_bits) len); } +SCM +scm_i_substring_shared (SCM str, size_t start, size_t end) +{ + if (start == 0 && end == STRING_LENGTH (str)) + return str; + else + { + size_t len = end - start; + if (IS_SH_STRING (str)) + { + start += STRING_START (str); + str = SH_STRING_STRING (str); + } + return scm_double_cell (SH_STRING_TAG, SCM_UNPACK(str), + (scm_t_bits)start, (scm_t_bits) len); + } +} + SCM scm_c_substring (SCM str, size_t start, size_t end) { @@ -212,29 +258,6 @@ scm_c_substring_copy (SCM str, size_t start, size_t end) return scm_i_substring_copy (str, start, end); } -/* Mutation-sharing substrings - */ - -#define SH_STRING_TAG (scm_tc7_string + 0x100) - -#define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh)) -/* START and LENGTH as for STRINGs. */ - -#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG) - -SCM -scm_i_substring_shared (SCM str, size_t start, size_t end) -{ - if (start == 0 && end == STRING_LENGTH (str)) - return str; - else - { - SCM res = scm_double_cell (SH_STRING_TAG, SCM_UNPACK(str), - (scm_t_bits)start, (scm_t_bits) end - start); - return res; - } -} - SCM scm_c_substring_shared (SCM str, size_t start, size_t end) { @@ -269,13 +292,8 @@ const char * scm_i_string_chars (SCM str) { SCM buf; - size_t start = STRING_START(str); - if (IS_SH_STRING (str)) - { - str = SH_STRING_STRING (str); - start += STRING_START (str); - } - buf = STRING_STRINGBUF (str); + size_t start; + get_str_buf_start (&str, &buf, &start); return STRINGBUF_CHARS (buf) + start; } @@ -283,13 +301,8 @@ char * scm_i_string_writable_chars (SCM str) { SCM buf; - size_t start = STRING_START(str); - if (IS_SH_STRING (str)) - { - str = SH_STRING_STRING (str); - start += STRING_START (str); - } - buf = STRING_STRINGBUF (str); + size_t start; + get_str_buf_start (&str, &buf, &start); scm_i_plugin_mutex_lock (&stringbuf_write_mutex); if (STRINGBUF_SHARED (buf)) { @@ -461,7 +474,7 @@ SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0, (void), "") -#define FUNC_NAME s_scm_sys_string_dump +#define FUNC_NAME s_scm_sys_stringbuf_hist { int i; for (i = 0; i < 1000; i++) @@ -660,15 +673,16 @@ SCM_DEFINE (scm_substring_copy, "substring/copy", 2, 1, 0, "0 <= @var{start} <= @var{end} <= (string-length @var{str}).") #define FUNC_NAME s_scm_substring_copy { - size_t len, from, to; + /* For the Scheme version, START is mandatory, but for the C + version, it is optional. See scm_string_copy in srfi-13.c for a + rationale. + */ + + size_t from, to; SCM_VALIDATE_STRING (1, str); - len = scm_i_string_length (str); - from = scm_to_unsigned_integer (start, 0, len); - if (SCM_UNBNDP (end)) - to = len; - else - to = scm_to_unsigned_integer (end, from, len); + scm_i_get_substring_spec (scm_i_string_length (str), + start, &from, end, &to); return scm_i_substring_copy (str, from, to); } #undef FUNC_NAME From fcb8ba8ce7f9ecababc659c87237bf49d3184cf8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 22 Aug 2004 19:30:04 +0000 Subject: [PATCH 047/100] (Invoking Guile): documented new '-L' switch. --- doc/ref/scheme-scripts.texi | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/doc/ref/scheme-scripts.texi b/doc/ref/scheme-scripts.texi index ec1675ec2..d1e06b85a 100644 --- a/doc/ref/scheme-scripts.texi +++ b/doc/ref/scheme-scripts.texi @@ -103,6 +103,13 @@ become command-line arguments for the interactive session; the @code{(@var{guile} @var{arg...})}, where @var{guile} is the path of the Guile executable. +@item -L @var{directory} +Add @var{directory} to the front of Guile's module load path. The +given directories are searched in the order given on the command line +and before any directories in the GUILE_LOAD_PATH environment +variable. Paths added here are @emph{not} in effect during execution +of the user's @file{.guile} file. + @item -l @var{file} Load Scheme source code from @var{file}, and continue processing the command line. From 3ece39d651baea34d38aca4f4d51529d1f74225c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 22 Aug 2004 19:31:32 +0000 Subject: [PATCH 048/100] *** empty log message *** --- NEWS | 4 ++++ doc/ref/ChangeLog | 7 +++++++ libguile/ChangeLog | 15 +++++++++++++++ 3 files changed, 26 insertions(+) diff --git a/NEWS b/NEWS index 3e0e2ebd8..f846beb84 100644 --- a/NEWS +++ b/NEWS @@ -135,6 +135,10 @@ provided. Use 'make html'. * Changes to the stand-alone interpreter +** New command line option `-L'. + +This option adds a directory to the front of the load path. + ** New command line option `--no-debug'. Specifying `--no-debug' on the command line will keep the debugging diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 75fe26a86..ff28dfa43 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,10 @@ +2004-08-21 Marius Vollmer + + From Richard Todd, Thanks! + + * scheme-scripts.texi (Invoking Guile): documented new '-L' + switch. + 2004-08-20 Marius Vollmer * gh.texi: Updated transition section with new recommended things. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 58a6e89a4..09c741d6e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,18 @@ +2004-08-22 Marius Vollmer + + * strings.c (get_str_buf_start): New helper function. + (scm_i_substring, scm_i_substring_copy, scm_i_substring_shared, + scm_i_string_char, scm_i_string_writable_chars): Use it. + (scm_i_substring_copy): Make START argument optional for C + callers, for upcoming SRFI-13 integration. + +2004-08-21 Marius Vollmer + + From Richard Todd, Thanks! + + * script.c (scm_compile_shell_switches): added '-L' switch to add + to the %load-path. + 2004-08-21 Dirk Herrmann * eval.c (unmemoize_exprs): When dropping internal body markers From 0ac467456bf2c48264c16b92c3c211c5483aaef3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 23 Aug 2004 10:48:51 +0000 Subject: [PATCH 049/100] * lib.scm (exception:used-before-define): New. * tests/syntax.test ("letrec"): Use it. --- test-suite/lib.scm | 3 +++ test-suite/tests/syntax.test | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/test-suite/lib.scm b/test-suite/lib.scm index ae4ff1628..46083288c 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -25,6 +25,7 @@ exception:bad-variable exception:missing-expression exception:out-of-range exception:unbound-var + exception:used-before-defined exception:wrong-num-args exception:wrong-type-arg exception:numerical-overflow @@ -243,6 +244,8 @@ (cons 'out-of-range "^Argument .*out of range")) (define exception:unbound-var (cons 'unbound-variable "^Unbound variable")) +(define exception:used-before-defined + (cons 'unbound-variable "^Variable used before given a value")) (define exception:wrong-num-args (cons 'wrong-number-of-args "^Wrong number of arguments")) (define exception:wrong-type-arg diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 9b3432af1..ae02ee842 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -430,7 +430,7 @@ (with-test-prefix "bindings" (pass-if-exception "initial bindings are undefined" - exception:unbound-var + exception:used-before-defined (let ((x 1)) (letrec ((x 1) (y x)) y)))) From 87cc0e0cacab088fdb7fa5e205c029069507dd4e Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 23 Aug 2004 10:51:23 +0000 Subject: [PATCH 050/100] Replaced all "@c module" markers with "@c module-for-docstring", making it less likely to collide with a real commentary. --- doc/maint/docstring.el | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/doc/maint/docstring.el b/doc/maint/docstring.el index a01558fbb..02eb4bd5f 100644 --- a/doc/maint/docstring.el +++ b/doc/maint/docstring.el @@ -109,14 +109,14 @@ to which new docstrings should be added.") result)) ;; Return t if the current buffer position is in the scope of the -;; specified MODULE, as determined by "@c module ..." comments in the +;; specified MODULE, as determined by "@c module-for-docstring ..." comments in the ;; buffer. DEFAULT-OK specifies the return value in the case that ;; there are no preceding module comments at all. (defun docstring-in-module (module default-ok) (save-excursion - (if (re-search-backward "^@c module " nil t) + (if (re-search-backward "^@c module-for-docstring " nil t) (progn - (search-forward "@c module ") + (search-forward "@c module-for-docstring ") (equal module (read (current-buffer)))) default-ok))) @@ -222,12 +222,12 @@ to which new docstrings should be added.") (module '(guile))) (save-excursion (goto-char (point-min)) - (while (re-search-forward "^\\(@c module \\|@deffnx? \\({[^}]+}\\|[^ ]+\\) \\([^ \n]+\\)\\)" + (while (re-search-forward "^\\(@c module-for-docstring \\|@deffnx? \\({[^}]+}\\|[^ ]+\\) \\([^ \n]+\\)\\)" nil t) (let ((matched (buffer-substring (match-beginning 1) (match-end 1)))) - (if (string-equal matched "@c module ") + (if (string-equal matched "@c module-for-docstring ") (setq module (read (current-buffer))) (let ((type (buffer-substring (match-beginning 2) (match-end 2)))) @@ -311,7 +311,7 @@ to which new docstrings should be added.") (set-buffer buf) (goto-char (point-max)) (or (docstring-in-module module nil) - (insert "\n@c module " (prin1-to-string module) "\n")) + (insert "\n@c module-for-docstring " (prin1-to-string module) "\n")) (insert "\n" (location-to-docstring (find-snarfed-docstring module description)))))) From 5e46627311f237e44637b60a31c10ec42e4eff8a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 23 Aug 2004 10:51:43 +0000 Subject: [PATCH 051/100] *** empty log message *** --- doc/maint/ChangeLog | 6 ++++++ test-suite/ChangeLog | 5 +++++ 2 files changed, 11 insertions(+) diff --git a/doc/maint/ChangeLog b/doc/maint/ChangeLog index a490b9f51..f50217f0c 100644 --- a/doc/maint/ChangeLog +++ b/doc/maint/ChangeLog @@ -1,3 +1,9 @@ +2004-08-23 Marius Vollmer + + * docstring.el: Replaced all "@c module" markers with "@c + module-for-docstring", making it less likely to collide with a + real commentary. + 2002-10-19 Neil Jerram * guile.texi: Replaced by regenerated libguile version. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 5826ba8de..3e19c2cca 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-08-23 Marius Vollmer + + * lib.scm (exception:used-before-define): New. + * tests/syntax.test ("letrec"): Use it. + 2004-08-20 Kevin Ryde * tests/posix.test (mkstemp!): New tests. From 12eec8a828cb213c222be1a980b7bad746c910aa Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 16:37:25 +0000 Subject: [PATCH 052/100] New file. --- doc/ref/api-undocumented.texi | 700 ++++++++++++++++++++++++++++++++++ 1 file changed, 700 insertions(+) create mode 100644 doc/ref/api-undocumented.texi diff --git a/doc/ref/api-undocumented.texi b/doc/ref/api-undocumented.texi new file mode 100644 index 000000000..c9f99d148 --- /dev/null +++ b/doc/ref/api-undocumented.texi @@ -0,0 +1,700 @@ +This file gathers entries that have been automatically generated from +docstrings in libguile. They are not included in the manual, however, +for various reasons. They are here in this file to give docstring.el a +chance to update them automatically. + +- The 'environments' are only in Guile by accident and are not used at + all and we don't want to advertise them. + +- GOOPS is documented in its own manual. + +@deffn {Scheme Procedure} module-import-interface module sym +@deffnx {C Function} scm_module_import_interface (module, sym) + +@end deffn + + +@deffn {Scheme Procedure} self-evaluating? obj +@deffnx {C Function} scm_self_evaluating_p (obj) +Return #t for objects which Guile considers self-evaluating +@end deffn + +@deffn {Scheme Procedure} unmemoize-expr m +@deffnx {C Function} scm_i_unmemoize_expr (m) +Unmemoize the memoized expression @var{m}, +@end deffn + +@deffn {Scheme Procedure} weak-key-alist-vector? obj +@deffnx {Scheme Procedure} weak-value-alist-vector? obj +@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj +@deffnx {C Function} scm_weak_key_alist_vector_p (obj) +Return @code{#t} if @var{obj} is the specified weak hash +table. Note that a doubly weak hash table is neither a weak key +nor a weak value hash table. +@end deffn + +@deffn {Scheme Procedure} make-weak-key-alist-vector [size] +@deffnx {Scheme Procedure} make-weak-value-alist-vector size +@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size +@deffnx {C Function} scm_make_weak_key_alist_vector (size) +Return a weak hash table with @var{size} buckets. As with any +hash table, choosing a good size for the table requires some +caution. + +You can modify weak hash tables in exactly the same way you +would modify regular hash tables. (@pxref{Hash Tables}) +@end deffn + +@deffn {Scheme Procedure} include-deprecated-features +Return @code{#t} iff deprecated features should be included +in public interfaces. +@end deffn + +@deffn {Scheme Procedure} issue-deprecation-warning . msgs +Output @var{msgs} to @code{(current-error-port)} when this +is the first call to @code{issue-deprecation-warning} with +this specific @var{msg}. Do nothing otherwise. +The argument @var{msgs} should be a list of strings; +they are printed in turn, each one followed by a newline. +@end deffn + +@deffn {Scheme Procedure} valid-object-procedure? proc +@deffnx {C Function} scm_valid_object_procedure_p (proc) +Return @code{#t} iff @var{proc} is a procedure that can be used with @code{set-object-procedure}. It is always valid to use a closure constructed by @code{lambda}. +@end deffn + +@deffn {Scheme Procedure} %get-pre-modules-obarray +@deffnx {C Function} scm_get_pre_modules_obarray () +Return the obarray that is used for all new bindings before the module system is booted. The first call to @code{set-current-module} will boot the module system. +@end deffn + +@deffn {Scheme Procedure} standard-interface-eval-closure module +@deffnx {C Function} scm_standard_interface_eval_closure (module) +Return a interface eval closure for the module @var{module}. Such a closure does not allow new bindings to be added. +@end deffn + +@deffn {Scheme Procedure} env-module env +@deffnx {C Function} scm_env_module (env) +Return the module of @var{ENV}, a lexical environment. +@end deffn + +@deffn {Scheme Procedure} single-active-thread? +implemented by the C function "scm_single_thread_p" +@end deffn + +@deffn {Scheme Procedure} set-debug-cell-accesses! flag +@deffnx {C Function} scm_set_debug_cell_accesses_x (flag) +This function is used to turn on checking for a debug version of GUILE. This version does not support this functionality + +@end deffn + +@deffn {Scheme Procedure} standard-eval-closure module +@deffnx {C Function} scm_standard_eval_closure (module) +Return an eval closure for the module @var{module}. +@end deffn + +@deffn {Scheme Procedure} mask-signals +@deffnx {C Function} scm_mask_signals () +Mask signals. The returned value is not specified. +@end deffn + +@deffn {Scheme Procedure} unmask-signals +@deffnx {C Function} scm_unmask_signals () +Unmask signals. The returned value is not specified. +@end deffn + +@deffn {Scheme Procedure} noop . args +@deffnx {C Function} scm_noop (args) +Do nothing. When called without arguments, return @code{#f}, +otherwise return the first argument. +@end deffn + +@deffn {Scheme Procedure} system-async thunk +@deffnx {C Function} scm_system_async (thunk) +This function is deprecated. You can use @var{thunk} directly +instead of explicitely creating an async object. + +@end deffn + +@deffn {Scheme Procedure} object-address obj +@deffnx {C Function} scm_object_address (obj) +Return an integer that for the lifetime of @var{obj} is uniquely +returned by this function for @var{obj} +@end deffn + +@deffn {Scheme Procedure} environment? obj +@deffnx {C Function} scm_environment_p (obj) +Return @code{#t} if @var{obj} is an environment, or @code{#f} +otherwise. +@end deffn + +@deffn {Scheme Procedure} environment-bound? env sym +@deffnx {C Function} scm_environment_bound_p (env, sym) +Return @code{#t} if @var{sym} is bound in @var{env}, or +@code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} environment-ref env sym +@deffnx {C Function} scm_environment_ref (env, sym) +Return the value of the location bound to @var{sym} in +@var{env}. If @var{sym} is unbound in @var{env}, signal an +@code{environment:unbound} error. +@end deffn + +@deffn {Scheme Procedure} environment-fold env proc init +@deffnx {C Function} scm_environment_fold (env, proc, init) +Iterate over all the bindings in @var{env}, accumulating some +value. +For each binding in @var{env}, apply @var{proc} to the symbol +bound, its value, and the result from the previous application +of @var{proc}. +Use @var{init} as @var{proc}'s third argument the first time +@var{proc} is applied. +If @var{env} contains no bindings, this function simply returns +@var{init}. +If @var{env} binds the symbol sym1 to the value val1, sym2 to +val2, and so on, then this procedure computes: +@lisp + (proc sym1 val1 + (proc sym2 val2 + ... + (proc symn valn + init))) +@end lisp +Each binding in @var{env} will be processed exactly once. +@code{environment-fold} makes no guarantees about the order in +which the bindings are processed. +Here is a function which, given an environment, constructs an +association list representing that environment's bindings, +using environment-fold: +@lisp + (define (environment->alist env) + (environment-fold env + (lambda (sym val tail) + (cons (cons sym val) tail)) + '())) +@end lisp +@end deffn + +@deffn {Scheme Procedure} environment-define env sym val +@deffnx {C Function} scm_environment_define (env, sym, val) +Bind @var{sym} to a new location containing @var{val} in +@var{env}. If @var{sym} is already bound to another location +in @var{env} and the binding is mutable, that binding is +replaced. The new binding and location are both mutable. The +return value is unspecified. +If @var{sym} is already bound in @var{env}, and the binding is +immutable, signal an @code{environment:immutable-binding} error. +@end deffn + +@deffn {Scheme Procedure} environment-undefine env sym +@deffnx {C Function} scm_environment_undefine (env, sym) +Remove any binding for @var{sym} from @var{env}. If @var{sym} +is unbound in @var{env}, do nothing. The return value is +unspecified. +If @var{sym} is already bound in @var{env}, and the binding is +immutable, signal an @code{environment:immutable-binding} error. +@end deffn + +@deffn {Scheme Procedure} environment-set! env sym val +@deffnx {C Function} scm_environment_set_x (env, sym, val) +If @var{env} binds @var{sym} to some location, change that +location's value to @var{val}. The return value is +unspecified. +If @var{sym} is not bound in @var{env}, signal an +@code{environment:unbound} error. If @var{env} binds @var{sym} +to an immutable location, signal an +@code{environment:immutable-location} error. +@end deffn + +@deffn {Scheme Procedure} environment-cell env sym for_write +@deffnx {C Function} scm_environment_cell (env, sym, for_write) +Return the value cell which @var{env} binds to @var{sym}, or +@code{#f} if the binding does not live in a value cell. +The argument @var{for-write} indicates whether the caller +intends to modify the variable's value by mutating the value +cell. If the variable is immutable, then +@code{environment-cell} signals an +@code{environment:immutable-location} error. +If @var{sym} is unbound in @var{env}, signal an +@code{environment:unbound} error. +If you use this function, you should consider using +@code{environment-observe}, to be notified when @var{sym} gets +re-bound to a new value cell, or becomes undefined. +@end deffn + +@deffn {Scheme Procedure} environment-observe env proc +@deffnx {C Function} scm_environment_observe (env, proc) +Whenever @var{env}'s bindings change, apply @var{proc} to +@var{env}. +This function returns an object, token, which you can pass to +@code{environment-unobserve} to remove @var{proc} from the set +of procedures observing @var{env}. The type and value of +token is unspecified. +@end deffn + +@deffn {Scheme Procedure} environment-observe-weak env proc +@deffnx {C Function} scm_environment_observe_weak (env, proc) +This function is the same as environment-observe, except that +the reference @var{env} retains to @var{proc} is a weak +reference. This means that, if there are no other live, +non-weak references to @var{proc}, it will be +garbage-collected, and dropped from @var{env}'s +list of observing procedures. +@end deffn + +@deffn {Scheme Procedure} environment-unobserve token +@deffnx {C Function} scm_environment_unobserve (token) +Cancel the observation request which returned the value +@var{token}. The return value is unspecified. +If a call @code{(environment-observe env proc)} returns +@var{token}, then the call @code{(environment-unobserve token)} +will cause @var{proc} to no longer be called when @var{env}'s +bindings change. +@end deffn + +@deffn {Scheme Procedure} make-leaf-environment +@deffnx {C Function} scm_make_leaf_environment () +Create a new leaf environment, containing no bindings. +All bindings and locations created in the new environment +will be mutable. +@end deffn + +@deffn {Scheme Procedure} leaf-environment? object +@deffnx {C Function} scm_leaf_environment_p (object) +Return @code{#t} if object is a leaf environment, or @code{#f} +otherwise. +@end deffn + +@deffn {Scheme Procedure} make-eval-environment local imported +@deffnx {C Function} scm_make_eval_environment (local, imported) +Return a new environment object eval whose bindings are the +union of the bindings in the environments @var{local} and +@var{imported}, with bindings from @var{local} taking +precedence. Definitions made in eval are placed in @var{local}. +Applying @code{environment-define} or +@code{environment-undefine} to eval has the same effect as +applying the procedure to @var{local}. +Note that eval incorporates @var{local} and @var{imported} by +reference: +If, after creating eval, the program changes the bindings of +@var{local} or @var{imported}, those changes will be visible +in eval. +Since most Scheme evaluation takes place in eval environments, +they transparently cache the bindings received from @var{local} +and @var{imported}. Thus, the first time the program looks up +a symbol in eval, eval may make calls to @var{local} or +@var{imported} to find their bindings, but subsequent +references to that symbol will be as fast as references to +bindings in finite environments. +In typical use, @var{local} will be a finite environment, and +@var{imported} will be an import environment +@end deffn + +@deffn {Scheme Procedure} eval-environment? object +@deffnx {C Function} scm_eval_environment_p (object) +Return @code{#t} if object is an eval environment, or @code{#f} +otherwise. +@end deffn + +@deffn {Scheme Procedure} eval-environment-local env +@deffnx {C Function} scm_eval_environment_local (env) +Return the local environment of eval environment @var{env}. +@end deffn + +@deffn {Scheme Procedure} eval-environment-set-local! env local +@deffnx {C Function} scm_eval_environment_set_local_x (env, local) +Change @var{env}'s local environment to @var{local}. +@end deffn + +@deffn {Scheme Procedure} eval-environment-imported env +@deffnx {C Function} scm_eval_environment_imported (env) +Return the imported environment of eval environment @var{env}. +@end deffn + +@deffn {Scheme Procedure} eval-environment-set-imported! env imported +@deffnx {C Function} scm_eval_environment_set_imported_x (env, imported) +Change @var{env}'s imported environment to @var{imported}. +@end deffn + +@deffn {Scheme Procedure} make-import-environment imports conflict_proc +@deffnx {C Function} scm_make_import_environment (imports, conflict_proc) +Return a new environment @var{imp} whose bindings are the union +of the bindings from the environments in @var{imports}; +@var{imports} must be a list of environments. That is, +@var{imp} binds a symbol to a location when some element of +@var{imports} does. +If two different elements of @var{imports} have a binding for +the same symbol, the @var{conflict-proc} is called with the +following parameters: the import environment, the symbol and +the list of the imported environments that bind the symbol. +If the @var{conflict-proc} returns an environment @var{env}, +the conflict is considered as resolved and the binding from +@var{env} is used. If the @var{conflict-proc} returns some +non-environment object, the conflict is considered unresolved +and the symbol is treated as unspecified in the import +environment. +The checking for conflicts may be performed lazily, i. e. at +the moment when a value or binding for a certain symbol is +requested instead of the moment when the environment is +created or the bindings of the imports change. +All bindings in @var{imp} are immutable. If you apply +@code{environment-define} or @code{environment-undefine} to +@var{imp}, Guile will signal an + @code{environment:immutable-binding} error. However, +notice that the set of bindings in @var{imp} may still change, +if one of its imported environments changes. +@end deffn + +@deffn {Scheme Procedure} import-environment? object +@deffnx {C Function} scm_import_environment_p (object) +Return @code{#t} if object is an import environment, or +@code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} import-environment-imports env +@deffnx {C Function} scm_import_environment_imports (env) +Return the list of environments imported by the import +environment @var{env}. +@end deffn + +@deffn {Scheme Procedure} import-environment-set-imports! env imports +@deffnx {C Function} scm_import_environment_set_imports_x (env, imports) +Change @var{env}'s list of imported environments to +@var{imports}, and check for conflicts. +@end deffn + +@deffn {Scheme Procedure} make-export-environment private signature +@deffnx {C Function} scm_make_export_environment (private, signature) +Return a new environment @var{exp} containing only those +bindings in private whose symbols are present in +@var{signature}. The @var{private} argument must be an +environment. + +The environment @var{exp} binds symbol to location when +@var{env} does, and symbol is exported by @var{signature}. + +@var{signature} is a list specifying which of the bindings in +@var{private} should be visible in @var{exp}. Each element of +@var{signature} should be a list of the form: + (symbol attribute ...) +where each attribute is one of the following: +@table @asis +@item the symbol @code{mutable-location} + @var{exp} should treat the + location bound to symbol as mutable. That is, @var{exp} + will pass calls to @code{environment-set!} or + @code{environment-cell} directly through to private. +@item the symbol @code{immutable-location} + @var{exp} should treat + the location bound to symbol as immutable. If the program + applies @code{environment-set!} to @var{exp} and symbol, or + calls @code{environment-cell} to obtain a writable value + cell, @code{environment-set!} will signal an + @code{environment:immutable-location} error. Note that, even + if an export environment treats a location as immutable, the + underlying environment may treat it as mutable, so its + value may change. +@end table +It is an error for an element of signature to specify both +@code{mutable-location} and @code{immutable-location}. If +neither is specified, @code{immutable-location} is assumed. + +As a special case, if an element of signature is a lone +symbol @var{sym}, it is equivalent to an element of the form +@code{(sym)}. + +All bindings in @var{exp} are immutable. If you apply +@code{environment-define} or @code{environment-undefine} to +@var{exp}, Guile will signal an +@code{environment:immutable-binding} error. However, +notice that the set of bindings in @var{exp} may still change, +if the bindings in private change. +@end deffn + +@deffn {Scheme Procedure} export-environment? object +@deffnx {C Function} scm_export_environment_p (object) +Return @code{#t} if object is an export environment, or +@code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} export-environment-private env +@deffnx {C Function} scm_export_environment_private (env) +Return the private environment of export environment @var{env}. +@end deffn + +@deffn {Scheme Procedure} export-environment-set-private! env private +@deffnx {C Function} scm_export_environment_set_private_x (env, private) +Change the private environment of export environment @var{env}. +@end deffn + +@deffn {Scheme Procedure} export-environment-signature env +@deffnx {C Function} scm_export_environment_signature (env) +Return the signature of export environment @var{env}. +@end deffn + +@deffn {Scheme Procedure} export-environment-set-signature! env signature +@deffnx {C Function} scm_export_environment_set_signature_x (env, signature) +Change the signature of export environment @var{env}. +@end deffn + +@deffn {Scheme Procedure} %compute-slots class +@deffnx {C Function} scm_sys_compute_slots (class) +Return a list consisting of the names of all slots belonging to +class @var{class}, i. e. the slots of @var{class} and of all of +its superclasses. +@end deffn + +@deffn {Scheme Procedure} get-keyword key l default_value +@deffnx {C Function} scm_get_keyword (key, l, default_value) +Determine an associated value for the keyword @var{key} from +the list @var{l}. The list @var{l} has to consist of an even +number of elements, where, starting with the first, every +second element is a keyword, followed by its associated value. +If @var{l} does not hold a value for @var{key}, the value +@var{default_value} is returned. +@end deffn + +@deffn {Scheme Procedure} slot-ref-using-class class obj slot_name +@deffnx {C Function} scm_slot_ref_using_class (class, obj, slot_name) + +@end deffn + +@deffn {Scheme Procedure} slot-set-using-class! class obj slot_name value +@deffnx {C Function} scm_slot_set_using_class_x (class, obj, slot_name, value) + +@end deffn + +@deffn {Scheme Procedure} class-of x +@deffnx {C Function} scm_class_of (x) +Return the class of @var{x}. +@end deffn + +@deffn {Scheme Procedure} %goops-loaded +@deffnx {C Function} scm_sys_goops_loaded () +Announce that GOOPS is loaded and perform initialization +on the C level which depends on the loaded GOOPS modules. +@end deffn + +@deffn {Scheme Procedure} %method-more-specific? m1 m2 targs +@deffnx {C Function} scm_sys_method_more_specific_p (m1, m2, targs) + +@end deffn + +@deffn {Scheme Procedure} find-method . l +@deffnx {C Function} scm_find_method (l) + +@end deffn + +@deffn {Scheme Procedure} primitive-generic-generic subr +@deffnx {C Function} scm_primitive_generic_generic (subr) + +@end deffn + +@deffn {Scheme Procedure} enable-primitive-generic! . subrs +@deffnx {C Function} scm_enable_primitive_generic_x (subrs) + +@end deffn + +@deffn {Scheme Procedure} generic-capability? proc +@deffnx {C Function} scm_generic_capability_p (proc) + +@end deffn + +@deffn {Scheme Procedure} %invalidate-method-cache! gf +@deffnx {C Function} scm_sys_invalidate_method_cache_x (gf) + +@end deffn + +@deffn {Scheme Procedure} %invalidate-class class +@deffnx {C Function} scm_sys_invalidate_class (class) + +@end deffn + +@deffn {Scheme Procedure} %modify-class old new +@deffnx {C Function} scm_sys_modify_class (old, new) + +@end deffn + +@deffn {Scheme Procedure} %modify-instance old new +@deffnx {C Function} scm_sys_modify_instance (old, new) + +@end deffn + +@deffn {Scheme Procedure} %set-object-setter! obj setter +@deffnx {C Function} scm_sys_set_object_setter_x (obj, setter) + +@end deffn + +@deffn {Scheme Procedure} %allocate-instance class initargs +@deffnx {C Function} scm_sys_allocate_instance (class, initargs) +Create a new instance of class @var{class} and initialize it +from the arguments @var{initargs}. +@end deffn + +@deffn {Scheme Procedure} slot-exists? obj slot_name +@deffnx {C Function} scm_slot_exists_p (obj, slot_name) +Return @code{#t} if @var{obj} has a slot named @var{slot_name}. +@end deffn + +@deffn {Scheme Procedure} slot-bound? obj slot_name +@deffnx {C Function} scm_slot_bound_p (obj, slot_name) +Return @code{#t} if the slot named @var{slot_name} of @var{obj} +is bound. +@end deffn + +@deffn {Scheme Procedure} slot-set! obj slot_name value +@deffnx {C Function} scm_slot_set_x (obj, slot_name, value) +Set the slot named @var{slot_name} of @var{obj} to @var{value}. +@end deffn + +@deffn {Scheme Procedure} slot-exists-using-class? class obj slot_name +@deffnx {C Function} scm_slot_exists_using_class_p (class, obj, slot_name) + +@end deffn + +@deffn {Scheme Procedure} slot-bound-using-class? class obj slot_name +@deffnx {C Function} scm_slot_bound_using_class_p (class, obj, slot_name) + +@end deffn + +@deffn {Scheme Procedure} %fast-slot-set! obj index value +@deffnx {C Function} scm_sys_fast_slot_set_x (obj, index, value) +Set the slot with index @var{index} in @var{obj} to +@var{value}. +@end deffn + +@deffn {Scheme Procedure} %fast-slot-ref obj index +@deffnx {C Function} scm_sys_fast_slot_ref (obj, index) +Return the slot value with index @var{index} from @var{obj}. +@end deffn + +@deffn {Scheme Procedure} @@assert-bound-ref obj index +@deffnx {C Function} scm_at_assert_bound_ref (obj, index) +Like @code{assert-bound}, but use @var{index} for accessing +the value from @var{obj}. +@end deffn + +@deffn {Scheme Procedure} assert-bound value obj +@deffnx {C Function} scm_assert_bound (value, obj) +Return @var{value} if it is bound, and invoke the +@var{slot-unbound} method of @var{obj} if it is not. +@end deffn + +@deffn {Scheme Procedure} unbound? obj +@deffnx {C Function} scm_unbound_p (obj) +Return @code{#t} if @var{obj} is unbound. +@end deffn + +@deffn {Scheme Procedure} make-unbound +@deffnx {C Function} scm_make_unbound () +Return the unbound value. +@end deffn + +@deffn {Scheme Procedure} accessor-method-slot-definition obj +@deffnx {C Function} scm_accessor_method_slot_definition (obj) +Return the slot definition of the accessor @var{obj}. +@end deffn + +@deffn {Scheme Procedure} method-procedure obj +@deffnx {C Function} scm_method_procedure (obj) +Return the procedure of the method @var{obj}. +@end deffn + +@deffn {Scheme Procedure} method-specializers obj +@deffnx {C Function} scm_method_specializers (obj) +Return specializers of the method @var{obj}. +@end deffn + +@deffn {Scheme Procedure} method-generic-function obj +@deffnx {C Function} scm_method_generic_function (obj) +Return the generic function for the method @var{obj}. +@end deffn + +@deffn {Scheme Procedure} generic-function-methods obj +@deffnx {C Function} scm_generic_function_methods (obj) +Return the methods of the generic function @var{obj}. +@end deffn + +@deffn {Scheme Procedure} generic-function-name obj +@deffnx {C Function} scm_generic_function_name (obj) +Return the name of the generic function @var{obj}. +@end deffn + +@deffn {Scheme Procedure} class-environment obj +@deffnx {C Function} scm_class_environment (obj) +Return the environment of the class @var{obj}. +@end deffn + +@deffn {Scheme Procedure} class-slots obj +@deffnx {C Function} scm_class_slots (obj) +Return the slot list of the class @var{obj}. +@end deffn + +@deffn {Scheme Procedure} class-precedence-list obj +@deffnx {C Function} scm_class_precedence_list (obj) +Return the class precedence list of the class @var{obj}. +@end deffn + +@deffn {Scheme Procedure} class-direct-methods obj +@deffnx {C Function} scm_class_direct_methods (obj) +Return the direct methods of the class @var{obj} +@end deffn + +@deffn {Scheme Procedure} class-direct-subclasses obj +@deffnx {C Function} scm_class_direct_subclasses (obj) +Return the direct subclasses of the class @var{obj}. +@end deffn + +@deffn {Scheme Procedure} class-direct-slots obj +@deffnx {C Function} scm_class_direct_slots (obj) +Return the direct slots of the class @var{obj}. +@end deffn + +@deffn {Scheme Procedure} class-direct-supers obj +@deffnx {C Function} scm_class_direct_supers (obj) +Return the direct superclasses of the class @var{obj}. +@end deffn + +@deffn {Scheme Procedure} class-name obj +@deffnx {C Function} scm_class_name (obj) +Return the class name of @var{obj}. +@end deffn + +@deffn {Scheme Procedure} instance? obj +@deffnx {C Function} scm_instance_p (obj) +Return @code{#t} if @var{obj} is an instance. +@end deffn + +@deffn {Scheme Procedure} %inherit-magic! class dsupers +@deffnx {C Function} scm_sys_inherit_magic_x (class, dsupers) + +@end deffn + +@deffn {Scheme Procedure} %prep-layout! class +@deffnx {C Function} scm_sys_prep_layout_x (class) + +@end deffn + +@deffn {Scheme Procedure} %initialize-object obj initargs +@deffnx {C Function} scm_sys_initialize_object (obj, initargs) +Initialize the object @var{obj} with the given arguments +@var{initargs}. +@end deffn + +@deffn {Scheme Procedure} make . args +@deffnx {C Function} scm_make (args) +Make a new object. @var{args} must contain the class and +all necessary initialization information. +@end deffn + +@deffn {Scheme Procedure} slot-ref obj slot_name +@deffnx {C Function} scm_slot_ref (obj, slot_name) +Return the value from @var{obj}'s slot with the name +@var{slot_name}. +@end deffn + +@deffn {Scheme Procedure} %tag-body body +@deffnx {C Function} scm_sys_tag_body (body) +Internal GOOPS magic---don't use this function! +@end deffn From cdf1ad3bc9ccc9f6bad737be285e2010a01b43e5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 16:40:54 +0000 Subject: [PATCH 053/100] Ran a (docstring-process-module "(guile)") and moved entries from new-docstrings.texi to their appropriate place. --- doc/ref/api-compound.texi | 12 +- doc/ref/api-data.texi | 20 + doc/ref/api-io.texi | 19 +- doc/ref/api-memory.texi | 19 +- doc/ref/api-modules.texi | 80 ++++ doc/ref/api-scheduling.texi | 38 +- doc/ref/api-utility.texi | 2 +- doc/ref/new-docstrings.texi | 743 +----------------------------------- 8 files changed, 163 insertions(+), 770 deletions(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index f117e1cfc..9d9eec3b7 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -308,7 +308,7 @@ Return the number of elements in list @var{lst}. @deffn {Scheme Procedure} last-pair lst @deffnx {C Function} scm_last_pair (lst) -Return a pointer to the last pair in @var{lst}, signalling an error if +Return the last pair in @var{lst}, signalling an error if @var{lst} is circular. @end deffn @@ -2379,6 +2379,16 @@ then it can use @var{size} to avoid rehashing when initial entries are added. @end deffn +@deffn {Scheme Procedure} hash-table? obj +@deffnx {C Function} scm_hash_table_p (obj) +Return @code{#t} if @var{obj} is a hash table. +@end deffn + +@deffn {Scheme Procedure} hash-clear! table +@deffnx {C Function} scm_hash_clear_x (table) +Remove all items from TABLE (without triggering a resize). +@end deffn + @deffn {Scheme Procedure} hash-ref table key [dflt] @deffnx {Scheme Procedure} hashq-ref table key [dflt] @deffnx {Scheme Procedure} hashv-ref table key [dflt] diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 28e580ffc..3cb6a0612 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -588,6 +588,16 @@ Return @code{#t} if @var{x} is either @samp{+inf.0} or @samp{-inf.0}, Return @code{#t} if @var{x} is @samp{+nan.0}, @code{#f} otherwise. @end deffn +@deffn {Scheme Procedure} nan +@deffnx {C Function} scm_nan () +Return NaN. +@end deffn + +@deffn {Scheme Procedure} inf +@deffnx {C Function} scm_inf () +Return Inf. +@end deffn + @deffn {Scheme Procedure} numerator x @deffnx {C Function} scm_numerator (x) Return the numerator of the rational number @var{x}. @@ -887,6 +897,16 @@ The C function @code{scm_lcm} always takes two arguments, while the Scheme function can take an arbitrary number. @end deffn +@deffn {Scheme Procedure} modulo-expt n k m +@deffnx {C Function} scm_modulo_expt (n, k, m) +Return @var{n} raised to the integer exponent +@var{k}, modulo @var{m}. + +@lisp +(modulo-expt 2 3 5) + @result{} 3 +@end lisp +@end deffn @node Comparison @subsubsection Comparison Predicates diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index d5ba25b43..4a38a8378 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -108,14 +108,15 @@ and return @code{#f} otherwise. If @code{char-ready?} returns @code{#t} then the next @code{read-char} operation on @var{port} is guaranteed not to hang. If @var{port} is a file port at end of file then @code{char-ready?} returns @code{#t}. -@footnote{@code{char-ready?} exists to make it possible for a + +@code{char-ready?} exists to make it possible for a program to accept characters from interactive ports without getting stuck waiting for input. Any input editors associated with such ports must make sure that characters whose existence has been asserted by @code{char-ready?} cannot be rubbed out. If @code{char-ready?} were to return @code{#f} at end of file, a port at end of file would be indistinguishable from an -interactive port that has no ready characters.} +interactive port that has no ready characters. @end deffn @rnindex read-char @@ -141,7 +142,9 @@ Note that this function does not update @code{port-line} and Return the next character available from @var{port}, @emph{without} updating @var{port} to point to the following character. If no more characters are available, the -end-of-file object is returned.@footnote{The value returned by +end-of-file object is returned. + +The value returned by a call to @code{peek-char} is the same as the value that would have been returned by a call to @code{read-char} on the same port. The only difference is that the very next call to @@ -149,7 +152,7 @@ port. The only difference is that the very next call to return the value returned by the preceding call to @code{peek-char}. In particular, a call to @code{peek-char} on an interactive port will hang waiting for input whenever a call -to @code{read-char} would have hung.} +to @code{read-char} would have hung. @end deffn @deffn {Scheme Procedure} unread-char cobj [port] @@ -248,10 +251,12 @@ Send a newline to @var{port}. If @var{port} is omitted, send to the current output port. @end deffn -@deffn {Scheme Procedure} port-with-print-state port pstate +@deffn {Scheme Procedure} port-with-print-state port [pstate] @deffnx {C Function} scm_port_with_print_state (port, pstate) Create a new port which behaves like @var{port}, but with an -included print state @var{pstate}. +included print state @var{pstate}. @var{pstate} is optional. +If @var{pstate} isn't supplied and @var{port} already has +a print state, the old print state is reused. @end deffn @deffn {Scheme Procedure} print-options-interface [setting] @@ -391,7 +396,7 @@ Truncates the object referred to by @var{object} to at most @var{length} bytes. @var{object} can be a string containing a file name or an integer file descriptor or a port. @var{length} may be omitted if @var{object} is not a file name, -in which case the truncation occurs at the current port. +in which case the truncation occurs at the current port position. The return value is unspecified. @end deffn diff --git a/doc/ref/api-memory.texi b/doc/ref/api-memory.texi index 62bc23ec6..8b015940c 100644 --- a/doc/ref/api-memory.texi +++ b/doc/ref/api-memory.texi @@ -323,13 +323,13 @@ To implement a mapping from source code expressions to the procedures they constitute a doubly-weak table has to be used. @menu -* Weak key hashes:: +* Weak hash tables:: * Weak vectors:: @end menu -@node Weak key hashes -@subsubsection Weak key hashes +@node Weak hash tables +@subsubsection Weak hash tables @deffn {Scheme Procedure} make-weak-key-hash-table size @deffnx {Scheme Procedure} make-weak-value-hash-table size @@ -356,19 +356,6 @@ table. Note that a doubly weak hash table is neither a weak key nor a weak value hash table. @end deffn -@deffn {Scheme Procedure} make-weak-value-hash-table k -@end deffn - -@deffn {Scheme Procedure} weak-value-hash-table? x -@end deffn - -@deffn {Scheme Procedure} make-doubly-weak-hash-table k -@end deffn - -@deffn {Scheme Procedure} doubly-weak-hash-table? x -@end deffn - - @node Weak vectors @subsubsection Weak vectors diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index 822c396fe..c699e88e1 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-modules.texi @@ -149,6 +149,7 @@ there is still some flux. * General Information about Modules:: Guile module basics. * Using Guile Modules:: How to use existing modules. * Creating Guile Modules:: How to package your code into modules. +* Module System Reflection:: Accessing module objects at run-time. * Module System Quirks:: Strange things to be aware of. * Included Guile Modules:: Which modules come with Guile? * Accessing Modules from C:: How to work with modules with C code. @@ -424,6 +425,47 @@ Equivalent to @code{(begin (define foo ...) (export foo))}. @end deffn @c end +@node Module System Reflection +@subsubsection Module System Reflection + +The previous sections have described a declarative view of the module +system. You can also work with it programmatically by accessing and +modifying various parts of the Scheme objects that Guile uses to +implement the module system. + +At any time, there is a @dfn{current module}. This module is the one +where a top-level @code{define} and similar syntax will add new +bindings. You can find other module objects with @code{resolve-module}, +for example. + +These module objects can be used as the second argument to @code{eval}. + +@deffn {Scheme Procedure} current-module +Return the current module object. +@end deffn + +@deffn {Scheme Procedure} set-current-module module +Set the current module to @var{module} and return +the previous current module. +@end deffn + +@deffn {Scheme Procedure} resolve-module name +Find the module named @var{name} and return it. When it has not already +been defined, try to auto-load it. When it can't be found that way +either, create an empty module. The name is a list of symbols. +@end deffn + +@deffn {Scheme Procedure} resolve-interface name +Find the module named @var{name} as with @code{resolve-module} and +return its interface. The interface of a module is also a module +object, but it contains only the exported bindings. +@end deffn + +@deffn {Scheme Procedure} module-use! module interface +Add @var{interface} to the front of the use-list of @var{module}. Both +arguments should be module objects, and @var{interface} should very +likely be a module returned by @code{resolve-interface}. +@end deffn @node Module System Quirks @subsubsection Module System Quirks @@ -956,6 +998,44 @@ guile> (apropos "j0") That's it! +@deffn {Scheme Procedure} load-extension lib init +@deffnx {C Function} scm_load_extension (lib, init) +Load and initialize the extension designated by LIB and INIT. +When there is no pre-registered function for LIB/INIT, this is +equivalent to + +@lisp +(dynamic-call INIT (dynamic-link LIB)) +@end lisp + +When there is a pre-registered function, that function is called +instead. + +Normally, there is no pre-registered function. This option exists +only for situations where dynamic linking is unavailable or unwanted. +In that case, you would statically link your program with the desired +library, and register its init function right after Guile has been +initialized. + +LIB should be a string denoting a shared library without any file type +suffix such as ".so". The suffix is provided automatically. It +should also not contain any directory components. Libraries that +implement Guile Extensions should be put into the normal locations for +shared libraries. We recommend to use the naming convention +libguile-bla-blum for a extension related to a module `(bla blum)'. + +The normal way for a extension to be used is to write a small Scheme +file that defines a module, and to load the extension into this +module. When the module is auto-loaded, the extension is loaded as +well. For example, + +@lisp +(define-module (bla blum)) + +(load-extension "libguile-bla-blum" "bla_init_blum") +@end lisp +@end deffn + @node Variables @subsection Variables @tpindex Variables diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index f85ea4aaa..a61f2ed7d 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -39,14 +39,17 @@ returned. @deffn {Scheme Procedure} make-arbiter name @deffnx {C Function} scm_make_arbiter (name) -Return an arbiter object, initially unlocked. Currently @var{name} is -only used for diagnostic output. +Return an object of type arbiter and name @var{name}. Its +state is initially unlocked. Arbiters are a way to achieve +process synchronization. @end deffn @deffn {Scheme Procedure} try-arbiter arb @deffnx {C Function} scm_try_arbiter (arb) -If @var{arb} is unlocked, then lock it and return @code{#t}. If -@var{arb} is already locked, then do nothing and return @code{#f}. +@deffnx {C Function} scm_try_arbiter (arb) +If @var{arb} is unlocked, then lock it and return @code{#t}. +If @var{arb} is already locked, then do nothing and return +@code{#f}. @end deffn @deffn {Scheme Procedure} release-arbiter arb @@ -323,8 +326,15 @@ threads must rendezvous. @node Low level thread primitives @subsubsection Low level thread primitives -@c NJFIXME no current mechanism for making sure that these docstrings -@c are in sync. +@deffn {Scheme Procedure} all-threads +@deffnx {C Function} scm_all_threads () +Return a list of all threads. +@end deffn + +@deffn {Scheme Procedure} current-thread +@deffnx {C Function} scm_current_thread () +Return the thread that called this function. +@end deffn @c begin (texi-doc-string "guile" "call-with-new-thread") @deffn {Scheme Procedure} call-with-new-thread thunk error-handler @@ -346,6 +356,11 @@ Suspend execution of the calling thread until the target @var{thread} terminates, unless the target @var{thread} has already terminated. @end deffn +@deffn {Scheme Procedure} thread-exited? thread +@deffnx {C Function} scm_thread_exited_p (thread) +Return @code{#t} iff @var{thread} has exited. +@end deffn + @c begin (texi-doc-string "guile" "yield") @deffn {Scheme Procedure} yield If one or more threads are waiting to execute, calling yield forces an @@ -357,6 +372,11 @@ immediate context switch to one of them. Otherwise, yield has no effect. Make a new condition variable. @end deffn +@deffn {Scheme Procedure} make-fair-condition-variable +@deffnx {C Function} scm_make_fair_condition_variable () +Make a new fair condition variable. +@end deffn + @c begin (texi-doc-string "guile" "wait-condition-variable") @deffn {Scheme Procedure} wait-condition-variable cond-var mutex [time] Wait until @var{cond-var} has been signalled. While waiting, @@ -610,6 +630,12 @@ Set the value associated with @var{fluid} in the current dynamic root. so that the given procedure and each procedure called by it access the given values. After the procedure returns, the old values are restored. +@deffn {Scheme Procedure} with-fluid* fluid value thunk +@deffnx {C Function} scm_with_fluid (fluid, value, thunk) +Set @var{fluid} to @var{value} temporarily, and call @var{thunk}. +@var{thunk} must be a procedure with no argument. +@end deffn + @deffn {Scheme Procedure} with-fluids* fluids values thunk @deffnx {C Function} scm_with_fluids (fluids, values, thunk) Set @var{fluids} to @var{values} temporary, and call @var{thunk}. diff --git a/doc/ref/api-utility.texi b/doc/ref/api-utility.texi index 8cc662fa7..669bf1b5c 100644 --- a/doc/ref/api-utility.texi +++ b/doc/ref/api-utility.texi @@ -355,7 +355,7 @@ copies any pairs in the cars of the input lists. @deffn {Scheme Procedure} copy-tree obj @deffnx {C Function} scm_copy_tree (obj) Recursively copy the data tree that is bound to @var{obj}, and return a -pointer to the new data structure. @code{copy-tree} recurses down the +the new data structure. @code{copy-tree} recurses down the contents of both pairs and vectors (since both cons cells and vector cells may point to arbitrary objects), and stops recursing when it hits any other object. diff --git a/doc/ref/new-docstrings.texi b/doc/ref/new-docstrings.texi index 79d45148c..91e9e9651 100644 --- a/doc/ref/new-docstrings.texi +++ b/doc/ref/new-docstrings.texi @@ -1,743 +1,8 @@ +@c module-for-docstring (guile) -@c module (guile) -@deffn {Scheme Procedure} environment? obj -@deffnx {C Function} scm_environment_p (obj) -Return @code{#t} if @var{obj} is an environment, or @code{#f} +@deffn {Scheme Procedure} inf? n +@deffnx {C Function} scm_inf_p (n) +Return @code{#t} if @var{n} is infinite, @code{#f} otherwise. @end deffn - -@deffn {Scheme Procedure} environment-bound? env sym -@deffnx {C Function} scm_environment_bound_p (env, sym) -Return @code{#t} if @var{sym} is bound in @var{env}, or -@code{#f} otherwise. -@end deffn - -@deffn {Scheme Procedure} environment-ref env sym -@deffnx {C Function} scm_environment_ref (env, sym) -Return the value of the location bound to @var{sym} in -@var{env}. If @var{sym} is unbound in @var{env}, signal an -@code{environment:unbound} error. -@end deffn - -@deffn {Scheme Procedure} environment-fold env proc init -@deffnx {C Function} scm_environment_fold (env, proc, init) -Iterate over all the bindings in @var{env}, accumulating some -value. -For each binding in @var{env}, apply @var{proc} to the symbol -bound, its value, and the result from the previous application -of @var{proc}. -Use @var{init} as @var{proc}'s third argument the first time -@var{proc} is applied. -If @var{env} contains no bindings, this function simply returns -@var{init}. -If @var{env} binds the symbol sym1 to the value val1, sym2 to -val2, and so on, then this procedure computes: -@lisp - (proc sym1 val1 - (proc sym2 val2 - ... - (proc symn valn - init))) -@end lisp -Each binding in @var{env} will be processed exactly once. -@code{environment-fold} makes no guarantees about the order in -which the bindings are processed. -Here is a function which, given an environment, constructs an -association list representing that environment's bindings, -using environment-fold: -@lisp - (define (environment->alist env) - (environment-fold env - (lambda (sym val tail) - (cons (cons sym val) tail)) - '())) -@end lisp -@end deffn - -@deffn {Scheme Procedure} environment-define env sym val -@deffnx {C Function} scm_environment_define (env, sym, val) -Bind @var{sym} to a new location containing @var{val} in -@var{env}. If @var{sym} is already bound to another location -in @var{env} and the binding is mutable, that binding is -replaced. The new binding and location are both mutable. The -return value is unspecified. -If @var{sym} is already bound in @var{env}, and the binding is -immutable, signal an @code{environment:immutable-binding} error. -@end deffn - -@deffn {Scheme Procedure} environment-undefine env sym -@deffnx {C Function} scm_environment_undefine (env, sym) -Remove any binding for @var{sym} from @var{env}. If @var{sym} -is unbound in @var{env}, do nothing. The return value is -unspecified. -If @var{sym} is already bound in @var{env}, and the binding is -immutable, signal an @code{environment:immutable-binding} error. -@end deffn - -@deffn {Scheme Procedure} environment-set! env sym val -@deffnx {C Function} scm_environment_set_x (env, sym, val) -If @var{env} binds @var{sym} to some location, change that -location's value to @var{val}. The return value is -unspecified. -If @var{sym} is not bound in @var{env}, signal an -@code{environment:unbound} error. If @var{env} binds @var{sym} -to an immutable location, signal an -@code{environment:immutable-location} error. -@end deffn - -@deffn {Scheme Procedure} environment-cell env sym for_write -@deffnx {C Function} scm_environment_cell (env, sym, for_write) -Return the value cell which @var{env} binds to @var{sym}, or -@code{#f} if the binding does not live in a value cell. -The argument @var{for-write} indicates whether the caller -intends to modify the variable's value by mutating the value -cell. If the variable is immutable, then -@code{environment-cell} signals an -@code{environment:immutable-location} error. -If @var{sym} is unbound in @var{env}, signal an -@code{environment:unbound} error. -If you use this function, you should consider using -@code{environment-observe}, to be notified when @var{sym} gets -re-bound to a new value cell, or becomes undefined. -@end deffn - -@deffn {Scheme Procedure} environment-observe env proc -@deffnx {C Function} scm_environment_observe (env, proc) -Whenever @var{env}'s bindings change, apply @var{proc} to -@var{env}. -This function returns an object, token, which you can pass to -@code{environment-unobserve} to remove @var{proc} from the set -of procedures observing @var{env}. The type and value of -token is unspecified. -@end deffn - -@deffn {Scheme Procedure} environment-observe-weak env proc -@deffnx {C Function} scm_environment_observe_weak (env, proc) -This function is the same as environment-observe, except that -the reference @var{env} retains to @var{proc} is a weak -reference. This means that, if there are no other live, -non-weak references to @var{proc}, it will be -garbage-collected, and dropped from @var{env}'s -list of observing procedures. -@end deffn - -@deffn {Scheme Procedure} environment-unobserve token -@deffnx {C Function} scm_environment_unobserve (token) -Cancel the observation request which returned the value -@var{token}. The return value is unspecified. -If a call @code{(environment-observe env proc)} returns -@var{token}, then the call @code{(environment-unobserve token)} -will cause @var{proc} to no longer be called when @var{env}'s -bindings change. -@end deffn - -@deffn {Scheme Procedure} make-leaf-environment -@deffnx {C Function} scm_make_leaf_environment () -Create a new leaf environment, containing no bindings. -All bindings and locations created in the new environment -will be mutable. -@end deffn - -@deffn {Scheme Procedure} leaf-environment? object -@deffnx {C Function} scm_leaf_environment_p (object) -Return @code{#t} if object is a leaf environment, or @code{#f} -otherwise. -@end deffn - -@deffn {Scheme Procedure} make-eval-environment local imported -@deffnx {C Function} scm_make_eval_environment (local, imported) -Return a new environment object eval whose bindings are the -union of the bindings in the environments @var{local} and -@var{imported}, with bindings from @var{local} taking -precedence. Definitions made in eval are placed in @var{local}. -Applying @code{environment-define} or -@code{environment-undefine} to eval has the same effect as -applying the procedure to @var{local}. -Note that eval incorporates @var{local} and @var{imported} by -reference: -If, after creating eval, the program changes the bindings of -@var{local} or @var{imported}, those changes will be visible -in eval. -Since most Scheme evaluation takes place in eval environments, -they transparently cache the bindings received from @var{local} -and @var{imported}. Thus, the first time the program looks up -a symbol in eval, eval may make calls to @var{local} or -@var{imported} to find their bindings, but subsequent -references to that symbol will be as fast as references to -bindings in finite environments. -In typical use, @var{local} will be a finite environment, and -@var{imported} will be an import environment -@end deffn - -@deffn {Scheme Procedure} eval-environment? object -@deffnx {C Function} scm_eval_environment_p (object) -Return @code{#t} if object is an eval environment, or @code{#f} -otherwise. -@end deffn - -@deffn {Scheme Procedure} eval-environment-local env -@deffnx {C Function} scm_eval_environment_local (env) -Return the local environment of eval environment @var{env}. -@end deffn - -@deffn {Scheme Procedure} eval-environment-set-local! env local -@deffnx {C Function} scm_eval_environment_set_local_x (env, local) -Change @var{env}'s local environment to @var{local}. -@end deffn - -@deffn {Scheme Procedure} eval-environment-imported env -@deffnx {C Function} scm_eval_environment_imported (env) -Return the imported environment of eval environment @var{env}. -@end deffn - -@deffn {Scheme Procedure} eval-environment-set-imported! env imported -@deffnx {C Function} scm_eval_environment_set_imported_x (env, imported) -Change @var{env}'s imported environment to @var{imported}. -@end deffn - -@deffn {Scheme Procedure} make-import-environment imports conflict_proc -@deffnx {C Function} scm_make_import_environment (imports, conflict_proc) -Return a new environment @var{imp} whose bindings are the union -of the bindings from the environments in @var{imports}; -@var{imports} must be a list of environments. That is, -@var{imp} binds a symbol to a location when some element of -@var{imports} does. -If two different elements of @var{imports} have a binding for -the same symbol, the @var{conflict-proc} is called with the -following parameters: the import environment, the symbol and -the list of the imported environments that bind the symbol. -If the @var{conflict-proc} returns an environment @var{env}, -the conflict is considered as resolved and the binding from -@var{env} is used. If the @var{conflict-proc} returns some -non-environment object, the conflict is considered unresolved -and the symbol is treated as unspecified in the import -environment. -The checking for conflicts may be performed lazily, i. e. at -the moment when a value or binding for a certain symbol is -requested instead of the moment when the environment is -created or the bindings of the imports change. -All bindings in @var{imp} are immutable. If you apply -@code{environment-define} or @code{environment-undefine} to -@var{imp}, Guile will signal an - @code{environment:immutable-binding} error. However, -notice that the set of bindings in @var{imp} may still change, -if one of its imported environments changes. -@end deffn - -@deffn {Scheme Procedure} import-environment? object -@deffnx {C Function} scm_import_environment_p (object) -Return @code{#t} if object is an import environment, or -@code{#f} otherwise. -@end deffn - -@deffn {Scheme Procedure} import-environment-imports env -@deffnx {C Function} scm_import_environment_imports (env) -Return the list of environments imported by the import -environment @var{env}. -@end deffn - -@deffn {Scheme Procedure} import-environment-set-imports! env imports -@deffnx {C Function} scm_import_environment_set_imports_x (env, imports) -Change @var{env}'s list of imported environments to -@var{imports}, and check for conflicts. -@end deffn - -@deffn {Scheme Procedure} make-export-environment private signature -@deffnx {C Function} scm_make_export_environment (private, signature) -Return a new environment @var{exp} containing only those -bindings in private whose symbols are present in -@var{signature}. The @var{private} argument must be an -environment. - -The environment @var{exp} binds symbol to location when -@var{env} does, and symbol is exported by @var{signature}. - -@var{signature} is a list specifying which of the bindings in -@var{private} should be visible in @var{exp}. Each element of -@var{signature} should be a list of the form: - (symbol attribute ...) -where each attribute is one of the following: -@table @asis -@item the symbol @code{mutable-location} - @var{exp} should treat the - location bound to symbol as mutable. That is, @var{exp} - will pass calls to @code{environment-set!} or - @code{environment-cell} directly through to private. -@item the symbol @code{immutable-location} - @var{exp} should treat - the location bound to symbol as immutable. If the program - applies @code{environment-set!} to @var{exp} and symbol, or - calls @code{environment-cell} to obtain a writable value - cell, @code{environment-set!} will signal an - @code{environment:immutable-location} error. Note that, even - if an export environment treats a location as immutable, the - underlying environment may treat it as mutable, so its - value may change. -@end table -It is an error for an element of signature to specify both -@code{mutable-location} and @code{immutable-location}. If -neither is specified, @code{immutable-location} is assumed. - -As a special case, if an element of signature is a lone -symbol @var{sym}, it is equivalent to an element of the form -@code{(sym)}. - -All bindings in @var{exp} are immutable. If you apply -@code{environment-define} or @code{environment-undefine} to -@var{exp}, Guile will signal an -@code{environment:immutable-binding} error. However, -notice that the set of bindings in @var{exp} may still change, -if the bindings in private change. -@end deffn - -@deffn {Scheme Procedure} export-environment? object -@deffnx {C Function} scm_export_environment_p (object) -Return @code{#t} if object is an export environment, or -@code{#f} otherwise. -@end deffn - -@deffn {Scheme Procedure} export-environment-private env -@deffnx {C Function} scm_export_environment_private (env) -Return the private environment of export environment @var{env}. -@end deffn - -@deffn {Scheme Procedure} export-environment-set-private! env private -@deffnx {C Function} scm_export_environment_set_private_x (env, private) -Change the private environment of export environment @var{env}. -@end deffn - -@deffn {Scheme Procedure} export-environment-signature env -@deffnx {C Function} scm_export_environment_signature (env) -Return the signature of export environment @var{env}. -@end deffn - -@deffn {Scheme Procedure} export-environment-set-signature! env signature -@deffnx {C Function} scm_export_environment_set_signature_x (env, signature) -Change the signature of export environment @var{env}. -@end deffn - -@deffn {Scheme Procedure} %compute-slots class -@deffnx {C Function} scm_sys_compute_slots (class) -Return a list consisting of the names of all slots belonging to -class @var{class}, i. e. the slots of @var{class} and of all of -its superclasses. -@end deffn - -@deffn {Scheme Procedure} get-keyword key l default_value -@deffnx {C Function} scm_get_keyword (key, l, default_value) -Determine an associated value for the keyword @var{key} from -the list @var{l}. The list @var{l} has to consist of an even -number of elements, where, starting with the first, every -second element is a keyword, followed by its associated value. -If @var{l} does not hold a value for @var{key}, the value -@var{default_value} is returned. -@end deffn - -@deffn {Scheme Procedure} slot-ref-using-class class obj slot_name -@deffnx {C Function} scm_slot_ref_using_class (class, obj, slot_name) - -@end deffn - -@deffn {Scheme Procedure} slot-set-using-class! class obj slot_name value -@deffnx {C Function} scm_slot_set_using_class_x (class, obj, slot_name, value) - -@end deffn - -@deffn {Scheme Procedure} class-of x -@deffnx {C Function} scm_class_of (x) -Return the class of @var{x}. -@end deffn - -@deffn {Scheme Procedure} %goops-loaded -@deffnx {C Function} scm_sys_goops_loaded () -Announce that GOOPS is loaded and perform initialization -on the C level which depends on the loaded GOOPS modules. -@end deffn - -@deffn {Scheme Procedure} %method-more-specific? m1 m2 targs -@deffnx {C Function} scm_sys_method_more_specific_p (m1, m2, targs) - -@end deffn - -@deffn {Scheme Procedure} find-method . l -@deffnx {C Function} scm_find_method (l) - -@end deffn - -@deffn {Scheme Procedure} primitive-generic-generic subr -@deffnx {C Function} scm_primitive_generic_generic (subr) - -@end deffn - -@deffn {Scheme Procedure} enable-primitive-generic! . subrs -@deffnx {C Function} scm_enable_primitive_generic_x (subrs) - -@end deffn - -@deffn {Scheme Procedure} generic-capability? proc -@deffnx {C Function} scm_generic_capability_p (proc) - -@end deffn - -@deffn {Scheme Procedure} %invalidate-method-cache! gf -@deffnx {C Function} scm_sys_invalidate_method_cache_x (gf) - -@end deffn - -@deffn {Scheme Procedure} %invalidate-class class -@deffnx {C Function} scm_sys_invalidate_class (class) - -@end deffn - -@deffn {Scheme Procedure} %modify-class old new -@deffnx {C Function} scm_sys_modify_class (old, new) - -@end deffn - -@deffn {Scheme Procedure} %modify-instance old new -@deffnx {C Function} scm_sys_modify_instance (old, new) - -@end deffn - -@deffn {Scheme Procedure} %set-object-setter! obj setter -@deffnx {C Function} scm_sys_set_object_setter_x (obj, setter) - -@end deffn - -@deffn {Scheme Procedure} %allocate-instance class initargs -@deffnx {C Function} scm_sys_allocate_instance (class, initargs) -Create a new instance of class @var{class} and initialize it -from the arguments @var{initargs}. -@end deffn - -@deffn {Scheme Procedure} slot-exists? obj slot_name -@deffnx {C Function} scm_slot_exists_p (obj, slot_name) -Return @code{#t} if @var{obj} has a slot named @var{slot_name}. -@end deffn - -@deffn {Scheme Procedure} slot-bound? obj slot_name -@deffnx {C Function} scm_slot_bound_p (obj, slot_name) -Return @code{#t} if the slot named @var{slot_name} of @var{obj} -is bound. -@end deffn - -@deffn {Scheme Procedure} slot-set! obj slot_name value -@deffnx {C Function} scm_slot_set_x (obj, slot_name, value) -Set the slot named @var{slot_name} of @var{obj} to @var{value}. -@end deffn - -@deffn {Scheme Procedure} slot-exists-using-class? class obj slot_name -@deffnx {C Function} scm_slot_exists_using_class_p (class, obj, slot_name) - -@end deffn - -@deffn {Scheme Procedure} slot-bound-using-class? class obj slot_name -@deffnx {C Function} scm_slot_bound_using_class_p (class, obj, slot_name) - -@end deffn - -@deffn {Scheme Procedure} %fast-slot-set! obj index value -@deffnx {C Function} scm_sys_fast_slot_set_x (obj, index, value) -Set the slot with index @var{index} in @var{obj} to -@var{value}. -@end deffn - -@deffn {Scheme Procedure} %fast-slot-ref obj index -@deffnx {C Function} scm_sys_fast_slot_ref (obj, index) -Return the slot value with index @var{index} from @var{obj}. -@end deffn - -@deffn {Scheme Procedure} @@assert-bound-ref obj index -@deffnx {C Function} scm_at_assert_bound_ref (obj, index) -Like @code{assert-bound}, but use @var{index} for accessing -the value from @var{obj}. -@end deffn - -@deffn {Scheme Procedure} assert-bound value obj -@deffnx {C Function} scm_assert_bound (value, obj) -Return @var{value} if it is bound, and invoke the -@var{slot-unbound} method of @var{obj} if it is not. -@end deffn - -@deffn {Scheme Procedure} unbound? obj -@deffnx {C Function} scm_unbound_p (obj) -Return @code{#t} if @var{obj} is unbound. -@end deffn - -@deffn {Scheme Procedure} make-unbound -@deffnx {C Function} scm_make_unbound () -Return the unbound value. -@end deffn - -@deffn {Scheme Procedure} accessor-method-slot-definition obj -@deffnx {C Function} scm_accessor_method_slot_definition (obj) -Return the slot definition of the accessor @var{obj}. -@end deffn - -@deffn {Scheme Procedure} method-procedure obj -@deffnx {C Function} scm_method_procedure (obj) -Return the procedure of the method @var{obj}. -@end deffn - -@deffn {Scheme Procedure} method-specializers obj -@deffnx {C Function} scm_method_specializers (obj) -Return specializers of the method @var{obj}. -@end deffn - -@deffn {Scheme Procedure} method-generic-function obj -@deffnx {C Function} scm_method_generic_function (obj) -Return the generic function for the method @var{obj}. -@end deffn - -@deffn {Scheme Procedure} generic-function-methods obj -@deffnx {C Function} scm_generic_function_methods (obj) -Return the methods of the generic function @var{obj}. -@end deffn - -@deffn {Scheme Procedure} generic-function-name obj -@deffnx {C Function} scm_generic_function_name (obj) -Return the name of the generic function @var{obj}. -@end deffn - -@deffn {Scheme Procedure} class-environment obj -@deffnx {C Function} scm_class_environment (obj) -Return the environment of the class @var{obj}. -@end deffn - -@deffn {Scheme Procedure} class-slots obj -@deffnx {C Function} scm_class_slots (obj) -Return the slot list of the class @var{obj}. -@end deffn - -@deffn {Scheme Procedure} class-precedence-list obj -@deffnx {C Function} scm_class_precedence_list (obj) -Return the class precedence list of the class @var{obj}. -@end deffn - -@deffn {Scheme Procedure} class-direct-methods obj -@deffnx {C Function} scm_class_direct_methods (obj) -Return the direct methods of the class @var{obj} -@end deffn - -@deffn {Scheme Procedure} class-direct-subclasses obj -@deffnx {C Function} scm_class_direct_subclasses (obj) -Return the direct subclasses of the class @var{obj}. -@end deffn - -@deffn {Scheme Procedure} class-direct-slots obj -@deffnx {C Function} scm_class_direct_slots (obj) -Return the direct slots of the class @var{obj}. -@end deffn - -@deffn {Scheme Procedure} class-direct-supers obj -@deffnx {C Function} scm_class_direct_supers (obj) -Return the direct superclasses of the class @var{obj}. -@end deffn - -@deffn {Scheme Procedure} class-name obj -@deffnx {C Function} scm_class_name (obj) -Return the class name of @var{obj}. -@end deffn - -@deffn {Scheme Procedure} instance? obj -@deffnx {C Function} scm_instance_p (obj) -Return @code{#t} if @var{obj} is an instance. -@end deffn - -@deffn {Scheme Procedure} %inherit-magic! class dsupers -@deffnx {C Function} scm_sys_inherit_magic_x (class, dsupers) - -@end deffn - -@deffn {Scheme Procedure} %prep-layout! class -@deffnx {C Function} scm_sys_prep_layout_x (class) - -@end deffn - -@deffn {Scheme Procedure} %initialize-object obj initargs -@deffnx {C Function} scm_sys_initialize_object (obj, initargs) -Initialize the object @var{obj} with the given arguments -@var{initargs}. -@end deffn - -@deffn {Scheme Procedure} make . args -@deffnx {C Function} scm_make (args) -Make a new object. @var{args} must contain the class and -all necessary initialization information. -@end deffn - -@deffn {Scheme Procedure} slot-ref obj slot_name -@deffnx {C Function} scm_slot_ref (obj, slot_name) -Return the value from @var{obj}'s slot with the name -@var{slot_name}. -@end deffn - -@deffn {Scheme Procedure} %tag-body body -@deffnx {C Function} scm_sys_tag_body (body) -Internal GOOPS magic---don't use this function! -@end deffn - -@deffn {Scheme Procedure} list* -implemented by the C function "scm_cons_star" -@end deffn - -@deffn {Scheme Procedure} set-current-module module -@deffnx {C Function} scm_set_current_module (module) -Set the current module to @var{module} and return -the previous current module. -@end deffn - -@deffn {Scheme Procedure} current-module -@deffnx {C Function} scm_current_module () -Return the current module. -@end deffn - -@deffn {Scheme Procedure} c-clear-registered-modules -Destroy the list of modules registered with the current Guile process. -The return value is unspecified. @strong{Warning:} this function does -not actually unlink or deallocate these modules, but only destroys the -records of which modules have been loaded. It should therefore be used -only by module bookkeeping operations. -@end deffn - -@deffn {Scheme Procedure} c-registered-modules -Return a list of the object code modules that have been imported into -the current Guile process. Each element of the list is a pair whose -car is the name of the module, and whose cdr is the function handle -for that module's initializer function. The name is the string that -has been passed to scm_register_module_xxx. -@end deffn - -@deffn {Scheme Procedure} include-deprecated-features -Return @code{#t} iff deprecated features should be included -in public interfaces. -@end deffn - -@deffn {Scheme Procedure} issue-deprecation-warning . msgs -Output @var{msgs} to @code{(current-error-port)} when this -is the first call to @code{issue-deprecation-warning} with -this specific @var{msg}. Do nothing otherwise. -The argument @var{msgs} should be a list of strings; -they are printed in turn, each one followed by a newline. -@end deffn - -@deffn {Scheme Procedure} valid-object-procedure? proc -@deffnx {C Function} scm_valid_object_procedure_p (proc) -Return @code{#t} iff @var{proc} is a procedure that can be used with @code{set-object-procedure}. It is always valid to use a closure constructed by @code{lambda}. -@end deffn - -@deffn {Scheme Procedure} %get-pre-modules-obarray -@deffnx {C Function} scm_get_pre_modules_obarray () -Return the obarray that is used for all new bindings before the module system is booted. The first call to @code{set-current-module} will boot the module system. -@end deffn - -@deffn {Scheme Procedure} standard-interface-eval-closure module -@deffnx {C Function} scm_standard_interface_eval_closure (module) -Return a interface eval closure for the module @var{module}. Such a closure does not allow new bindings to be added. -@end deffn - -@deffn {Scheme Procedure} env-module env -@deffnx {C Function} scm_env_module (env) -Return the module of @var{ENV}, a lexical environment. -@end deffn - -@deffn {Scheme Procedure} load-extension lib init -@deffnx {C Function} scm_load_extension (lib, init) -Load and initialize the extension designated by LIB and INIT. -When there is no pre-registered function for LIB/INIT, this is -equivalent to - -@lisp -(dynamic-call INIT (dynamic-link LIB)) -@end lisp - -When there is a pre-registered function, that function is called -instead. - -Normally, there is no pre-registered function. This option exists -only for situations where dynamic linking is unavailable or unwanted. -In that case, you would statically link your program with the desired -library, and register its init function right after Guile has been -initialized. - -LIB should be a string denoting a shared library without any file type -suffix such as ".so". The suffix is provided automatically. It -should also not contain any directory components. Libraries that -implement Guile Extensions should be put into the normal locations for -shared libraries. We recommend to use the naming convention -libguile-bla-blum for a extension related to a module `(bla blum)'. - -The normal way for a extension to be used is to write a small Scheme -file that defines a module, and to load the extension into this -module. When the module is auto-loaded, the extension is loaded as -well. For example, - -@lisp -(define-module (bla blum)) - -(load-extension "libguile-bla-blum" "bla_init_blum") -@end lisp -@end deffn - -@deffn {Scheme Procedure} single-active-thread? -implemented by the C function "scm_single_thread_p" -@end deffn - -@deffn {Scheme Procedure} object-address obj -@deffnx {C Function} scm_object_address (obj) -Return an integer that for the lifetime of @var{obj} is uniquely -returned by this function for @var{obj} -@end deffn - -@deffn {Scheme Procedure} nan -@deffnx {C Function} scm_nan () -Return NaN. -@end deffn - -@deffn {Scheme Procedure} inf -@deffnx {C Function} scm_inf () -Return Inf. -@end deffn - -@deffn {Scheme Procedure} set-debug-cell-accesses! flag -@deffnx {C Function} scm_set_debug_cell_accesses_x (flag) -This function is used to turn on checking for a debug version of GUILE. This version does not support this functionality - -@end deffn - -@deffn {Scheme Procedure} all-threads -implemented by the C function "scm_all_threads" -@end deffn - -@deffn {Scheme Procedure} current-thread -implemented by the C function "scm_current_thread" -@end deffn - -@deffn {Scheme Procedure} standard-eval-closure module -@deffnx {C Function} scm_standard_eval_closure (module) -Return an eval closure for the module @var{module}. -@end deffn - -@deffn {Scheme Procedure} mask-signals -@deffnx {C Function} scm_mask_signals () -Mask signals. The returned value is not specified. -@end deffn - -@deffn {Scheme Procedure} unmask-signals -@deffnx {C Function} scm_unmask_signals () -Unmask signals. The returned value is not specified. -@end deffn - -@deffn {Scheme Procedure} noop . args -@deffnx {C Function} scm_noop (args) -Do nothing. When called without arguments, return @code{#f}, -otherwise return the first argument. -@end deffn - -@deffn {Scheme Procedure} system-async thunk -@deffnx {C Function} scm_system_async (thunk) -This function is deprecated. You can use @var{thunk} directly -instead of explicitely creating an async object. - -@end deffn From 0d2bfbad6ecf113eae1db284fedcdd50280f3ae8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 16:43:07 +0000 Subject: [PATCH 054/100] Copied from libguile/guile.texi. --- doc/maint/guile.texi | 1508 ++++++++++++++++++++++++++++++++++++------ 1 file changed, 1293 insertions(+), 215 deletions(-) diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi index 725084d90..3e7c68edb 100644 --- a/doc/maint/guile.texi +++ b/doc/maint/guile.texi @@ -1,5 +1,6 @@ acons +@c snarfed from alist.c:35 @deffn {Scheme Procedure} acons key value alist @deffnx {C Function} scm_acons (key, value, alist) Add a new key-value pair to @var{alist}. A new pair is @@ -9,6 +10,7 @@ function is @emph{not} destructive; @var{alist} is not modified. @end deffn sloppy-assq +@c snarfed from alist.c:49 @deffn {Scheme Procedure} sloppy-assq key alist @deffnx {C Function} scm_sloppy_assq (key, alist) Behaves like @code{assq} but does not do any error checking. @@ -16,6 +18,7 @@ Recommended only for use in Guile internals. @end deffn sloppy-assv +@c snarfed from alist.c:67 @deffn {Scheme Procedure} sloppy-assv key alist @deffnx {C Function} scm_sloppy_assv (key, alist) Behaves like @code{assv} but does not do any error checking. @@ -23,6 +26,7 @@ Recommended only for use in Guile internals. @end deffn sloppy-assoc +@c snarfed from alist.c:85 @deffn {Scheme Procedure} sloppy-assoc key alist @deffnx {C Function} scm_sloppy_assoc (key, alist) Behaves like @code{assoc} but does not do any error checking. @@ -30,6 +34,7 @@ Recommended only for use in Guile internals. @end deffn assq +@c snarfed from alist.c:112 @deffn {Scheme Procedure} assq key alist @deffnx {Scheme Procedure} assv key alist @deffnx {Scheme Procedure} assoc key alist @@ -44,18 +49,21 @@ return the entire alist entry found (i.e. both the key and the value). @end deffn assv +@c snarfed from alist.c:133 @deffn {Scheme Procedure} assv key alist @deffnx {C Function} scm_assv (key, alist) Behaves like @code{assq} but uses @code{eqv?} for key comparison. @end deffn assoc +@c snarfed from alist.c:154 @deffn {Scheme Procedure} assoc key alist @deffnx {C Function} scm_assoc (key, alist) Behaves like @code{assq} but uses @code{equal?} for key comparison. @end deffn assq-ref +@c snarfed from alist.c:198 @deffn {Scheme Procedure} assq-ref alist key @deffnx {Scheme Procedure} assv-ref alist key @deffnx {Scheme Procedure} assoc-ref alist key @@ -73,18 +81,21 @@ where @var{associator} is one of @code{assq}, @code{assv} or @code{assoc}. @end deffn assv-ref +@c snarfed from alist.c:215 @deffn {Scheme Procedure} assv-ref alist key @deffnx {C Function} scm_assv_ref (alist, key) Behaves like @code{assq-ref} but uses @code{eqv?} for key comparison. @end deffn assoc-ref +@c snarfed from alist.c:232 @deffn {Scheme Procedure} assoc-ref alist key @deffnx {C Function} scm_assoc_ref (alist, key) Behaves like @code{assq-ref} but uses @code{equal?} for key comparison. @end deffn assq-set! +@c snarfed from alist.c:261 @deffn {Scheme Procedure} assq-set! alist key val @deffnx {Scheme Procedure} assv-set! alist key value @deffnx {Scheme Procedure} assoc-set! alist key value @@ -100,18 +111,21 @@ association list. @end deffn assv-set! +@c snarfed from alist.c:279 @deffn {Scheme Procedure} assv-set! alist key val @deffnx {C Function} scm_assv_set_x (alist, key, val) Behaves like @code{assq-set!} but uses @code{eqv?} for key comparison. @end deffn assoc-set! +@c snarfed from alist.c:297 @deffn {Scheme Procedure} assoc-set! alist key val @deffnx {C Function} scm_assoc_set_x (alist, key, val) Behaves like @code{assq-set!} but uses @code{equal?} for key comparison. @end deffn assq-remove! +@c snarfed from alist.c:321 @deffn {Scheme Procedure} assq-remove! alist key @deffnx {Scheme Procedure} assv-remove! alist key @deffnx {Scheme Procedure} assoc-remove! alist key @@ -121,93 +135,95 @@ the resulting alist. @end deffn assv-remove! +@c snarfed from alist.c:337 @deffn {Scheme Procedure} assv-remove! alist key @deffnx {C Function} scm_assv_remove_x (alist, key) Behaves like @code{assq-remove!} but uses @code{eqv?} for key comparison. @end deffn assoc-remove! +@c snarfed from alist.c:353 @deffn {Scheme Procedure} assoc-remove! alist key @deffnx {C Function} scm_assoc_remove_x (alist, key) Behaves like @code{assq-remove!} but uses @code{equal?} for key comparison. @end deffn make-arbiter +@c snarfed from arbiters.c:99 @deffn {Scheme Procedure} make-arbiter name @deffnx {C Function} scm_make_arbiter (name) -Return an object of type arbiter and name @var{name}. Its -state is initially unlocked. Arbiters are a way to achieve -process synchronization. +Return an arbiter object, initially unlocked. Currently +@var{name} is only used for diagnostic output. @end deffn try-arbiter +@c snarfed from arbiters.c:116 @deffn {Scheme Procedure} try-arbiter arb @deffnx {C Function} scm_try_arbiter (arb) -Return @code{#t} and lock the arbiter @var{arb} if the arbiter -was unlocked. Otherwise, return @code{#f}. +If @var{arb} is unlocked, then lock it and return @code{#t}. +If @var{arb} is already locked, then do nothing and return +@code{#f}. @end deffn release-arbiter +@c snarfed from arbiters.c:142 @deffn {Scheme Procedure} release-arbiter arb @deffnx {C Function} scm_release_arbiter (arb) -Return @code{#t} and unlock the arbiter @var{arb} if the -arbiter was locked. Otherwise, return @code{#f}. +If @var{arb} is locked, then unlock it and return @code{#t}. +If @var{arb} is already unlocked, then do nothing and return +@code{#f}. + +Typical usage is for the thread which locked an arbiter to +later release it, but that's not required, any thread can +release it. @end deffn async +@c snarfed from async.c:97 @deffn {Scheme Procedure} async thunk @deffnx {C Function} scm_async (thunk) Create a new async for the procedure @var{thunk}. @end deffn async-mark +@c snarfed from async.c:106 @deffn {Scheme Procedure} async-mark a @deffnx {C Function} scm_async_mark (a) Mark the async @var{a} for future execution. @end deffn run-asyncs +@c snarfed from async.c:117 @deffn {Scheme Procedure} run-asyncs list_of_a @deffnx {C Function} scm_run_asyncs (list_of_a) Execute all thunks from the asyncs of the list @var{list_of_a}. @end deffn - system-async -@deffn {Scheme Procedure} system-async thunk -@deffnx {C Function} scm_system_async (thunk) -This function is deprecated. You can use @var{thunk} directly -instead of explicitely creating an async object. - -@end deffn - system-async-mark +@c snarfed from async.c:222 @deffn {Scheme Procedure} system-async-mark proc [thread] @deffnx {C Function} scm_system_async_mark_for_thread (proc, thread) -Register the procedure @var{proc} for future execution -in @var{thread}. When @var{thread} is not specified, -use the current thread. +Mark @var{proc} (a procedure with zero arguments) for future execution +in @var{thread}. If @var{proc} has already been marked for +@var{thread} but has not been executed yet, this call has no effect. +If @var{thread} is omitted, the thread that called +@code{system-async-mark} is used. + +This procedure is not safe to be called from C signal handlers. Use +@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install +signal handlers. @end deffn noop +@c snarfed from async.c:253 @deffn {Scheme Procedure} noop . args @deffnx {C Function} scm_noop (args) Do nothing. When called without arguments, return @code{#f}, otherwise return the first argument. @end deffn - unmask-signals -@deffn {Scheme Procedure} unmask-signals -@deffnx {C Function} scm_unmask_signals () -Unmask signals. The returned value is not specified. -@end deffn - - mask-signals -@deffn {Scheme Procedure} mask-signals -@deffnx {C Function} scm_mask_signals () -Mask signals. The returned value is not specified. -@end deffn - call-with-blocked-asyncs +@c snarfed from async.c:319 @deffn {Scheme Procedure} call-with-blocked-asyncs proc @deffnx {C Function} scm_call_with_blocked_asyncs (proc) Call @var{proc} with no arguments and block the execution @@ -217,6 +233,7 @@ it is running. Return the value returned by @var{proc}. @end deffn call-with-unblocked-asyncs +@c snarfed from async.c:343 @deffn {Scheme Procedure} call-with-unblocked-asyncs proc @deffnx {C Function} scm_call_with_unblocked_asyncs (proc) Call @var{proc} with no arguments and unblock the execution @@ -226,6 +243,7 @@ it is running. Return the value returned by @var{proc}. @end deffn display-error +@c snarfed from backtrace.c:303 @deffn {Scheme Procedure} display-error stack port subr message args rest @deffnx {C Function} scm_display_error (stack, port, subr, message, args, rest) Display an error message to the output port @var{port}. @@ -238,6 +256,7 @@ ignored. @end deffn display-application +@c snarfed from backtrace.c:446 @deffn {Scheme Procedure} display-application frame [port [indent]] @deffnx {C Function} scm_display_application (frame, port, indent) Display a procedure application @var{frame} to the output port @@ -246,6 +265,7 @@ output. @end deffn display-backtrace +@c snarfed from backtrace.c:756 @deffn {Scheme Procedure} display-backtrace stack port [first [depth]] @deffnx {C Function} scm_display_backtrace (stack, port, first, depth) Display a backtrace to the output port @var{port}. @var{stack} @@ -256,6 +276,7 @@ which means that default values will be used. @end deffn backtrace +@c snarfed from backtrace.c:779 @deffn {Scheme Procedure} backtrace @deffnx {C Function} scm_backtrace () Display a backtrace of the stack saved by the last error @@ -263,83 +284,97 @@ to the current output port. @end deffn not +@c snarfed from boolean.c:33 @deffn {Scheme Procedure} not x @deffnx {C Function} scm_not (x) Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}. @end deffn boolean? +@c snarfed from boolean.c:43 @deffn {Scheme Procedure} boolean? obj @deffnx {C Function} scm_boolean_p (obj) Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}. @end deffn char? +@c snarfed from chars.c:31 @deffn {Scheme Procedure} char? x @deffnx {C Function} scm_char_p (x) Return @code{#t} iff @var{x} is a character, else @code{#f}. @end deffn char=? +@c snarfed from chars.c:40 @deffn {Scheme Procedure} char=? x y Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}. @end deffn char? +@c snarfed from chars.c:77 @deffn {Scheme Procedure} char>? x y Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII sequence, else @code{#f}. @end deffn char>=? +@c snarfed from chars.c:89 @deffn {Scheme Procedure} char>=? x y Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the ASCII sequence, else @code{#f}. @end deffn char-ci=? +@c snarfed from chars.c:101 @deffn {Scheme Procedure} char-ci=? x y Return @code{#t} iff @var{x} is the same character as @var{y} ignoring case, else @code{#f}. @end deffn char-ci? +@c snarfed from chars.c:137 @deffn {Scheme Procedure} char-ci>? x y Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII sequence ignoring case, else @code{#f}. @end deffn char-ci>=? +@c snarfed from chars.c:149 @deffn {Scheme Procedure} char-ci>=? x y Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the ASCII sequence ignoring case, else @code{#f}. @end deffn char-alphabetic? +@c snarfed from chars.c:162 @deffn {Scheme Procedure} char-alphabetic? chr @deffnx {C Function} scm_char_alphabetic_p (chr) Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}. @@ -347,6 +382,7 @@ Alphabetic means the same thing as the isalpha C library function. @end deffn char-numeric? +@c snarfed from chars.c:173 @deffn {Scheme Procedure} char-numeric? chr @deffnx {C Function} scm_char_numeric_p (chr) Return @code{#t} iff @var{chr} is numeric, else @code{#f}. @@ -354,6 +390,7 @@ Numeric means the same thing as the isdigit C library function. @end deffn char-whitespace? +@c snarfed from chars.c:184 @deffn {Scheme Procedure} char-whitespace? chr @deffnx {C Function} scm_char_whitespace_p (chr) Return @code{#t} iff @var{chr} is whitespace, else @code{#f}. @@ -361,6 +398,7 @@ Whitespace means the same thing as the isspace C library function. @end deffn char-upper-case? +@c snarfed from chars.c:197 @deffn {Scheme Procedure} char-upper-case? chr @deffnx {C Function} scm_char_upper_case_p (chr) Return @code{#t} iff @var{chr} is uppercase, else @code{#f}. @@ -368,6 +406,7 @@ Uppercase means the same thing as the isupper C library function. @end deffn char-lower-case? +@c snarfed from chars.c:209 @deffn {Scheme Procedure} char-lower-case? chr @deffnx {C Function} scm_char_lower_case_p (chr) Return @code{#t} iff @var{chr} is lowercase, else @code{#f}. @@ -375,6 +414,7 @@ Lowercase means the same thing as the islower C library function. @end deffn char-is-both? +@c snarfed from chars.c:223 @deffn {Scheme Procedure} char-is-both? chr @deffnx {C Function} scm_char_is_both_p (chr) Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}. @@ -383,6 +423,7 @@ C library functions. @end deffn char->integer +@c snarfed from chars.c:237 @deffn {Scheme Procedure} char->integer chr @deffnx {C Function} scm_char_to_integer (chr) Return the number corresponding to ordinal position of @var{chr} in the @@ -390,24 +431,28 @@ ASCII sequence. @end deffn integer->char +@c snarfed from chars.c:249 @deffn {Scheme Procedure} integer->char n @deffnx {C Function} scm_integer_to_char (n) Return the character at position @var{n} in the ASCII sequence. @end deffn char-upcase +@c snarfed from chars.c:259 @deffn {Scheme Procedure} char-upcase chr @deffnx {C Function} scm_char_upcase (chr) Return the uppercase character version of @var{chr}. @end deffn char-downcase +@c snarfed from chars.c:270 @deffn {Scheme Procedure} char-downcase chr @deffnx {C Function} scm_char_downcase (chr) Return the lowercase character version of @var{chr}. @end deffn debug-options-interface +@c snarfed from debug.c:53 @deffn {Scheme Procedure} debug-options-interface [setting] @deffnx {C Function} scm_debug_options (setting) Option interface for the debug options. Instead of using @@ -416,48 +461,56 @@ this procedure directly, use the procedures @code{debug-enable}, @end deffn with-traps +@c snarfed from debug.c:96 @deffn {Scheme Procedure} with-traps thunk @deffnx {C Function} scm_with_traps (thunk) Call @var{thunk} with traps enabled. @end deffn memoized? +@c snarfed from debug.c:134 @deffn {Scheme Procedure} memoized? obj @deffnx {C Function} scm_memoized_p (obj) Return @code{#t} if @var{obj} is memoized. @end deffn - unmemoize -@deffn {Scheme Procedure} unmemoize m -@deffnx {C Function} scm_unmemoize (m) + unmemoize-expr +@c snarfed from debug.c:271 +@deffn {Scheme Procedure} unmemoize-expr m +@deffnx {C Function} scm_i_unmemoize_expr (m) Unmemoize the memoized expression @var{m}, @end deffn memoized-environment +@c snarfed from debug.c:281 @deffn {Scheme Procedure} memoized-environment m @deffnx {C Function} scm_memoized_environment (m) Return the environment of the memoized expression @var{m}. @end deffn procedure-name +@c snarfed from debug.c:291 @deffn {Scheme Procedure} procedure-name proc @deffnx {C Function} scm_procedure_name (proc) Return the name of the procedure @var{proc} @end deffn procedure-source +@c snarfed from debug.c:317 @deffn {Scheme Procedure} procedure-source proc @deffnx {C Function} scm_procedure_source (proc) Return the source of the procedure @var{proc}. @end deffn procedure-environment +@c snarfed from debug.c:374 @deffn {Scheme Procedure} procedure-environment proc @deffnx {C Function} scm_procedure_environment (proc) Return the environment of the procedure @var{proc}. @end deffn local-eval +@c snarfed from debug.c:406 @deffn {Scheme Procedure} local-eval exp [env] @deffnx {C Function} scm_local_eval (exp, env) Evaluate @var{exp} in its environment. If @var{env} is supplied, @@ -467,12 +520,21 @@ is implicit). @end deffn debug-object? +@c snarfed from debug.c:493 @deffn {Scheme Procedure} debug-object? obj @deffnx {C Function} scm_debug_object_p (obj) Return @code{#t} if @var{obj} is a debug object. @end deffn + include-deprecated-features +@c snarfed from deprecation.c:144 +@deffn {Scheme Procedure} include-deprecated-features +@deffnx {C Function} scm_include_deprecated_features () +Return @code{#t} iff deprecated features should be included in public interfaces. +@end deffn + dynamic-link +@c snarfed from dynl.c:149 @deffn {Scheme Procedure} dynamic-link filename @deffnx {C Function} scm_dynamic_link (filename) Find the shared object (shared library) denoted by @@ -488,6 +550,7 @@ such as @file{/usr/lib} and @file{/usr/local/lib}. @end deffn dynamic-object? +@c snarfed from dynl.c:168 @deffn {Scheme Procedure} dynamic-object? obj @deffnx {C Function} scm_dynamic_object_p (obj) Return @code{#t} if @var{obj} is a dynamic object handle, @@ -495,6 +558,7 @@ or @code{#f} otherwise. @end deffn dynamic-unlink +@c snarfed from dynl.c:182 @deffn {Scheme Procedure} dynamic-unlink dobj @deffnx {C Function} scm_dynamic_unlink (dobj) Unlink a dynamic object from the application, if possible. The @@ -505,6 +569,7 @@ object. @end deffn dynamic-func +@c snarfed from dynl.c:207 @deffn {Scheme Procedure} dynamic-func name dobj @deffnx {C Function} scm_dynamic_func (name, dobj) Return a ``handle'' for the function @var{name} in the @@ -519,6 +584,7 @@ since it will be added automatically when necessary. @end deffn dynamic-call +@c snarfed from dynl.c:253 @deffn {Scheme Procedure} dynamic-call func dobj @deffnx {C Function} scm_dynamic_call (func, dobj) Call a C function in a dynamic object. Two styles of @@ -543,6 +609,7 @@ and its return value is ignored. @end deffn dynamic-args-call +@c snarfed from dynl.c:285 @deffn {Scheme Procedure} dynamic-args-call func dobj args @deffnx {C Function} scm_dynamic_args_call (func, dobj, args) Call the C function indicated by @var{func} and @var{dobj}, @@ -561,6 +628,7 @@ converted to a Scheme number and returned from the call to @end deffn dynamic-wind +@c snarfed from dynwind.c:97 @deffn {Scheme Procedure} dynamic-wind in_guard thunk out_guard @deffnx {C Function} scm_dynamic_wind (in_guard, thunk, out_guard) All three arguments must be 0-argument procedures. @@ -614,6 +682,7 @@ a-cont @end deffn environment? +@c snarfed from environments.c:106 @deffn {Scheme Procedure} environment? obj @deffnx {C Function} scm_environment_p (obj) Return @code{#t} if @var{obj} is an environment, or @code{#f} @@ -621,6 +690,7 @@ otherwise. @end deffn environment-bound? +@c snarfed from environments.c:117 @deffn {Scheme Procedure} environment-bound? env sym @deffnx {C Function} scm_environment_bound_p (env, sym) Return @code{#t} if @var{sym} is bound in @var{env}, or @@ -628,6 +698,7 @@ Return @code{#t} if @var{sym} is bound in @var{env}, or @end deffn environment-ref +@c snarfed from environments.c:132 @deffn {Scheme Procedure} environment-ref env sym @deffnx {C Function} scm_environment_ref (env, sym) Return the value of the location bound to @var{sym} in @@ -636,6 +707,7 @@ Return the value of the location bound to @var{sym} in @end deffn environment-fold +@c snarfed from environments.c:202 @deffn {Scheme Procedure} environment-fold env proc init @deffnx {C Function} scm_environment_fold (env, proc, init) Iterate over all the bindings in @var{env}, accumulating some @@ -672,6 +744,7 @@ using environment-fold: @end deffn environment-define +@c snarfed from environments.c:237 @deffn {Scheme Procedure} environment-define env sym val @deffnx {C Function} scm_environment_define (env, sym, val) Bind @var{sym} to a new location containing @var{val} in @@ -684,6 +757,7 @@ immutable, signal an @code{environment:immutable-binding} error. @end deffn environment-undefine +@c snarfed from environments.c:263 @deffn {Scheme Procedure} environment-undefine env sym @deffnx {C Function} scm_environment_undefine (env, sym) Remove any binding for @var{sym} from @var{env}. If @var{sym} @@ -694,6 +768,7 @@ immutable, signal an @code{environment:immutable-binding} error. @end deffn environment-set! +@c snarfed from environments.c:291 @deffn {Scheme Procedure} environment-set! env sym val @deffnx {C Function} scm_environment_set_x (env, sym, val) If @var{env} binds @var{sym} to some location, change that @@ -706,6 +781,7 @@ to an immutable location, signal an @end deffn environment-cell +@c snarfed from environments.c:326 @deffn {Scheme Procedure} environment-cell env sym for_write @deffnx {C Function} scm_environment_cell (env, sym, for_write) Return the value cell which @var{env} binds to @var{sym}, or @@ -723,6 +799,7 @@ re-bound to a new value cell, or becomes undefined. @end deffn environment-observe +@c snarfed from environments.c:378 @deffn {Scheme Procedure} environment-observe env proc @deffnx {C Function} scm_environment_observe (env, proc) Whenever @var{env}'s bindings change, apply @var{proc} to @@ -734,6 +811,7 @@ token is unspecified. @end deffn environment-observe-weak +@c snarfed from environments.c:395 @deffn {Scheme Procedure} environment-observe-weak env proc @deffnx {C Function} scm_environment_observe_weak (env, proc) This function is the same as environment-observe, except that @@ -745,6 +823,7 @@ list of observing procedures. @end deffn environment-unobserve +@c snarfed from environments.c:431 @deffn {Scheme Procedure} environment-unobserve token @deffnx {C Function} scm_environment_unobserve (token) Cancel the observation request which returned the value @@ -756,6 +835,7 @@ bindings change. @end deffn make-leaf-environment +@c snarfed from environments.c:1015 @deffn {Scheme Procedure} make-leaf-environment @deffnx {C Function} scm_make_leaf_environment () Create a new leaf environment, containing no bindings. @@ -764,6 +844,7 @@ will be mutable. @end deffn leaf-environment? +@c snarfed from environments.c:1038 @deffn {Scheme Procedure} leaf-environment? object @deffnx {C Function} scm_leaf_environment_p (object) Return @code{#t} if object is a leaf environment, or @code{#f} @@ -771,6 +852,7 @@ otherwise. @end deffn make-eval-environment +@c snarfed from environments.c:1403 @deffn {Scheme Procedure} make-eval-environment local imported @deffnx {C Function} scm_make_eval_environment (local, imported) Return a new environment object eval whose bindings are the @@ -797,6 +879,7 @@ In typical use, @var{local} will be a finite environment, and @end deffn eval-environment? +@c snarfed from environments.c:1440 @deffn {Scheme Procedure} eval-environment? object @deffnx {C Function} scm_eval_environment_p (object) Return @code{#t} if object is an eval environment, or @code{#f} @@ -804,30 +887,35 @@ otherwise. @end deffn eval-environment-local +@c snarfed from environments.c:1450 @deffn {Scheme Procedure} eval-environment-local env @deffnx {C Function} scm_eval_environment_local (env) Return the local environment of eval environment @var{env}. @end deffn eval-environment-set-local! +@c snarfed from environments.c:1462 @deffn {Scheme Procedure} eval-environment-set-local! env local @deffnx {C Function} scm_eval_environment_set_local_x (env, local) Change @var{env}'s local environment to @var{local}. @end deffn eval-environment-imported +@c snarfed from environments.c:1488 @deffn {Scheme Procedure} eval-environment-imported env @deffnx {C Function} scm_eval_environment_imported (env) Return the imported environment of eval environment @var{env}. @end deffn eval-environment-set-imported! +@c snarfed from environments.c:1500 @deffn {Scheme Procedure} eval-environment-set-imported! env imported @deffnx {C Function} scm_eval_environment_set_imported_x (env, imported) Change @var{env}'s imported environment to @var{imported}. @end deffn make-import-environment +@c snarfed from environments.c:1823 @deffn {Scheme Procedure} make-import-environment imports conflict_proc @deffnx {C Function} scm_make_import_environment (imports, conflict_proc) Return a new environment @var{imp} whose bindings are the union @@ -858,6 +946,7 @@ if one of its imported environments changes. @end deffn import-environment? +@c snarfed from environments.c:1852 @deffn {Scheme Procedure} import-environment? object @deffnx {C Function} scm_import_environment_p (object) Return @code{#t} if object is an import environment, or @@ -865,6 +954,7 @@ Return @code{#t} if object is an import environment, or @end deffn import-environment-imports +@c snarfed from environments.c:1863 @deffn {Scheme Procedure} import-environment-imports env @deffnx {C Function} scm_import_environment_imports (env) Return the list of environments imported by the import @@ -872,6 +962,7 @@ environment @var{env}. @end deffn import-environment-set-imports! +@c snarfed from environments.c:1876 @deffn {Scheme Procedure} import-environment-set-imports! env imports @deffnx {C Function} scm_import_environment_set_imports_x (env, imports) Change @var{env}'s list of imported environments to @@ -879,6 +970,7 @@ Change @var{env}'s list of imported environments to @end deffn make-export-environment +@c snarfed from environments.c:2143 @deffn {Scheme Procedure} make-export-environment private signature @deffnx {C Function} scm_make_export_environment (private, signature) Return a new environment @var{exp} containing only those @@ -928,6 +1020,7 @@ if the bindings in private change. @end deffn export-environment? +@c snarfed from environments.c:2178 @deffn {Scheme Procedure} export-environment? object @deffnx {C Function} scm_export_environment_p (object) Return @code{#t} if object is an export environment, or @@ -935,30 +1028,35 @@ Return @code{#t} if object is an export environment, or @end deffn export-environment-private +@c snarfed from environments.c:2188 @deffn {Scheme Procedure} export-environment-private env @deffnx {C Function} scm_export_environment_private (env) Return the private environment of export environment @var{env}. @end deffn export-environment-set-private! +@c snarfed from environments.c:2200 @deffn {Scheme Procedure} export-environment-set-private! env private @deffnx {C Function} scm_export_environment_set_private_x (env, private) Change the private environment of export environment @var{env}. @end deffn export-environment-signature +@c snarfed from environments.c:2222 @deffn {Scheme Procedure} export-environment-signature env @deffnx {C Function} scm_export_environment_signature (env) Return the signature of export environment @var{env}. @end deffn export-environment-set-signature! +@c snarfed from environments.c:2296 @deffn {Scheme Procedure} export-environment-set-signature! env signature @deffnx {C Function} scm_export_environment_set_signature_x (env, signature) Change the signature of export environment @var{env}. @end deffn eq? +@c snarfed from eq.c:47 @deffn {Scheme Procedure} eq? x y Return @code{#t} iff @var{x} references the same object as @var{y}. @code{eq?} is similar to @code{eqv?} except that in some cases it is @@ -967,6 +1065,7 @@ capable of discerning distinctions finer than those detectable by @end deffn eqv? +@c snarfed from eq.c:71 @deffn {Scheme Procedure} eqv? x y The @code{eqv?} procedure defines a useful equivalence relation on objects. Briefly, it returns @code{#t} if @var{x} and @var{y} should normally be @@ -976,6 +1075,7 @@ and inexact numbers. @end deffn equal? +@c snarfed from eq.c:138 @deffn {Scheme Procedure} equal? x y Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent. @code{equal?} recursively compares the contents of pairs, @@ -986,6 +1086,7 @@ terminate if its arguments are circular data structures. @end deffn scm-error +@c snarfed from error.c:81 @deffn {Scheme Procedure} scm-error key subr message args data @deffnx {C Function} scm_error_scm (key, subr, message, args, data) Raise an error with key @var{key}. @var{subr} can be a string @@ -1004,6 +1105,7 @@ it will usually be @code{#f}. @end deffn strerror +@c snarfed from error.c:128 @deffn {Scheme Procedure} strerror err @deffnx {C Function} scm_strerror (err) Return the Unix error message corresponding to @var{err}, which @@ -1011,6 +1113,7 @@ must be an integer value. @end deffn apply:nconc2last +@c snarfed from eval.c:4697 @deffn {Scheme Procedure} apply:nconc2last lst @deffnx {C Function} scm_nconc2last (lst) Given a list (@var{arg1} @dots{} @var{args}), this function @@ -1023,14 +1126,16 @@ destroys its argument, so use with care. @end deffn force -@deffn {Scheme Procedure} force x -@deffnx {C Function} scm_force (x) +@c snarfed from eval.c:5625 +@deffn {Scheme Procedure} force promise +@deffnx {C Function} scm_force (promise) If the promise @var{x} has not been computed yet, compute and return @var{x}, otherwise just return the previously computed value. @end deffn promise? +@c snarfed from eval.c:5648 @deffn {Scheme Procedure} promise? obj @deffnx {C Function} scm_promise_p (obj) Return true if @var{obj} is a promise, i.e. a delayed computation @@ -1038,6 +1143,7 @@ Return true if @var{obj} is a promise, i.e. a delayed computation @end deffn cons-source +@c snarfed from eval.c:5660 @deffn {Scheme Procedure} cons-source xorig x y @deffnx {C Function} scm_cons_source (xorig, x, y) Create and return a new pair whose car and cdr are @var{x} and @var{y}. @@ -1046,16 +1152,18 @@ with the new pair. @end deffn copy-tree +@c snarfed from eval.c:5817 @deffn {Scheme Procedure} copy-tree obj @deffnx {C Function} scm_copy_tree (obj) Recursively copy the data tree that is bound to @var{obj}, and return a -pointer to the new data structure. @code{copy-tree} recurses down the +the new data structure. @code{copy-tree} recurses down the contents of both pairs and vectors (since both cons cells and vector cells may point to arbitrary objects), and stops recursing when it hits any other object. @end deffn primitive-eval +@c snarfed from eval.c:5903 @deffn {Scheme Procedure} primitive-eval exp @deffnx {C Function} scm_primitive_eval (exp) Evaluate @var{exp} in the top-level environment specified by @@ -1063,6 +1171,7 @@ the current module. @end deffn eval +@c snarfed from eval.c:5972 @deffn {Scheme Procedure} eval exp module @deffnx {C Function} scm_eval (exp, module) Evaluate @var{exp}, a list representing a Scheme expression, @@ -1073,6 +1182,7 @@ is reset to its previous value when @var{eval} returns. @end deffn eval-options-interface +@c snarfed from eval.c:3087 @deffn {Scheme Procedure} eval-options-interface [setting] @deffnx {C Function} scm_eval_options_interface (setting) Option interface for the evaluation options. Instead of using @@ -1081,23 +1191,34 @@ this procedure directly, use the procedures @code{eval-enable}, @end deffn evaluator-traps-interface +@c snarfed from eval.c:3105 @deffn {Scheme Procedure} evaluator-traps-interface [setting] @deffnx {C Function} scm_evaluator_traps (setting) Option interface for the evaluator trap options. @end deffn defined? +@c snarfed from evalext.c:34 @deffn {Scheme Procedure} defined? sym [env] @deffnx {C Function} scm_defined_p (sym, env) Return @code{#t} if @var{sym} is defined in the lexical environment @var{env}. When @var{env} is not specified, look in the top-level environment as defined by the current module. @end deffn map-in-order +@c snarfed from evalext.c:80 @deffn {Scheme Procedure} map-in-order implemented by the C function "scm_map" @end deffn + self-evaluating? +@c snarfed from evalext.c:85 +@deffn {Scheme Procedure} self-evaluating? obj +@deffnx {C Function} scm_self_evaluating_p (obj) +Return #t for objects which Guile considers self-evaluating +@end deffn + load-extension +@c snarfed from extensions.c:143 @deffn {Scheme Procedure} load-extension lib init @deffnx {C Function} scm_load_extension (lib, init) Load and initialize the extension designated by LIB and INIT. @@ -1137,6 +1258,7 @@ well. For example, @end deffn program-arguments +@c snarfed from feature.c:56 @deffn {Scheme Procedure} program-arguments @deffnx {Scheme Procedure} command-line @deffnx {C Function} scm_program_arguments () @@ -1147,6 +1269,7 @@ options like @code{-e} and @code{-l}. @end deffn make-fluid +@c snarfed from fluids.c:100 @deffn {Scheme Procedure} make-fluid @deffnx {C Function} scm_make_fluid () Return a newly created fluid. @@ -1159,6 +1282,7 @@ in its own dynamic root, you can use fluids for thread local storage. @end deffn fluid? +@c snarfed from fluids.c:113 @deffn {Scheme Procedure} fluid? obj @deffnx {C Function} scm_fluid_p (obj) Return @code{#t} iff @var{obj} is a fluid; otherwise, return @@ -1166,6 +1290,7 @@ Return @code{#t} iff @var{obj} is a fluid; otherwise, return @end deffn fluid-ref +@c snarfed from fluids.c:124 @deffn {Scheme Procedure} fluid-ref fluid @deffnx {C Function} scm_fluid_ref (fluid) Return the value associated with @var{fluid} in the current @@ -1174,12 +1299,14 @@ dynamic root. If @var{fluid} has not been set, then return @end deffn fluid-set! +@c snarfed from fluids.c:140 @deffn {Scheme Procedure} fluid-set! fluid value @deffnx {C Function} scm_fluid_set_x (fluid, value) Set the value associated with @var{fluid} in the current dynamic root. @end deffn with-fluids* +@c snarfed from fluids.c:206 @deffn {Scheme Procedure} with-fluids* fluids values thunk @deffnx {C Function} scm_with_fluids (fluids, values, thunk) Set @var{fluids} to @var{values} temporary, and call @var{thunk}. @@ -1188,7 +1315,16 @@ number of their values to be applied. Each substitution is done one after another. @var{thunk} must be a procedure with no argument. @end deffn + with-fluid* +@c snarfed from fluids.c:245 +@deffn {Scheme Procedure} with-fluid* fluid value thunk +@deffnx {C Function} scm_with_fluid (fluid, value, thunk) +Set @var{fluid} to @var{value} temporarily, and call @var{thunk}. +@var{thunk} must be a procedure with no argument. +@end deffn + setvbuf +@c snarfed from fports.c:137 @deffn {Scheme Procedure} setvbuf port mode [size] @deffnx {C Function} scm_setvbuf (port, mode, size) Set the buffering mode for @var{port}. @var{mode} can be: @@ -1204,12 +1340,14 @@ If @var{size} is omitted, a default size will be used. @end deffn file-port? +@c snarfed from fports.c:230 @deffn {Scheme Procedure} file-port? obj @deffnx {C Function} scm_file_port_p (obj) Determine whether @var{obj} is a port that is related to a file. @end deffn open-file +@c snarfed from fports.c:284 @deffn {Scheme Procedure} open-file filename mode @deffnx {C Function} scm_open_file (filename, mode) Open the file whose name is @var{filename}, and return a port @@ -1251,14 +1389,24 @@ current interfaces. If a file cannot be opened with the access requested, @code{open-file} throws an exception. @end deffn - set-debug-cell-accesses! -@deffn {Scheme Procedure} set-debug-cell-accesses! flag -@deffnx {C Function} scm_set_debug_cell_accesses_x (flag) -This function is used to turn on checking for a debug version of GUILE. This version does not support this functionality + make-future +@c snarfed from futures.c:89 +@deffn {Scheme Procedure} make-future thunk +@deffnx {C Function} scm_make_future (thunk) +Make a future evaluating THUNK. +@end deffn + future-ref +@c snarfed from futures.c:221 +@deffn {Scheme Procedure} future-ref future +@deffnx {C Function} scm_future_ref (future) +If the future @var{x} has not been computed yet, compute and +return @var{x}, otherwise just return the previously computed +value. @end deffn gc-stats +@c snarfed from gc.c:283 @deffn {Scheme Procedure} gc-stats @deffnx {C Function} scm_gc_stats () Return an association list of statistics about Guile's current @@ -1267,6 +1415,7 @@ use of storage. @end deffn object-address +@c snarfed from gc.c:419 @deffn {Scheme Procedure} object-address obj @deffnx {C Function} scm_object_address (obj) Return an integer that for the lifetime of @var{obj} is uniquely @@ -1274,6 +1423,7 @@ returned by this function for @var{obj} @end deffn gc +@c snarfed from gc.c:430 @deffn {Scheme Procedure} gc @deffnx {C Function} scm_gc () Scans all of SCM objects and reclaims for further use those that are @@ -1281,6 +1431,7 @@ no longer accessible. @end deffn %compute-slots +@c snarfed from goops.c:265 @deffn {Scheme Procedure} %compute-slots class @deffnx {C Function} scm_sys_compute_slots (class) Return a list consisting of the names of all slots belonging to @@ -1289,6 +1440,7 @@ its superclasses. @end deffn get-keyword +@c snarfed from goops.c:356 @deffn {Scheme Procedure} get-keyword key l default_value @deffnx {C Function} scm_get_keyword (key, l, default_value) Determine an associated value for the keyword @var{key} from @@ -1300,6 +1452,7 @@ If @var{l} does not hold a value for @var{key}, the value @end deffn %initialize-object +@c snarfed from goops.c:379 @deffn {Scheme Procedure} %initialize-object obj initargs @deffnx {C Function} scm_sys_initialize_object (obj, initargs) Initialize the object @var{obj} with the given arguments @@ -1307,126 +1460,147 @@ Initialize the object @var{obj} with the given arguments @end deffn %prep-layout! +@c snarfed from goops.c:477 @deffn {Scheme Procedure} %prep-layout! class @deffnx {C Function} scm_sys_prep_layout_x (class) @end deffn %inherit-magic! +@c snarfed from goops.c:576 @deffn {Scheme Procedure} %inherit-magic! class dsupers @deffnx {C Function} scm_sys_inherit_magic_x (class, dsupers) @end deffn instance? +@c snarfed from goops.c:816 @deffn {Scheme Procedure} instance? obj @deffnx {C Function} scm_instance_p (obj) Return @code{#t} if @var{obj} is an instance. @end deffn class-name +@c snarfed from goops.c:831 @deffn {Scheme Procedure} class-name obj @deffnx {C Function} scm_class_name (obj) Return the class name of @var{obj}. @end deffn class-direct-supers +@c snarfed from goops.c:841 @deffn {Scheme Procedure} class-direct-supers obj @deffnx {C Function} scm_class_direct_supers (obj) Return the direct superclasses of the class @var{obj}. @end deffn class-direct-slots +@c snarfed from goops.c:851 @deffn {Scheme Procedure} class-direct-slots obj @deffnx {C Function} scm_class_direct_slots (obj) Return the direct slots of the class @var{obj}. @end deffn class-direct-subclasses +@c snarfed from goops.c:861 @deffn {Scheme Procedure} class-direct-subclasses obj @deffnx {C Function} scm_class_direct_subclasses (obj) Return the direct subclasses of the class @var{obj}. @end deffn class-direct-methods +@c snarfed from goops.c:871 @deffn {Scheme Procedure} class-direct-methods obj @deffnx {C Function} scm_class_direct_methods (obj) Return the direct methods of the class @var{obj} @end deffn class-precedence-list +@c snarfed from goops.c:881 @deffn {Scheme Procedure} class-precedence-list obj @deffnx {C Function} scm_class_precedence_list (obj) Return the class precedence list of the class @var{obj}. @end deffn class-slots +@c snarfed from goops.c:891 @deffn {Scheme Procedure} class-slots obj @deffnx {C Function} scm_class_slots (obj) Return the slot list of the class @var{obj}. @end deffn class-environment +@c snarfed from goops.c:901 @deffn {Scheme Procedure} class-environment obj @deffnx {C Function} scm_class_environment (obj) Return the environment of the class @var{obj}. @end deffn generic-function-name +@c snarfed from goops.c:912 @deffn {Scheme Procedure} generic-function-name obj @deffnx {C Function} scm_generic_function_name (obj) Return the name of the generic function @var{obj}. @end deffn generic-function-methods +@c snarfed from goops.c:957 @deffn {Scheme Procedure} generic-function-methods obj @deffnx {C Function} scm_generic_function_methods (obj) Return the methods of the generic function @var{obj}. @end deffn method-generic-function +@c snarfed from goops.c:970 @deffn {Scheme Procedure} method-generic-function obj @deffnx {C Function} scm_method_generic_function (obj) Return the generic function for the method @var{obj}. @end deffn method-specializers +@c snarfed from goops.c:980 @deffn {Scheme Procedure} method-specializers obj @deffnx {C Function} scm_method_specializers (obj) Return specializers of the method @var{obj}. @end deffn method-procedure +@c snarfed from goops.c:990 @deffn {Scheme Procedure} method-procedure obj @deffnx {C Function} scm_method_procedure (obj) Return the procedure of the method @var{obj}. @end deffn accessor-method-slot-definition +@c snarfed from goops.c:1000 @deffn {Scheme Procedure} accessor-method-slot-definition obj @deffnx {C Function} scm_accessor_method_slot_definition (obj) Return the slot definition of the accessor @var{obj}. @end deffn %tag-body +@c snarfed from goops.c:1010 @deffn {Scheme Procedure} %tag-body body @deffnx {C Function} scm_sys_tag_body (body) Internal GOOPS magic---don't use this function! @end deffn make-unbound +@c snarfed from goops.c:1025 @deffn {Scheme Procedure} make-unbound @deffnx {C Function} scm_make_unbound () Return the unbound value. @end deffn unbound? +@c snarfed from goops.c:1034 @deffn {Scheme Procedure} unbound? obj @deffnx {C Function} scm_unbound_p (obj) Return @code{#t} if @var{obj} is unbound. @end deffn assert-bound +@c snarfed from goops.c:1044 @deffn {Scheme Procedure} assert-bound value obj @deffnx {C Function} scm_assert_bound (value, obj) Return @var{value} if it is bound, and invoke the @@ -1434,6 +1608,7 @@ Return @var{value} if it is bound, and invoke the @end deffn @@assert-bound-ref +@c snarfed from goops.c:1056 @deffn {Scheme Procedure} @@assert-bound-ref obj index @deffnx {C Function} scm_at_assert_bound_ref (obj, index) Like @code{assert-bound}, but use @var{index} for accessing @@ -1441,12 +1616,14 @@ the value from @var{obj}. @end deffn %fast-slot-ref +@c snarfed from goops.c:1068 @deffn {Scheme Procedure} %fast-slot-ref obj index @deffnx {C Function} scm_sys_fast_slot_ref (obj, index) Return the slot value with index @var{index} from @var{obj}. @end deffn %fast-slot-set! +@c snarfed from goops.c:1082 @deffn {Scheme Procedure} %fast-slot-set! obj index value @deffnx {C Function} scm_sys_fast_slot_set_x (obj, index, value) Set the slot with index @var{index} in @var{obj} to @@ -1454,30 +1631,35 @@ Set the slot with index @var{index} in @var{obj} to @end deffn slot-ref-using-class +@c snarfed from goops.c:1219 @deffn {Scheme Procedure} slot-ref-using-class class obj slot_name @deffnx {C Function} scm_slot_ref_using_class (class, obj, slot_name) @end deffn slot-set-using-class! +@c snarfed from goops.c:1238 @deffn {Scheme Procedure} slot-set-using-class! class obj slot_name value @deffnx {C Function} scm_slot_set_using_class_x (class, obj, slot_name, value) @end deffn slot-bound-using-class? +@c snarfed from goops.c:1252 @deffn {Scheme Procedure} slot-bound-using-class? class obj slot_name @deffnx {C Function} scm_slot_bound_using_class_p (class, obj, slot_name) @end deffn slot-exists-using-class? +@c snarfed from goops.c:1267 @deffn {Scheme Procedure} slot-exists-using-class? class obj slot_name @deffnx {C Function} scm_slot_exists_using_class_p (class, obj, slot_name) @end deffn slot-ref +@c snarfed from goops.c:1283 @deffn {Scheme Procedure} slot-ref obj slot_name @deffnx {C Function} scm_slot_ref (obj, slot_name) Return the value from @var{obj}'s slot with the name @@ -1485,12 +1667,14 @@ Return the value from @var{obj}'s slot with the name @end deffn slot-set! +@c snarfed from goops.c:1300 @deffn {Scheme Procedure} slot-set! obj slot_name value @deffnx {C Function} scm_slot_set_x (obj, slot_name, value) Set the slot named @var{slot_name} of @var{obj} to @var{value}. @end deffn slot-bound? +@c snarfed from goops.c:1317 @deffn {Scheme Procedure} slot-bound? obj slot_name @deffnx {C Function} scm_slot_bound_p (obj, slot_name) Return @code{#t} if the slot named @var{slot_name} of @var{obj} @@ -1498,12 +1682,14 @@ is bound. @end deffn slot-exists? +@c snarfed from goops.c:1335 @deffn {Scheme Procedure} slot-exists? obj slot_name @deffnx {C Function} scm_slot_exists_p (obj, slot_name) Return @code{#t} if @var{obj} has a slot named @var{slot_name}. @end deffn %allocate-instance +@c snarfed from goops.c:1374 @deffn {Scheme Procedure} %allocate-instance class initargs @deffnx {C Function} scm_sys_allocate_instance (class, initargs) Create a new instance of class @var{class} and initialize it @@ -1511,54 +1697,63 @@ from the arguments @var{initargs}. @end deffn %set-object-setter! +@c snarfed from goops.c:1444 @deffn {Scheme Procedure} %set-object-setter! obj setter @deffnx {C Function} scm_sys_set_object_setter_x (obj, setter) @end deffn %modify-instance +@c snarfed from goops.c:1469 @deffn {Scheme Procedure} %modify-instance old new @deffnx {C Function} scm_sys_modify_instance (old, new) @end deffn %modify-class +@c snarfed from goops.c:1495 @deffn {Scheme Procedure} %modify-class old new @deffnx {C Function} scm_sys_modify_class (old, new) @end deffn %invalidate-class +@c snarfed from goops.c:1519 @deffn {Scheme Procedure} %invalidate-class class @deffnx {C Function} scm_sys_invalidate_class (class) @end deffn %invalidate-method-cache! +@c snarfed from goops.c:1641 @deffn {Scheme Procedure} %invalidate-method-cache! gf @deffnx {C Function} scm_sys_invalidate_method_cache_x (gf) @end deffn generic-capability? +@c snarfed from goops.c:1667 @deffn {Scheme Procedure} generic-capability? proc @deffnx {C Function} scm_generic_capability_p (proc) @end deffn enable-primitive-generic! +@c snarfed from goops.c:1680 @deffn {Scheme Procedure} enable-primitive-generic! . subrs @deffnx {C Function} scm_enable_primitive_generic_x (subrs) @end deffn primitive-generic-generic +@c snarfed from goops.c:1701 @deffn {Scheme Procedure} primitive-generic-generic subr @deffnx {C Function} scm_primitive_generic_generic (subr) @end deffn make +@c snarfed from goops.c:2069 @deffn {Scheme Procedure} make . args @deffnx {C Function} scm_make (args) Make a new object. @var{args} must contain the class and @@ -1566,18 +1761,21 @@ all necessary initialization information. @end deffn find-method +@c snarfed from goops.c:2158 @deffn {Scheme Procedure} find-method . l @deffnx {C Function} scm_find_method (l) @end deffn %method-more-specific? +@c snarfed from goops.c:2178 @deffn {Scheme Procedure} %method-more-specific? m1 m2 targs @deffnx {C Function} scm_sys_method_more_specific_p (m1, m2, targs) @end deffn %goops-loaded +@c snarfed from goops.c:2793 @deffn {Scheme Procedure} %goops-loaded @deffnx {C Function} scm_sys_goops_loaded () Announce that GOOPS is loaded and perform initialization @@ -1585,6 +1783,7 @@ on the C level which depends on the loaded GOOPS modules. @end deffn make-guardian +@c snarfed from guardians.c:306 @deffn {Scheme Procedure} make-guardian [greedy_p] @deffnx {C Function} scm_make_guardian (greedy_p) Create a new guardian. @@ -1615,18 +1814,21 @@ paper still (mostly) accurately describes the interface). @end deffn guardian-destroyed? +@c snarfed from guardians.c:334 @deffn {Scheme Procedure} guardian-destroyed? guardian @deffnx {C Function} scm_guardian_destroyed_p (guardian) Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}. @end deffn guardian-greedy? +@c snarfed from guardians.c:352 @deffn {Scheme Procedure} guardian-greedy? guardian @deffnx {C Function} scm_guardian_greedy_p (guardian) Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}. @end deffn destroy-guardian! +@c snarfed from guardians.c:363 @deffn {Scheme Procedure} destroy-guardian! guardian @deffnx {C Function} scm_destroy_guardian_x (guardian) Destroys @var{guardian}, by making it impossible to put any more @@ -1635,6 +1837,7 @@ objects guarded by @var{guardian}. @end deffn hashq +@c snarfed from hash.c:176 @deffn {Scheme Procedure} hashq key size @deffnx {C Function} scm_hashq (key, size) Determine a hash value for @var{key} that is suitable for @@ -1650,6 +1853,7 @@ different values, since @code{foo} will be garbage collected. @end deffn hashv +@c snarfed from hash.c:212 @deffn {Scheme Procedure} hashv key size @deffnx {C Function} scm_hashv (key, size) Determine a hash value for @var{key} that is suitable for @@ -1665,6 +1869,7 @@ different values, since @code{foo} will be garbage collected. @end deffn hash +@c snarfed from hash.c:235 @deffn {Scheme Procedure} hash key size @deffnx {C Function} scm_hash (key, size) Determine a hash value for @var{key} that is suitable for @@ -1673,7 +1878,85 @@ is used as the equality predicate. The function returns an integer in the range 0 to @var{size} - 1. @end deffn + make-hash-table +@c snarfed from hashtab.c:309 +@deffn {Scheme Procedure} make-hash-table [n] +@deffnx {C Function} scm_make_hash_table (n) +Make a hash table with optional minimum number of buckets @var{n} + +@end deffn + + make-weak-key-hash-table +@c snarfed from hashtab.c:328 +@deffn {Scheme Procedure} make-weak-key-hash-table [n] +@deffnx {Scheme Procedure} make-weak-value-hash-table size +@deffnx {Scheme Procedure} make-doubly-weak-hash-table size +@deffnx {C Function} scm_make_weak_key_hash_table (n) +Return a weak hash table with @var{size} buckets. As with any +hash table, choosing a good size for the table requires some +caution. + +You can modify weak hash tables in exactly the same way you +would modify regular hash tables. (@pxref{Hash Tables}) +@end deffn + + make-weak-value-hash-table +@c snarfed from hashtab.c:343 +@deffn {Scheme Procedure} make-weak-value-hash-table [n] +@deffnx {C Function} scm_make_weak_value_hash_table (n) +Return a hash table with weak values with @var{size} buckets. +(@pxref{Hash Tables}) +@end deffn + + make-doubly-weak-hash-table +@c snarfed from hashtab.c:360 +@deffn {Scheme Procedure} make-doubly-weak-hash-table n +@deffnx {C Function} scm_make_doubly_weak_hash_table (n) +Return a hash table with weak keys and values with @var{size} +buckets. (@pxref{Hash Tables}) +@end deffn + + hash-table? +@c snarfed from hashtab.c:379 +@deffn {Scheme Procedure} hash-table? obj +@deffnx {C Function} scm_hash_table_p (obj) +Return @code{#t} if @var{obj} is a hash table. +@end deffn + + weak-key-hash-table? +@c snarfed from hashtab.c:393 +@deffn {Scheme Procedure} weak-key-hash-table? obj +@deffnx {Scheme Procedure} weak-value-hash-table? obj +@deffnx {Scheme Procedure} doubly-weak-hash-table? obj +@deffnx {C Function} scm_weak_key_hash_table_p (obj) +Return @code{#t} if @var{obj} is the specified weak hash +table. Note that a doubly weak hash table is neither a weak key +nor a weak value hash table. +@end deffn + + weak-value-hash-table? +@c snarfed from hashtab.c:403 +@deffn {Scheme Procedure} weak-value-hash-table? obj +@deffnx {C Function} scm_weak_value_hash_table_p (obj) +Return @code{#t} if @var{obj} is a weak value hash table. +@end deffn + + doubly-weak-hash-table? +@c snarfed from hashtab.c:413 +@deffn {Scheme Procedure} doubly-weak-hash-table? obj +@deffnx {C Function} scm_doubly_weak_hash_table_p (obj) +Return @code{#t} if @var{obj} is a doubly weak hash table. +@end deffn + + hash-clear! +@c snarfed from hashtab.c:550 +@deffn {Scheme Procedure} hash-clear! table +@deffnx {C Function} scm_hash_clear_x (table) +Remove all items from TABLE (without triggering a resize). +@end deffn + hashq-get-handle +@c snarfed from hashtab.c:567 @deffn {Scheme Procedure} hashq-get-handle table key @deffnx {C Function} scm_hashq_get_handle (table, key) This procedure returns the @code{(key . value)} pair from the @@ -1683,6 +1966,7 @@ Uses @code{eq?} for equality testing. @end deffn hashq-create-handle! +@c snarfed from hashtab.c:579 @deffn {Scheme Procedure} hashq-create-handle! table key init @deffnx {C Function} scm_hashq_create_handle_x (table, key, init) This function looks up @var{key} in @var{table} and returns its handle. @@ -1691,6 +1975,7 @@ associates @var{key} with @var{init}. @end deffn hashq-ref +@c snarfed from hashtab.c:592 @deffn {Scheme Procedure} hashq-ref table key [dflt] @deffnx {C Function} scm_hashq_ref (table, key, dflt) Look up @var{key} in the hash table @var{table}, and return the @@ -1700,6 +1985,7 @@ is supplied). Uses @code{eq?} for equality testing. @end deffn hashq-set! +@c snarfed from hashtab.c:606 @deffn {Scheme Procedure} hashq-set! table key val @deffnx {C Function} scm_hashq_set_x (table, key, val) Find the entry in @var{table} associated with @var{key}, and @@ -1707,6 +1993,7 @@ store @var{value} there. Uses @code{eq?} for equality testing. @end deffn hashq-remove! +@c snarfed from hashtab.c:618 @deffn {Scheme Procedure} hashq-remove! table key @deffnx {C Function} scm_hashq_remove_x (table, key) Remove @var{key} (and any value associated with it) from @@ -1714,6 +2001,7 @@ Remove @var{key} (and any value associated with it) from @end deffn hashv-get-handle +@c snarfed from hashtab.c:634 @deffn {Scheme Procedure} hashv-get-handle table key @deffnx {C Function} scm_hashv_get_handle (table, key) This procedure returns the @code{(key . value)} pair from the @@ -1723,6 +2011,7 @@ Uses @code{eqv?} for equality testing. @end deffn hashv-create-handle! +@c snarfed from hashtab.c:646 @deffn {Scheme Procedure} hashv-create-handle! table key init @deffnx {C Function} scm_hashv_create_handle_x (table, key, init) This function looks up @var{key} in @var{table} and returns its handle. @@ -1731,6 +2020,7 @@ associates @var{key} with @var{init}. @end deffn hashv-ref +@c snarfed from hashtab.c:660 @deffn {Scheme Procedure} hashv-ref table key [dflt] @deffnx {C Function} scm_hashv_ref (table, key, dflt) Look up @var{key} in the hash table @var{table}, and return the @@ -1740,6 +2030,7 @@ is supplied). Uses @code{eqv?} for equality testing. @end deffn hashv-set! +@c snarfed from hashtab.c:674 @deffn {Scheme Procedure} hashv-set! table key val @deffnx {C Function} scm_hashv_set_x (table, key, val) Find the entry in @var{table} associated with @var{key}, and @@ -1747,6 +2038,7 @@ store @var{value} there. Uses @code{eqv?} for equality testing. @end deffn hashv-remove! +@c snarfed from hashtab.c:685 @deffn {Scheme Procedure} hashv-remove! table key @deffnx {C Function} scm_hashv_remove_x (table, key) Remove @var{key} (and any value associated with it) from @@ -1754,6 +2046,7 @@ Remove @var{key} (and any value associated with it) from @end deffn hash-get-handle +@c snarfed from hashtab.c:700 @deffn {Scheme Procedure} hash-get-handle table key @deffnx {C Function} scm_hash_get_handle (table, key) This procedure returns the @code{(key . value)} pair from the @@ -1763,6 +2056,7 @@ Uses @code{equal?} for equality testing. @end deffn hash-create-handle! +@c snarfed from hashtab.c:712 @deffn {Scheme Procedure} hash-create-handle! table key init @deffnx {C Function} scm_hash_create_handle_x (table, key, init) This function looks up @var{key} in @var{table} and returns its handle. @@ -1771,6 +2065,7 @@ associates @var{key} with @var{init}. @end deffn hash-ref +@c snarfed from hashtab.c:725 @deffn {Scheme Procedure} hash-ref table key [dflt] @deffnx {C Function} scm_hash_ref (table, key, dflt) Look up @var{key} in the hash table @var{table}, and return the @@ -1780,6 +2075,7 @@ is supplied). Uses @code{equal?} for equality testing. @end deffn hash-set! +@c snarfed from hashtab.c:740 @deffn {Scheme Procedure} hash-set! table key val @deffnx {C Function} scm_hash_set_x (table, key, val) Find the entry in @var{table} associated with @var{key}, and @@ -1788,6 +2084,7 @@ testing. @end deffn hash-remove! +@c snarfed from hashtab.c:752 @deffn {Scheme Procedure} hash-remove! table key @deffnx {C Function} scm_hash_remove_x (table, key) Remove @var{key} (and any value associated with it) from @@ -1795,6 +2092,7 @@ Remove @var{key} (and any value associated with it) from @end deffn hashx-get-handle +@c snarfed from hashtab.c:805 @deffn {Scheme Procedure} hashx-get-handle hash assoc table key @deffnx {C Function} scm_hashx_get_handle (hash, assoc, table, key) This behaves the same way as the corresponding @@ -1806,6 +2104,7 @@ table size. @code{assoc} must be an associator function, like @end deffn hashx-create-handle! +@c snarfed from hashtab.c:824 @deffn {Scheme Procedure} hashx-create-handle! hash assoc table key init @deffnx {C Function} scm_hashx_create_handle_x (hash, assoc, table, key, init) This behaves the same way as the corresponding @@ -1817,6 +2116,7 @@ table size. @code{assoc} must be an associator function, like @end deffn hashx-ref +@c snarfed from hashtab.c:847 @deffn {Scheme Procedure} hashx-ref hash assoc table key [dflt] @deffnx {C Function} scm_hashx_ref (hash, assoc, table, key, dflt) This behaves the same way as the corresponding @code{ref} @@ -1831,6 +2131,7 @@ equivalent to @code{hashx-ref hashq assq table key}. @end deffn hashx-set! +@c snarfed from hashtab.c:873 @deffn {Scheme Procedure} hashx-set! hash assoc table key val @deffnx {C Function} scm_hashx_set_x (hash, assoc, table, key, val) This behaves the same way as the corresponding @code{set!} @@ -1845,6 +2146,7 @@ equivalent to @code{hashx-set! hashq assq table key}. @end deffn hash-fold +@c snarfed from hashtab.c:975 @deffn {Scheme Procedure} hash-fold proc init table @deffnx {C Function} scm_hash_fold (proc, init, table) An iterator over hash-table elements. @@ -1857,7 +2159,36 @@ For example, @code{(hash-fold acons '() tab)} will convert a hash table into an a-list of key-value pairs. @end deffn + hash-for-each +@c snarfed from hashtab.c:996 +@deffn {Scheme Procedure} hash-for-each proc table +@deffnx {C Function} scm_hash_for_each (proc, table) +An iterator over hash-table elements. +Applies PROC successively on all hash table items. +The arguments to PROC are "(key value)" where key +and value are successive pairs from the hash table TABLE. +@end deffn + + hash-for-each-handle +@c snarfed from hashtab.c:1013 +@deffn {Scheme Procedure} hash-for-each-handle proc table +@deffnx {C Function} scm_hash_for_each_handle (proc, table) +An iterator over hash-table elements. +Applies PROC successively on all hash table handles. +@end deffn + + hash-map->list +@c snarfed from hashtab.c:1039 +@deffn {Scheme Procedure} hash-map->list proc table +@deffnx {C Function} scm_hash_map_to_list (proc, table) +An iterator over hash-table elements. +Accumulates and returns as a list the results of applying PROC successively. +The arguments to PROC are "(key value)" where key +and value are successive pairs from the hash table TABLE. +@end deffn + make-hook +@c snarfed from hooks.c:154 @deffn {Scheme Procedure} make-hook [n_args] @deffnx {C Function} scm_make_hook (n_args) Create a hook for storing procedure of arity @var{n_args}. @@ -1866,12 +2197,14 @@ object to be used with the other hook procedures. @end deffn hook? +@c snarfed from hooks.c:171 @deffn {Scheme Procedure} hook? x @deffnx {C Function} scm_hook_p (x) Return @code{#t} if @var{x} is a hook, @code{#f} otherwise. @end deffn hook-empty? +@c snarfed from hooks.c:182 @deffn {Scheme Procedure} hook-empty? hook @deffnx {C Function} scm_hook_empty_p (hook) Return @code{#t} if @var{hook} is an empty hook, @code{#f} @@ -1879,6 +2212,7 @@ otherwise. @end deffn add-hook! +@c snarfed from hooks.c:196 @deffn {Scheme Procedure} add-hook! hook proc [append_p] @deffnx {C Function} scm_add_hook_x (hook, proc, append_p) Add the procedure @var{proc} to the hook @var{hook}. The @@ -1888,6 +2222,7 @@ procedure is not specified. @end deffn remove-hook! +@c snarfed from hooks.c:223 @deffn {Scheme Procedure} remove-hook! hook proc @deffnx {C Function} scm_remove_hook_x (hook, proc) Remove the procedure @var{proc} from the hook @var{hook}. The @@ -1895,6 +2230,7 @@ return value of this procedure is not specified. @end deffn reset-hook! +@c snarfed from hooks.c:237 @deffn {Scheme Procedure} reset-hook! hook @deffnx {C Function} scm_reset_hook_x (hook) Remove all procedures from the hook @var{hook}. The return @@ -1902,6 +2238,7 @@ value of this procedure is not specified. @end deffn run-hook +@c snarfed from hooks.c:251 @deffn {Scheme Procedure} run-hook hook . args @deffnx {C Function} scm_run_hook (hook, args) Apply all procedures from the hook @var{hook} to the arguments @@ -1910,12 +2247,14 @@ last. The return value of this procedure is not specified. @end deffn hook->list +@c snarfed from hooks.c:278 @deffn {Scheme Procedure} hook->list hook @deffnx {C Function} scm_hook_to_list (hook) Convert the procedure list of @var{hook} to a list. @end deffn ftell +@c snarfed from ioext.c:54 @deffn {Scheme Procedure} ftell fd_port @deffnx {C Function} scm_ftell (fd_port) Return an integer representing the current position of @@ -1927,6 +2266,7 @@ Return an integer representing the current position of @end deffn redirect-port +@c snarfed from ioext.c:72 @deffn {Scheme Procedure} redirect-port old new @deffnx {C Function} scm_redirect_port (old, new) This procedure takes two ports and duplicates the underlying file @@ -1945,6 +2285,7 @@ revealed counts. @end deffn dup->fdes +@c snarfed from ioext.c:111 @deffn {Scheme Procedure} dup->fdes fd_or_port [fd] @deffnx {C Function} scm_dup_to_fdes (fd_or_port, fd) Return a new integer file descriptor referring to the open file @@ -1953,6 +2294,7 @@ file port or a file descriptor. @end deffn dup2 +@c snarfed from ioext.c:158 @deffn {Scheme Procedure} dup2 oldfd newfd @deffnx {C Function} scm_dup2 (oldfd, newfd) A simple wrapper for the @code{dup2} system call. @@ -1966,6 +2308,7 @@ The return value is unspecified. @end deffn fileno +@c snarfed from ioext.c:177 @deffn {Scheme Procedure} fileno port @deffnx {C Function} scm_fileno (port) Return the integer file descriptor underlying @var{port}. Does @@ -1973,6 +2316,7 @@ not change its revealed count. @end deffn isatty? +@c snarfed from ioext.c:197 @deffn {Scheme Procedure} isatty? port @deffnx {C Function} scm_isatty_p (port) Return @code{#t} if @var{port} is using a serial non--file @@ -1980,6 +2324,7 @@ device, otherwise @code{#f}. @end deffn fdopen +@c snarfed from ioext.c:219 @deffn {Scheme Procedure} fdopen fdes modes @deffnx {C Function} scm_fdopen (fdes, modes) Return a new port based on the file descriptor @var{fdes}. @@ -1989,6 +2334,7 @@ same as that accepted by @ref{File Ports, open-file}. @end deffn primitive-move->fdes +@c snarfed from ioext.c:241 @deffn {Scheme Procedure} primitive-move->fdes port fd @deffnx {C Function} scm_primitive_move_to_fdes (port, fd) Moves the underlying file descriptor for @var{port} to the integer @@ -2000,6 +2346,7 @@ required value or @code{#t} if it was moved. @end deffn fdes->ports +@c snarfed from ioext.c:274 @deffn {Scheme Procedure} fdes->ports fd @deffnx {C Function} scm_fdes_to_ports (fd) Return a list of existing ports which have @var{fdes} as an @@ -2008,12 +2355,14 @@ counts. @end deffn make-keyword-from-dash-symbol +@c snarfed from keywords.c:52 @deffn {Scheme Procedure} make-keyword-from-dash-symbol symbol @deffnx {C Function} scm_make_keyword_from_dash_symbol (symbol) Make a keyword object from a @var{symbol} that starts with a dash. @end deffn keyword? +@c snarfed from keywords.c:91 @deffn {Scheme Procedure} keyword? obj @deffnx {C Function} scm_keyword_p (obj) Return @code{#t} if the argument @var{obj} is a keyword, else @@ -2021,6 +2370,7 @@ Return @code{#t} if the argument @var{obj} is a keyword, else @end deffn keyword-dash-symbol +@c snarfed from keywords.c:102 @deffn {Scheme Procedure} keyword-dash-symbol keyword @deffnx {C Function} scm_keyword_dash_symbol (keyword) Return the dash symbol for @var{keyword}. @@ -2028,6 +2378,7 @@ This is the inverse of @code{make-keyword-from-dash-symbol}. @end deffn list +@c snarfed from list.c:104 @deffn {Scheme Procedure} list . objs @deffnx {C Function} scm_list (objs) Return a list containing @var{objs}, the arguments to @@ -2035,6 +2386,7 @@ Return a list containing @var{objs}, the arguments to @end deffn cons* +@c snarfed from list.c:119 @deffn {Scheme Procedure} cons* arg . rest @deffnx {C Function} scm_cons_star (arg, rest) Like @code{list}, but the last arg provides the tail of the @@ -2046,24 +2398,28 @@ Schemes and in Common LISP. @end deffn null? +@c snarfed from list.c:143 @deffn {Scheme Procedure} null? x @deffnx {C Function} scm_null_p (x) Return @code{#t} iff @var{x} is the empty list, else @code{#f}. @end deffn list? +@c snarfed from list.c:153 @deffn {Scheme Procedure} list? x @deffnx {C Function} scm_list_p (x) Return @code{#t} iff @var{x} is a proper list, else @code{#f}. @end deffn length +@c snarfed from list.c:194 @deffn {Scheme Procedure} length lst @deffnx {C Function} scm_length (lst) Return the number of elements in list @var{lst}. @end deffn append +@c snarfed from list.c:223 @deffn {Scheme Procedure} append . args @deffnx {C Function} scm_append (args) Return a list consisting of the elements the lists passed as @@ -2084,23 +2440,26 @@ if the last argument is not a proper list. @end deffn append! +@c snarfed from list.c:259 @deffn {Scheme Procedure} append! . lists @deffnx {C Function} scm_append_x (lists) A destructive version of @code{append} (@pxref{Pairs and Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field of each list's final pair is changed to point to the head of -the next list, so no consing is performed. Return a pointer to +the next list, so no consing is performed. Return the mutated list. @end deffn last-pair +@c snarfed from list.c:291 @deffn {Scheme Procedure} last-pair lst @deffnx {C Function} scm_last_pair (lst) -Return a pointer to the last pair in @var{lst}, signalling an error if +Return the last pair in @var{lst}, signalling an error if @var{lst} is circular. @end deffn reverse +@c snarfed from list.c:321 @deffn {Scheme Procedure} reverse lst @deffnx {C Function} scm_reverse (lst) Return a new list that contains the elements of @var{lst} but @@ -2108,12 +2467,13 @@ in reverse order. @end deffn reverse! +@c snarfed from list.c:355 @deffn {Scheme Procedure} reverse! lst [new_tail] @deffnx {C Function} scm_reverse_x (lst, new_tail) A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr of each cell in @var{lst} is -modified to point to the previous list element. Return a pointer to the -head of the reversed list. +modified to point to the previous list element. Return the +reversed list. Caveat: because the list is modified in place, the tail of the original list now becomes its head, and the head of the original list now becomes @@ -2124,23 +2484,27 @@ of the modified list is not lost, it is wise to save the return value of @end deffn list-ref +@c snarfed from list.c:381 @deffn {Scheme Procedure} list-ref list k @deffnx {C Function} scm_list_ref (list, k) Return the @var{k}th element from @var{list}. @end deffn list-set! +@c snarfed from list.c:405 @deffn {Scheme Procedure} list-set! list k val @deffnx {C Function} scm_list_set_x (list, k, val) Set the @var{k}th element of @var{list} to @var{val}. @end deffn list-cdr-ref +@c snarfed from list.c:427 @deffn {Scheme Procedure} list-cdr-ref implemented by the C function "scm_list_tail" @end deffn list-tail +@c snarfed from list.c:436 @deffn {Scheme Procedure} list-tail lst k @deffnx {Scheme Procedure} list-cdr-ref lst k @deffnx {C Function} scm_list_tail (lst, k) @@ -2153,12 +2517,14 @@ or returning the results of cdring @var{k} times down @var{lst}. @end deffn list-cdr-set! +@c snarfed from list.c:451 @deffn {Scheme Procedure} list-cdr-set! list k val @deffnx {C Function} scm_list_cdr_set_x (list, k, val) Set the @var{k}th cdr of @var{list} to @var{val}. @end deffn list-head +@c snarfed from list.c:479 @deffn {Scheme Procedure} list-head lst k @deffnx {C Function} scm_list_head (lst, k) Copy the first @var{k} elements from @var{lst} into a new list, and @@ -2166,12 +2532,14 @@ return it. @end deffn list-copy +@c snarfed from list.c:530 @deffn {Scheme Procedure} list-copy lst @deffnx {C Function} scm_list_copy (lst) Return a (newly-created) copy of @var{lst}. @end deffn memq +@c snarfed from list.c:584 @deffn {Scheme Procedure} memq x lst @deffnx {C Function} scm_memq (x, lst) Return the first sublist of @var{lst} whose car is @code{eq?} @@ -2183,6 +2551,7 @@ returned. @end deffn memv +@c snarfed from list.c:600 @deffn {Scheme Procedure} memv x lst @deffnx {C Function} scm_memv (x, lst) Return the first sublist of @var{lst} whose car is @code{eqv?} @@ -2194,6 +2563,7 @@ returned. @end deffn member +@c snarfed from list.c:621 @deffn {Scheme Procedure} member x lst @deffnx {C Function} scm_member (x, lst) Return the first sublist of @var{lst} whose car is @@ -2205,12 +2575,13 @@ empty list) is returned. @end deffn delq! +@c snarfed from list.c:646 @deffn {Scheme Procedure} delq! item lst @deffnx {Scheme Procedure} delv! item lst @deffnx {Scheme Procedure} delete! item lst @deffnx {C Function} scm_delq_x (item, lst) These procedures are destructive versions of @code{delq}, @code{delv} -and @code{delete}: they modify the pointers in the existing @var{lst} +and @code{delete}: they modify the existing @var{lst} rather than creating a new list. Caveat evaluator: Like other destructive list functions, these functions cannot modify the binding of @var{lst}, and so cannot be used to delete the first element of @@ -2218,6 +2589,7 @@ destructive list functions, these functions cannot modify the binding of @end deffn delv! +@c snarfed from list.c:670 @deffn {Scheme Procedure} delv! item lst @deffnx {C Function} scm_delv_x (item, lst) Destructively remove all elements from @var{lst} that are @@ -2225,6 +2597,7 @@ Destructively remove all elements from @var{lst} that are @end deffn delete! +@c snarfed from list.c:695 @deffn {Scheme Procedure} delete! item lst @deffnx {C Function} scm_delete_x (item, lst) Destructively remove all elements from @var{lst} that are @@ -2232,6 +2605,7 @@ Destructively remove all elements from @var{lst} that are @end deffn delq +@c snarfed from list.c:724 @deffn {Scheme Procedure} delq item lst @deffnx {C Function} scm_delq (item, lst) Return a newly-created copy of @var{lst} with elements @@ -2241,6 +2615,7 @@ Return a newly-created copy of @var{lst} with elements @end deffn delv +@c snarfed from list.c:737 @deffn {Scheme Procedure} delv item lst @deffnx {C Function} scm_delv (item, lst) Return a newly-created copy of @var{lst} with elements @@ -2250,6 +2625,7 @@ Return a newly-created copy of @var{lst} with elements @end deffn delete +@c snarfed from list.c:750 @deffn {Scheme Procedure} delete item lst @deffnx {C Function} scm_delete (item, lst) Return a newly-created copy of @var{lst} with elements @@ -2259,6 +2635,7 @@ against @var{item} with @code{equal?}. @end deffn delq1! +@c snarfed from list.c:763 @deffn {Scheme Procedure} delq1! item lst @deffnx {C Function} scm_delq1_x (item, lst) Like @code{delq!}, but only deletes the first occurrence of @@ -2267,6 +2644,7 @@ Like @code{delq!}, but only deletes the first occurrence of @end deffn delv1! +@c snarfed from list.c:791 @deffn {Scheme Procedure} delv1! item lst @deffnx {C Function} scm_delv1_x (item, lst) Like @code{delv!}, but only deletes the first occurrence of @@ -2275,6 +2653,7 @@ Like @code{delv!}, but only deletes the first occurrence of @end deffn delete1! +@c snarfed from list.c:819 @deffn {Scheme Procedure} delete1! item lst @deffnx {C Function} scm_delete1_x (item, lst) Like @code{delete!}, but only deletes the first occurrence of @@ -2282,7 +2661,30 @@ Like @code{delete!}, but only deletes the first occurrence of @code{equal?}. See also @code{delq1!} and @code{delv1!}. @end deffn + filter +@c snarfed from list.c:851 +@deffn {Scheme Procedure} filter pred list +@deffnx {C Function} scm_filter (pred, list) +Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}. +The list is not disordered -- elements that appear in the result list occur +in the same order as they occur in the argument list. The returned list may +share a common tail with the argument list. The dynamic order in which the +various applications of pred are made is not specified. + +@lisp +(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4) +@end lisp +@end deffn + + filter! +@c snarfed from list.c:878 +@deffn {Scheme Procedure} filter! pred list +@deffnx {C Function} scm_filter_x (pred, list) +Linear-update variant of @code{filter}. +@end deffn + primitive-load +@c snarfed from load.c:94 @deffn {Scheme Procedure} primitive-load filename @deffnx {C Function} scm_primitive_load (filename) Load the file named @var{filename} and evaluate its contents in @@ -2295,6 +2697,7 @@ documentation for @code{%load-hook} later in this section. @end deffn %package-data-dir +@c snarfed from load.c:134 @deffn {Scheme Procedure} %package-data-dir @deffnx {C Function} scm_sys_package_data_dir () Return the name of the directory where Scheme packages, modules and @@ -2303,6 +2706,7 @@ libraries are kept. On most Unix systems, this will be @end deffn %library-dir +@c snarfed from load.c:146 @deffn {Scheme Procedure} %library-dir @deffnx {C Function} scm_sys_library_dir () Return the directory where the Guile Scheme library files are installed. @@ -2310,6 +2714,7 @@ E.g., may return "/usr/share/guile/1.3.5". @end deffn %site-dir +@c snarfed from load.c:158 @deffn {Scheme Procedure} %site-dir @deffnx {C Function} scm_sys_site_dir () Return the directory where the Guile site files are installed. @@ -2317,6 +2722,7 @@ E.g., may return "/usr/share/guile/site". @end deffn parse-path +@c snarfed from load.c:183 @deffn {Scheme Procedure} parse-path path [tail] @deffnx {C Function} scm_parse_path (path, tail) Parse @var{path}, which is expected to be a colon-separated @@ -2326,6 +2732,7 @@ is returned. @end deffn search-path +@c snarfed from load.c:310 @deffn {Scheme Procedure} search-path path filename [extensions] @deffnx {C Function} scm_search_path (path, filename, extensions) Search @var{path} for a directory containing a file named @@ -2338,6 +2745,7 @@ concatenated with each @var{extension}. @end deffn %search-load-path +@c snarfed from load.c:447 @deffn {Scheme Procedure} %search-load-path filename @deffnx {C Function} scm_sys_search_load_path (filename) Search @var{%load-path} for the file named @var{filename}, @@ -2350,6 +2758,7 @@ will try each extension automatically. @end deffn primitive-load-path +@c snarfed from load.c:468 @deffn {Scheme Procedure} primitive-load-path filename @deffnx {C Function} scm_primitive_load_path (filename) Search @var{%load-path} for the file named @var{filename} and @@ -2358,33 +2767,8 @@ relative pathname and is not found in the list of search paths, an error is signalled. @end deffn - procedure->syntax -@deffn {Scheme Procedure} procedure->syntax code -@deffnx {C Function} scm_makacro (code) -Return a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, returns the -result of applying @var{code} to the expression and the -environment. -@end deffn - - procedure->macro -@deffn {Scheme Procedure} procedure->macro code -@deffnx {C Function} scm_makmacro (code) -Return a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, evaluates the -result of applying @var{code} to the expression and the -environment. For example: - -@lisp -(define trace - (procedure->macro - (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) - -(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). -@end lisp -@end deffn - procedure->memoizing-macro +@c snarfed from macros.c:109 @deffn {Scheme Procedure} procedure->memoizing-macro code @deffnx {C Function} scm_makmmacro (code) Return a @dfn{macro} which, when a symbol defined to this value @@ -2398,7 +2782,18 @@ environment. form of the containing code. @end deffn + procedure->syntax +@c snarfed from macros.c:123 +@deffn {Scheme Procedure} procedure->syntax code +@deffnx {C Function} scm_makacro (code) +Return a @dfn{macro} which, when a symbol defined to this value +appears as the first symbol in an expression, returns the +result of applying @var{code} to the expression and the +environment. +@end deffn + macro? +@c snarfed from macros.c:165 @deffn {Scheme Procedure} macro? obj @deffnx {C Function} scm_macro_p (obj) Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a @@ -2406,6 +2801,7 @@ syntax transformer. @end deffn macro-type +@c snarfed from macros.c:186 @deffn {Scheme Procedure} macro-type m @deffnx {C Function} scm_macro_type (m) Return one of the symbols @code{syntax}, @code{macro} or @@ -2416,24 +2812,28 @@ returned. @end deffn macro-name +@c snarfed from macros.c:207 @deffn {Scheme Procedure} macro-name m @deffnx {C Function} scm_macro_name (m) Return the name of the macro @var{m}. @end deffn macro-transformer +@c snarfed from macros.c:218 @deffn {Scheme Procedure} macro-transformer m @deffnx {C Function} scm_macro_transformer (m) Return the transformer of the macro @var{m}. @end deffn current-module +@c snarfed from modules.c:45 @deffn {Scheme Procedure} current-module @deffnx {C Function} scm_current_module () Return the current module. @end deffn set-current-module +@c snarfed from modules.c:57 @deffn {Scheme Procedure} set-current-module module @deffnx {C Function} scm_set_current_module (module) Set the current module to @var{module} and return @@ -2441,6 +2841,7 @@ the previous current module. @end deffn interaction-environment +@c snarfed from modules.c:80 @deffn {Scheme Procedure} interaction-environment @deffnx {C Function} scm_interaction_environment () Return a specifier for the environment that contains @@ -2451,30 +2852,42 @@ evaluate expressions dynamically typed by the user. @end deffn env-module +@c snarfed from modules.c:261 @deffn {Scheme Procedure} env-module env @deffnx {C Function} scm_env_module (env) Return the module of @var{ENV}, a lexical environment. @end deffn standard-eval-closure +@c snarfed from modules.c:337 @deffn {Scheme Procedure} standard-eval-closure module @deffnx {C Function} scm_standard_eval_closure (module) Return an eval closure for the module @var{module}. @end deffn standard-interface-eval-closure +@c snarfed from modules.c:348 @deffn {Scheme Procedure} standard-interface-eval-closure module @deffnx {C Function} scm_standard_interface_eval_closure (module) Return a interface eval closure for the module @var{module}. Such a closure does not allow new bindings to be added. @end deffn + module-import-interface +@c snarfed from modules.c:394 +@deffn {Scheme Procedure} module-import-interface module sym +@deffnx {C Function} scm_module_import_interface (module, sym) + +@end deffn + %get-pre-modules-obarray +@c snarfed from modules.c:611 @deffn {Scheme Procedure} %get-pre-modules-obarray @deffnx {C Function} scm_get_pre_modules_obarray () Return the obarray that is used for all new bindings before the module system is booted. The first call to @code{set-current-module} will boot the module system. @end deffn exact? +@c snarfed from numbers.c:461 @deffn {Scheme Procedure} exact? x @deffnx {C Function} scm_exact_p (x) Return @code{#t} if @var{x} is an exact number, @code{#f} @@ -2482,6 +2895,7 @@ otherwise. @end deffn odd? +@c snarfed from numbers.c:480 @deffn {Scheme Procedure} odd? n @deffnx {C Function} scm_odd_p (n) Return @code{#t} if @var{n} is an odd number, @code{#f} @@ -2489,6 +2903,7 @@ otherwise. @end deffn even? +@c snarfed from numbers.c:515 @deffn {Scheme Procedure} even? n @deffnx {C Function} scm_even_p (n) Return @code{#t} if @var{n} is an even number, @code{#f} @@ -2496,6 +2911,7 @@ otherwise. @end deffn inf? +@c snarfed from numbers.c:549 @deffn {Scheme Procedure} inf? n @deffnx {C Function} scm_inf_p (n) Return @code{#t} if @var{n} is infinite, @code{#f} @@ -2503,6 +2919,7 @@ otherwise. @end deffn nan? +@c snarfed from numbers.c:565 @deffn {Scheme Procedure} nan? n @deffnx {C Function} scm_nan_p (n) Return @code{#t} if @var{n} is a NaN, @code{#f} @@ -2510,18 +2927,28 @@ otherwise. @end deffn inf +@c snarfed from numbers.c:635 @deffn {Scheme Procedure} inf @deffnx {C Function} scm_inf () Return Inf. @end deffn nan +@c snarfed from numbers.c:650 @deffn {Scheme Procedure} nan @deffnx {C Function} scm_nan () Return NaN. @end deffn + abs +@c snarfed from numbers.c:666 +@deffn {Scheme Procedure} abs x +@deffnx {C Function} scm_abs (x) +Return the absolute value of @var{x}. +@end deffn + logand +@c snarfed from numbers.c:1201 @deffn {Scheme Procedure} logand n1 n2 Return the bitwise AND of the integer arguments. @@ -2533,6 +2960,7 @@ Return the bitwise AND of the integer arguments. @end deffn logior +@c snarfed from numbers.c:1277 @deffn {Scheme Procedure} logior n1 n2 Return the bitwise OR of the integer arguments. @@ -2544,6 +2972,7 @@ Return the bitwise OR of the integer arguments. @end deffn logxor +@c snarfed from numbers.c:1353 @deffn {Scheme Procedure} logxor n1 n2 Return the bitwise XOR of the integer arguments. A bit is set in the result if it is set in an odd number of arguments. @@ -2556,6 +2985,7 @@ set in the result if it is set in an odd number of arguments. @end deffn logtest +@c snarfed from numbers.c:1424 @deffn {Scheme Procedure} logtest j k @deffnx {C Function} scm_logtest (j, k) @lisp @@ -2567,6 +2997,7 @@ set in the result if it is set in an odd number of arguments. @end deffn logbit? +@c snarfed from numbers.c:1495 @deffn {Scheme Procedure} logbit? index j @deffnx {C Function} scm_logbit_p (index, j) @lisp @@ -2581,9 +3012,10 @@ set in the result if it is set in an odd number of arguments. @end deffn lognot +@c snarfed from numbers.c:1529 @deffn {Scheme Procedure} lognot n @deffnx {C Function} scm_lognot (n) -Return the integer which is the 2s-complement of the integer +Return the integer which is the ones-complement of the integer argument. @lisp @@ -2594,7 +3026,21 @@ argument. @end lisp @end deffn + modulo-expt +@c snarfed from numbers.c:1574 +@deffn {Scheme Procedure} modulo-expt n k m +@deffnx {C Function} scm_modulo_expt (n, k, m) +Return @var{n} raised to the integer exponent +@var{k}, modulo @var{m}. + +@lisp +(modulo-expt 2 3 5) + @result{} 3 +@end lisp +@end deffn + integer-expt +@c snarfed from numbers.c:1679 @deffn {Scheme Procedure} integer-expt n k @deffnx {C Function} scm_integer_expt (n, k) Return @var{n} raised to the non-negative integer exponent @@ -2609,26 +3055,32 @@ Return @var{n} raised to the non-negative integer exponent @end deffn ash +@c snarfed from numbers.c:1785 @deffn {Scheme Procedure} ash n cnt @deffnx {C Function} scm_ash (n, cnt) -The function ash performs an arithmetic shift left by @var{cnt} -bits (or shift right, if @var{cnt} is negative). 'Arithmetic' -means, that the function does not guarantee to keep the bit -structure of @var{n}, but rather guarantees that the result -will always be rounded towards minus infinity. Therefore, the -results of ash and a corresponding bitwise shift will differ if -@var{n} is negative. +Return @var{n} shifted left by @var{cnt} bits, or shifted right +if @var{cnt} is negative. This is an ``arithmetic'' shift. -Formally, the function returns an integer equivalent to -@code{(inexact->exact (floor (* @var{n} (expt 2 @var{cnt}))))}. +This is effectively a multiplication by 2^@var{cnt}, and when +@var{cnt} is negative it's a division, rounded towards negative +infinity. (Note that this is not the same rounding as +@code{quotient} does.) + +With @var{n} viewed as an infinite precision twos complement, +@code{ash} means a left shift introducing zero bits, or a right +shift dropping bits. @lisp (number->string (ash #b1 3) 2) @result{} "1000" (number->string (ash #b1010 -1) 2) @result{} "101" + +;; -23 is bits ...11101001, -6 is bits ...111010 +(ash -23 -2) @result{} -6 @end lisp @end deffn bit-extract +@c snarfed from numbers.c:1825 @deffn {Scheme Procedure} bit-extract n start end @deffnx {C Function} scm_bit_extract (n, start, end) Return the integer composed of the @var{start} (inclusive) @@ -2644,6 +3096,7 @@ through @var{end} (exclusive) bits of @var{n}. The @end deffn logcount +@c snarfed from numbers.c:1904 @deffn {Scheme Procedure} logcount n @deffnx {C Function} scm_logcount (n) Return the number of bits in integer @var{n}. If integer is @@ -2662,6 +3115,7 @@ representation are counted. If 0, 0 is returned. @end deffn integer-length +@c snarfed from numbers.c:1952 @deffn {Scheme Procedure} integer-length n @deffnx {C Function} scm_integer_length (n) Return the number of bits necessary to represent @var{n}. @@ -2677,6 +3131,7 @@ Return the number of bits necessary to represent @var{n}. @end deffn number->string +@c snarfed from numbers.c:2275 @deffn {Scheme Procedure} number->string n [radix] @deffnx {C Function} scm_number_to_string (n, radix) Return a string holding the external representation of the @@ -2685,6 +3140,7 @@ inexact, a radix of 10 will be used. @end deffn string->number +@c snarfed from numbers.c:2958 @deffn {Scheme Procedure} string->number string [radix] @deffnx {C Function} scm_string_to_number (string, radix) Return a number of the maximally precise representation @@ -2698,13 +3154,17 @@ syntactically valid notation for a number, then @end deffn number? -@deffn {Scheme Procedure} number? -implemented by the C function "scm_number_p" +@c snarfed from numbers.c:3021 +@deffn {Scheme Procedure} number? x +@deffnx {C Function} scm_number_p (x) +Return @code{#t} if @var{x} is a number, @code{#f} +otherwise. @end deffn complex? +@c snarfed from numbers.c:3034 @deffn {Scheme Procedure} complex? x -@deffnx {C Function} scm_number_p (x) +@deffnx {C Function} scm_complex_p (x) Return @code{#t} if @var{x} is a complex number, @code{#f} otherwise. Note that the sets of real, rational and integer values form subsets of the set of complex numbers, i. e. the @@ -2713,22 +3173,27 @@ rational or integer number. @end deffn real? -@deffn {Scheme Procedure} real? -implemented by the C function "scm_real_p" +@c snarfed from numbers.c:3047 +@deffn {Scheme Procedure} real? x +@deffnx {C Function} scm_real_p (x) +Return @code{#t} if @var{x} is a real number, @code{#f} +otherwise. Note that the set of integer values forms a subset of +the set of real numbers, i. e. the predicate will also be +fulfilled if @var{x} is an integer number. @end deffn rational? +@c snarfed from numbers.c:3060 @deffn {Scheme Procedure} rational? x -@deffnx {C Function} scm_real_p (x) +@deffnx {C Function} scm_rational_p (x) Return @code{#t} if @var{x} is a rational number, @code{#f} otherwise. Note that the set of integer values forms a subset of the set of rational numbers, i. e. the predicate will also be -fulfilled if @var{x} is an integer number. Real numbers -will also satisfy this predicate, because of their limited -precision. +fulfilled if @var{x} is an integer number. @end deffn integer? +@c snarfed from numbers.c:3083 @deffn {Scheme Procedure} integer? x @deffnx {C Function} scm_integer_p (x) Return @code{#t} if @var{x} is an integer number, @code{#f} @@ -2736,13 +3201,43 @@ else. @end deffn inexact? +@c snarfed from numbers.c:3108 @deffn {Scheme Procedure} inexact? x @deffnx {C Function} scm_inexact_p (x) Return @code{#t} if @var{x} is an inexact number, @code{#f} else. @end deffn + truncate +@c snarfed from numbers.c:4955 +@deffn {Scheme Procedure} truncate x +@deffnx {C Function} scm_truncate_number (x) +Round the number @var{x} towards zero. +@end deffn + + round +@c snarfed from numbers.c:4971 +@deffn {Scheme Procedure} round x +@deffnx {C Function} scm_round_number (x) +Round the number @var{x} towards the nearest integer. When it is exactly halfway between two integers, round towards the even one. +@end deffn + + floor +@c snarfed from numbers.c:4997 +@deffn {Scheme Procedure} floor x +@deffnx {C Function} scm_floor (x) +Round the number @var{x} towards minus infinity. +@end deffn + + ceiling +@c snarfed from numbers.c:5028 +@deffn {Scheme Procedure} ceiling x +@deffnx {C Function} scm_ceiling (x) +Round the number @var{x} towards infinity. +@end deffn + $expt +@c snarfed from numbers.c:5137 @deffn {Scheme Procedure} $expt x y @deffnx {C Function} scm_sys_expt (x, y) Return @var{x} raised to the power of @var{y}. This @@ -2750,6 +3245,7 @@ procedure does not accept complex arguments. @end deffn $atan2 +@c snarfed from numbers.c:5153 @deffn {Scheme Procedure} $atan2 x y @deffnx {C Function} scm_sys_atan2 (x, y) Return the arc tangent of the two arguments @var{x} and @@ -2760,6 +3256,7 @@ procedure does not accept complex arguments. @end deffn make-rectangular +@c snarfed from numbers.c:5181 @deffn {Scheme Procedure} make-rectangular real imaginary @deffnx {C Function} scm_make_rectangular (real, imaginary) Return a complex number constructed of the given @var{real} and @@ -2767,42 +3264,56 @@ Return a complex number constructed of the given @var{real} and @end deffn make-polar +@c snarfed from numbers.c:5205 @deffn {Scheme Procedure} make-polar x y @deffnx {C Function} scm_make_polar (x, y) Return the complex number @var{x} * e^(i * @var{y}). @end deffn inexact->exact +@c snarfed from numbers.c:5408 @deffn {Scheme Procedure} inexact->exact z @deffnx {C Function} scm_inexact_to_exact (z) Return an exact number that is numerically closest to @var{z}. @end deffn + rationalize +@c snarfed from numbers.c:5445 +@deffn {Scheme Procedure} rationalize x err +@deffnx {C Function} scm_rationalize (x, err) +Return an exact number that is within @var{err} of @var{x}. +@end deffn + class-of +@c snarfed from objects.c:62 @deffn {Scheme Procedure} class-of x @deffnx {C Function} scm_class_of (x) Return the class of @var{x}. @end deffn entity? +@c snarfed from objects.c:342 @deffn {Scheme Procedure} entity? obj @deffnx {C Function} scm_entity_p (obj) Return @code{#t} if @var{obj} is an entity. @end deffn operator? +@c snarfed from objects.c:351 @deffn {Scheme Procedure} operator? obj @deffnx {C Function} scm_operator_p (obj) Return @code{#t} if @var{obj} is an operator. @end deffn valid-object-procedure? +@c snarfed from objects.c:367 @deffn {Scheme Procedure} valid-object-procedure? proc @deffnx {C Function} scm_valid_object_procedure_p (proc) Return @code{#t} iff @var{proc} is a procedure that can be used with @code{set-object-procedure}. It is always valid to use a closure constructed by @code{lambda}. @end deffn set-object-procedure! +@c snarfed from objects.c:389 @deffn {Scheme Procedure} set-object-procedure! obj proc @deffnx {C Function} scm_set_object_procedure_x (obj, proc) Set the object procedure of @var{obj} to @var{proc}. @@ -2810,6 +3321,7 @@ Set the object procedure of @var{obj} to @var{proc}. @end deffn make-class-object +@c snarfed from objects.c:449 @deffn {Scheme Procedure} make-class-object metaclass layout @deffnx {C Function} scm_make_class_object (metaclass, layout) Create a new class object of class @var{metaclass}, with the @@ -2817,6 +3329,7 @@ slot layout specified by @var{layout}. @end deffn make-subclass-object +@c snarfed from objects.c:464 @deffn {Scheme Procedure} make-subclass-object class layout @deffnx {C Function} scm_make_subclass_object (class, layout) Create a subclass object of @var{class}, with the slot layout @@ -2824,24 +3337,28 @@ specified by @var{layout}. @end deffn object-properties +@c snarfed from objprop.c:35 @deffn {Scheme Procedure} object-properties obj @deffnx {C Function} scm_object_properties (obj) Return @var{obj}'s property list. @end deffn set-object-properties! +@c snarfed from objprop.c:45 @deffn {Scheme Procedure} set-object-properties! obj alist @deffnx {C Function} scm_set_object_properties_x (obj, alist) Set @var{obj}'s property list to @var{alist}. @end deffn object-property +@c snarfed from objprop.c:56 @deffn {Scheme Procedure} object-property obj key @deffnx {C Function} scm_object_property (obj, key) Return the property of @var{obj} with name @var{key}. @end deffn set-object-property! +@c snarfed from objprop.c:68 @deffn {Scheme Procedure} set-object-property! obj key value @deffnx {C Function} scm_set_object_property_x (obj, key, value) In @var{obj}'s property list, set the property named @var{key} @@ -2849,6 +3366,7 @@ to @var{value}. @end deffn cons +@c snarfed from pairs.c:56 @deffn {Scheme Procedure} cons x y @deffnx {C Function} scm_cons (x, y) Return a newly allocated pair whose car is @var{x} and whose @@ -2857,6 +3375,7 @@ sense of @code{eq?}) from every previously existing object. @end deffn pair? +@c snarfed from pairs.c:74 @deffn {Scheme Procedure} pair? x @deffnx {C Function} scm_pair_p (x) Return @code{#t} if @var{x} is a pair; otherwise return @@ -2864,6 +3383,7 @@ Return @code{#t} if @var{x} is a pair; otherwise return @end deffn set-car! +@c snarfed from pairs.c:85 @deffn {Scheme Procedure} set-car! pair value @deffnx {C Function} scm_set_car_x (pair, value) Stores @var{value} in the car field of @var{pair}. The value returned @@ -2871,6 +3391,7 @@ by @code{set-car!} is unspecified. @end deffn set-cdr! +@c snarfed from pairs.c:98 @deffn {Scheme Procedure} set-cdr! pair value @deffnx {C Function} scm_set_cdr_x (pair, value) Stores @var{value} in the cdr field of @var{pair}. The value returned @@ -2878,6 +3399,7 @@ by @code{set-cdr!} is unspecified. @end deffn char-ready? +@c snarfed from ports.c:242 @deffn {Scheme Procedure} char-ready? [port] @deffnx {C Function} scm_char_ready_p (port) Return @code{#t} if a character is ready on input @var{port} @@ -2885,17 +3407,19 @@ and return @code{#f} otherwise. If @code{char-ready?} returns @code{#t} then the next @code{read-char} operation on @var{port} is guaranteed not to hang. If @var{port} is a file port at end of file then @code{char-ready?} returns @code{#t}. -@footnote{@code{char-ready?} exists to make it possible for a + +@code{char-ready?} exists to make it possible for a program to accept characters from interactive ports without getting stuck waiting for input. Any input editors associated with such ports must make sure that characters whose existence has been asserted by @code{char-ready?} cannot be rubbed out. If @code{char-ready?} were to return @code{#f} at end of file, a port at end of file would be indistinguishable from an -interactive port that has no ready characters.} +interactive port that has no ready characters. @end deffn drain-input +@c snarfed from ports.c:319 @deffn {Scheme Procedure} drain-input port @deffnx {C Function} scm_drain_input (port) This procedure clears a port's input buffers, similar @@ -2915,6 +3439,7 @@ for further input. @end deffn current-input-port +@c snarfed from ports.c:347 @deffn {Scheme Procedure} current-input-port @deffnx {C Function} scm_current_input_port () Return the current input port. This is the default port used @@ -2923,6 +3448,7 @@ returns the @dfn{standard input} in Unix and C terminology. @end deffn current-output-port +@c snarfed from ports.c:359 @deffn {Scheme Procedure} current-output-port @deffnx {C Function} scm_current_output_port () Return the current output port. This is the default port used @@ -2932,6 +3458,7 @@ Unix and C terminology. @end deffn current-error-port +@c snarfed from ports.c:369 @deffn {Scheme Procedure} current-error-port @deffnx {C Function} scm_current_error_port () Return the port to which errors and warnings should be sent (the @@ -2939,6 +3466,7 @@ Return the port to which errors and warnings should be sent (the @end deffn current-load-port +@c snarfed from ports.c:379 @deffn {Scheme Procedure} current-load-port @deffnx {C Function} scm_current_load_port () Return the current-load-port. @@ -2946,6 +3474,7 @@ The load port is used internally by @code{primitive-load}. @end deffn set-current-input-port +@c snarfed from ports.c:392 @deffn {Scheme Procedure} set-current-input-port port @deffnx {Scheme Procedure} set-current-output-port port @deffnx {Scheme Procedure} set-current-error-port port @@ -2956,24 +3485,28 @@ so that they use the supplied @var{port} for input or output. @end deffn set-current-output-port +@c snarfed from ports.c:405 @deffn {Scheme Procedure} set-current-output-port port @deffnx {C Function} scm_set_current_output_port (port) Set the current default output port to @var{port}. @end deffn set-current-error-port +@c snarfed from ports.c:419 @deffn {Scheme Procedure} set-current-error-port port @deffnx {C Function} scm_set_current_error_port (port) Set the current default error port to @var{port}. @end deffn port-revealed +@c snarfed from ports.c:639 @deffn {Scheme Procedure} port-revealed port @deffnx {C Function} scm_port_revealed (port) Return the revealed count for @var{port}. @end deffn set-port-revealed! +@c snarfed from ports.c:652 @deffn {Scheme Procedure} set-port-revealed! port rcount @deffnx {C Function} scm_set_port_revealed_x (port, rcount) Sets the revealed count for a port to a given value. @@ -2981,6 +3514,7 @@ The return value is unspecified. @end deffn port-mode +@c snarfed from ports.c:713 @deffn {Scheme Procedure} port-mode port @deffnx {C Function} scm_port_mode (port) Return the port modes associated with the open port @var{port}. @@ -2990,6 +3524,7 @@ used only during port creation are not retained. @end deffn close-port +@c snarfed from ports.c:750 @deffn {Scheme Procedure} close-port port @deffnx {C Function} scm_close_port (port) Close the specified port object. Return @code{#t} if it @@ -3001,6 +3536,7 @@ descriptors. @end deffn close-input-port +@c snarfed from ports.c:780 @deffn {Scheme Procedure} close-input-port port @deffnx {C Function} scm_close_input_port (port) Close the specified input port object. The routine has no effect if @@ -3012,6 +3548,7 @@ which can close file descriptors. @end deffn close-output-port +@c snarfed from ports.c:795 @deffn {Scheme Procedure} close-output-port port @deffnx {C Function} scm_close_output_port (port) Close the specified output port object. The routine has no effect if @@ -3023,6 +3560,7 @@ which can close file descriptors. @end deffn port-for-each +@c snarfed from ports.c:841 @deffn {Scheme Procedure} port-for-each proc @deffnx {C Function} scm_port_for_each (proc) Apply @var{proc} to each port in the Guile port table @@ -3034,6 +3572,7 @@ have no effect as far as @var{port-for-each} is concerned. @end deffn input-port? +@c snarfed from ports.c:859 @deffn {Scheme Procedure} input-port? x @deffnx {C Function} scm_input_port_p (x) Return @code{#t} if @var{x} is an input port, otherwise return @@ -3042,6 +3581,7 @@ Return @code{#t} if @var{x} is an input port, otherwise return @end deffn output-port? +@c snarfed from ports.c:870 @deffn {Scheme Procedure} output-port? x @deffnx {C Function} scm_output_port_p (x) Return @code{#t} if @var{x} is an output port, otherwise return @@ -3050,6 +3590,7 @@ Return @code{#t} if @var{x} is an output port, otherwise return @end deffn port? +@c snarfed from ports.c:882 @deffn {Scheme Procedure} port? x @deffnx {C Function} scm_port_p (x) Return a boolean indicating whether @var{x} is a port. @@ -3058,6 +3599,7 @@ Equivalent to @code{(or (input-port? @var{x}) (output-port? @end deffn port-closed? +@c snarfed from ports.c:892 @deffn {Scheme Procedure} port-closed? port @deffnx {C Function} scm_port_closed_p (port) Return @code{#t} if @var{port} is closed or @code{#f} if it is @@ -3065,6 +3607,7 @@ open. @end deffn eof-object? +@c snarfed from ports.c:903 @deffn {Scheme Procedure} eof-object? x @deffnx {C Function} scm_eof_object_p (x) Return @code{#t} if @var{x} is an end-of-file object; otherwise @@ -3072,6 +3615,7 @@ return @code{#f}. @end deffn force-output +@c snarfed from ports.c:917 @deffn {Scheme Procedure} force-output [port] @deffnx {C Function} scm_force_output (port) Flush the specified output port, or the current output port if @var{port} @@ -3084,6 +3628,7 @@ The return value is unspecified. @end deffn flush-all-ports +@c snarfed from ports.c:935 @deffn {Scheme Procedure} flush-all-ports @deffnx {C Function} scm_flush_all_ports () Equivalent to calling @code{force-output} on @@ -3091,6 +3636,7 @@ all open output ports. The return value is unspecified. @end deffn read-char +@c snarfed from ports.c:955 @deffn {Scheme Procedure} read-char [port] @deffnx {C Function} scm_read_char (port) Return the next character available from @var{port}, updating @@ -3099,12 +3645,15 @@ characters are available, the end-of-file object is returned. @end deffn peek-char +@c snarfed from ports.c:1281 @deffn {Scheme Procedure} peek-char [port] @deffnx {C Function} scm_peek_char (port) Return the next character available from @var{port}, @emph{without} updating @var{port} to point to the following character. If no more characters are available, the -end-of-file object is returned.@footnote{The value returned by +end-of-file object is returned. + +The value returned by a call to @code{peek-char} is the same as the value that would have been returned by a call to @code{read-char} on the same port. The only difference is that the very next call to @@ -3112,10 +3661,11 @@ port. The only difference is that the very next call to return the value returned by the preceding call to @code{peek-char}. In particular, a call to @code{peek-char} on an interactive port will hang waiting for input whenever a call -to @code{read-char} would have hung.} +to @code{read-char} would have hung. @end deffn unread-char +@c snarfed from ports.c:1304 @deffn {Scheme Procedure} unread-char cobj [port] @deffnx {C Function} scm_unread_char (cobj, port) Place @var{char} in @var{port} so that it will be read by the @@ -3125,6 +3675,7 @@ not supplied, the current input port is used. @end deffn unread-string +@c snarfed from ports.c:1327 @deffn {Scheme Procedure} unread-string str port @deffnx {C Function} scm_unread_string (str, port) Place the string @var{str} in @var{port} so that its characters will be @@ -3134,6 +3685,7 @@ unread characters will be read again in last-in first-out order. If @end deffn seek +@c snarfed from ports.c:1366 @deffn {Scheme Procedure} seek fd_port offset whence @deffnx {C Function} scm_seek (fd_port, offset, whence) Sets the current position of @var{fd/port} to the integer @@ -3162,34 +3714,43 @@ that the current position of a port can be obtained using: @end deffn truncate-file +@c snarfed from ports.c:1424 @deffn {Scheme Procedure} truncate-file object [length] @deffnx {C Function} scm_truncate_file (object, length) Truncates the object referred to by @var{object} to at most @var{length} bytes. @var{object} can be a string containing a file name or an integer file descriptor or a port. @var{length} may be omitted if @var{object} is not a file name, -in which case the truncation occurs at the current port. +in which case the truncation occurs at the current port position. The return value is unspecified. @end deffn port-line +@c snarfed from ports.c:1484 @deffn {Scheme Procedure} port-line port @deffnx {C Function} scm_port_line (port) Return the current line number for @var{port}. + +The first line of a file is 0. But you might want to add 1 +when printing line numbers, since starting from 1 is +traditional in error messages, and likely to be more natural to +non-programmers. @end deffn set-port-line! +@c snarfed from ports.c:1496 @deffn {Scheme Procedure} set-port-line! port line @deffnx {C Function} scm_set_port_line_x (port, line) -Set the current line number for @var{port} to @var{line}. +Set the current line number for @var{port} to @var{line}. The +first line of a file is 0. @end deffn port-column +@c snarfed from ports.c:1515 @deffn {Scheme Procedure} port-column port -@deffnx {Scheme Procedure} port-line port @deffnx {C Function} scm_port_column (port) -Return the current column number or line number of @var{port}, -using the current input port if none is specified. If the number is +Return the current column number of @var{port}. +If the number is unknown, the result is #f. Otherwise, the result is a 0-origin integer - i.e. the first character of the first line is line 0, column 0. (However, when you display a file position, for example in an error @@ -3199,14 +3760,15 @@ what non-programmers will find most natural.) @end deffn set-port-column! +@c snarfed from ports.c:1527 @deffn {Scheme Procedure} set-port-column! port column -@deffnx {Scheme Procedure} set-port-line! port line @deffnx {C Function} scm_set_port_column_x (port, column) -Set the current column or line number of @var{port}, using the -current input port if none is specified. +Set the current column of @var{port}. Before reading the first +character on a line the column should be 0. @end deffn port-filename +@c snarfed from ports.c:1541 @deffn {Scheme Procedure} port-filename port @deffnx {C Function} scm_port_filename (port) Return the filename associated with @var{port}. This function returns @@ -3215,6 +3777,7 @@ when called on the current input, output and error ports respectively. @end deffn set-port-filename! +@c snarfed from ports.c:1555 @deffn {Scheme Procedure} set-port-filename! port filename @deffnx {C Function} scm_set_port_filename_x (port, filename) Change the filename associated with @var{port}, using the current input @@ -3224,6 +3787,7 @@ source of data, but only the value that is returned by @end deffn %make-void-port +@c snarfed from ports.c:1649 @deffn {Scheme Procedure} %make-void-port mode @deffnx {C Function} scm_sys_make_void_port (mode) Create and return a new void port. A void port acts like @@ -3233,6 +3797,7 @@ documentation for @code{open-file} in @ref{File Ports}. @end deffn print-options-interface +@c snarfed from print.c:83 @deffn {Scheme Procedure} print-options-interface [setting] @deffnx {C Function} scm_print_options (setting) Option interface for the print options. Instead of using @@ -3242,6 +3807,7 @@ and @code{print-options}. @end deffn simple-format +@c snarfed from print.c:914 @deffn {Scheme Procedure} simple-format destination message . args @deffnx {C Function} scm_simple_format (destination, message, args) Write @var{message} to @var{destination}, defaulting to @@ -3258,6 +3824,7 @@ containing the formatted text. Does not add a trailing newline. @end deffn newline +@c snarfed from print.c:1004 @deffn {Scheme Procedure} newline [port] @deffnx {C Function} scm_newline (port) Send a newline to @var{port}. @@ -3265,19 +3832,24 @@ If @var{port} is omitted, send to the current output port. @end deffn write-char +@c snarfed from print.c:1019 @deffn {Scheme Procedure} write-char chr [port] @deffnx {C Function} scm_write_char (chr, port) Send character @var{chr} to @var{port}. @end deffn port-with-print-state -@deffn {Scheme Procedure} port-with-print-state port pstate +@c snarfed from print.c:1073 +@deffn {Scheme Procedure} port-with-print-state port [pstate] @deffnx {C Function} scm_port_with_print_state (port, pstate) Create a new port which behaves like @var{port}, but with an -included print state @var{pstate}. +included print state @var{pstate}. @var{pstate} is optional. +If @var{pstate} isn't supplied and @var{port} already has +a print state, the old print state is reused. @end deffn get-print-state +@c snarfed from print.c:1086 @deffn {Scheme Procedure} get-print-state port @deffnx {C Function} scm_get_print_state (port) Return the print state of the port @var{port}. If @var{port} @@ -3285,24 +3857,28 @@ has no associated print state, @code{#f} is returned. @end deffn procedure-properties +@c snarfed from procprop.c:160 @deffn {Scheme Procedure} procedure-properties proc @deffnx {C Function} scm_procedure_properties (proc) Return @var{obj}'s property list. @end deffn set-procedure-properties! +@c snarfed from procprop.c:173 @deffn {Scheme Procedure} set-procedure-properties! proc new_val @deffnx {C Function} scm_set_procedure_properties_x (proc, new_val) Set @var{obj}'s property list to @var{alist}. @end deffn procedure-property +@c snarfed from procprop.c:186 @deffn {Scheme Procedure} procedure-property p k @deffnx {C Function} scm_procedure_property (p, k) Return the property of @var{obj} with name @var{key}. @end deffn set-procedure-property! +@c snarfed from procprop.c:209 @deffn {Scheme Procedure} set-procedure-property! p k v @deffnx {C Function} scm_set_procedure_property_x (p, k, v) In @var{obj}'s property list, set the property named @var{key} to @@ -3310,24 +3886,28 @@ In @var{obj}'s property list, set the property named @var{key} to @end deffn procedure? +@c snarfed from procs.c:162 @deffn {Scheme Procedure} procedure? obj @deffnx {C Function} scm_procedure_p (obj) Return @code{#t} if @var{obj} is a procedure. @end deffn closure? +@c snarfed from procs.c:189 @deffn {Scheme Procedure} closure? obj @deffnx {C Function} scm_closure_p (obj) Return @code{#t} if @var{obj} is a closure. @end deffn thunk? +@c snarfed from procs.c:198 @deffn {Scheme Procedure} thunk? obj @deffnx {C Function} scm_thunk_p (obj) Return @code{#t} if @var{obj} is a thunk. @end deffn procedure-documentation +@c snarfed from procs.c:248 @deffn {Scheme Procedure} procedure-documentation proc @deffnx {C Function} scm_procedure_documentation (proc) Return the documentation string associated with @code{proc}. By @@ -3337,6 +3917,7 @@ documentation for that procedure. @end deffn procedure-with-setter? +@c snarfed from procs.c:284 @deffn {Scheme Procedure} procedure-with-setter? obj @deffnx {C Function} scm_procedure_with_setter_p (obj) Return @code{#t} if @var{obj} is a procedure with an @@ -3344,6 +3925,7 @@ associated setter procedure. @end deffn make-procedure-with-setter +@c snarfed from procs.c:294 @deffn {Scheme Procedure} make-procedure-with-setter procedure setter @deffnx {C Function} scm_make_procedure_with_setter (procedure, setter) Create a new procedure which behaves like @var{procedure}, but @@ -3351,6 +3933,7 @@ with the associated setter @var{setter}. @end deffn procedure +@c snarfed from procs.c:308 @deffn {Scheme Procedure} procedure proc @deffnx {C Function} scm_procedure (proc) Return the procedure of @var{proc}, which must be either a @@ -3358,6 +3941,7 @@ procedure with setter, or an operator struct. @end deffn primitive-make-property +@c snarfed from properties.c:40 @deffn {Scheme Procedure} primitive-make-property not_found_proc @deffnx {C Function} scm_primitive_make_property (not_found_proc) Create a @dfn{property token} that can be used with @@ -3367,30 +3951,35 @@ See @code{primitive-property-ref} for the significance of @end deffn primitive-property-ref +@c snarfed from properties.c:59 @deffn {Scheme Procedure} primitive-property-ref prop obj @deffnx {C Function} scm_primitive_property_ref (prop, obj) -Return the property @var{prop} of @var{obj}. When no value -has yet been associated with @var{prop} and @var{obj}, call -@var{not-found-proc} instead (see @code{primitive-make-property}) -and use its return value. That value is also associated with -@var{obj} via @code{primitive-property-set!}. When -@var{not-found-proc} is @code{#f}, use @code{#f} as the -default value of @var{prop}. +Return the property @var{prop} of @var{obj}. + +When no value has yet been associated with @var{prop} and +@var{obj}, the @var{not-found-proc} from @var{prop} is used. A +call @code{(@var{not-found-proc} @var{prop} @var{obj})} is made +and the result set as the property value. If +@var{not-found-proc} is @code{#f} then @code{#f} is the +property value. @end deffn primitive-property-set! +@c snarfed from properties.c:90 @deffn {Scheme Procedure} primitive-property-set! prop obj val @deffnx {C Function} scm_primitive_property_set_x (prop, obj, val) -Associate @var{code} with @var{prop} and @var{obj}. +Set the property @var{prop} of @var{obj} to @var{val}. @end deffn primitive-property-del! +@c snarfed from properties.c:111 @deffn {Scheme Procedure} primitive-property-del! prop obj @deffnx {C Function} scm_primitive_property_del_x (prop, obj) Remove any value associated with @var{prop} and @var{obj}. @end deffn random +@c snarfed from random.c:346 @deffn {Scheme Procedure} random n [state] @deffnx {C Function} scm_random (n, state) Return a number in [0, N). @@ -3408,18 +3997,21 @@ as a side effect of the random operation. @end deffn copy-random-state +@c snarfed from random.c:371 @deffn {Scheme Procedure} copy-random-state [state] @deffnx {C Function} scm_copy_random_state (state) Return a copy of the random state @var{state}. @end deffn seed->random-state +@c snarfed from random.c:383 @deffn {Scheme Procedure} seed->random-state seed @deffnx {C Function} scm_seed_to_random_state (seed) Return a new random state using @var{seed}. @end deffn random:uniform +@c snarfed from random.c:401 @deffn {Scheme Procedure} random:uniform [state] @deffnx {C Function} scm_random_uniform (state) Return a uniformly distributed inexact real random number in @@ -3427,6 +4019,7 @@ Return a uniformly distributed inexact real random number in @end deffn random:normal +@c snarfed from random.c:416 @deffn {Scheme Procedure} random:normal [state] @deffnx {C Function} scm_random_normal (state) Return an inexact real in a normal distribution. The @@ -3436,6 +4029,7 @@ normal distribution with mean m and standard deviation d use @end deffn random:solid-sphere! +@c snarfed from random.c:472 @deffn {Scheme Procedure} random:solid-sphere! v [state] @deffnx {C Function} scm_random_solid_sphere_x (v, state) Fills vect with inexact real random numbers @@ -3447,6 +4041,7 @@ The sum of the squares of the numbers is returned. @end deffn random:hollow-sphere! +@c snarfed from random.c:495 @deffn {Scheme Procedure} random:hollow-sphere! v [state] @deffnx {C Function} scm_random_hollow_sphere_x (v, state) Fills vect with inexact real random numbers @@ -3458,6 +4053,7 @@ unit n-sphere. @end deffn random:normal-vector! +@c snarfed from random.c:513 @deffn {Scheme Procedure} random:normal-vector! v [state] @deffnx {C Function} scm_random_normal_vector_x (v, state) Fills vect with inexact real random numbers that are @@ -3466,6 +4062,7 @@ independent and standard normally distributed @end deffn random:exp +@c snarfed from random.c:538 @deffn {Scheme Procedure} random:exp [state] @deffnx {C Function} scm_random_exp (state) Return an inexact real in an exponential distribution with mean @@ -3474,6 +4071,7 @@ Return an inexact real in an exponential distribution with mean @end deffn %read-delimited! +@c snarfed from rdelim.c:55 @deffn {Scheme Procedure} %read-delimited! delims str gobble [port [start [end]]] @deffnx {C Function} scm_read_delimited_x (delims, str, gobble, port, start, end) Read characters from @var{port} into @var{str} until one of the @@ -3494,6 +4092,7 @@ a delimiter, this value is @code{#f}. @end deffn %read-line +@c snarfed from rdelim.c:202 @deffn {Scheme Procedure} %read-line [port] @deffnx {C Function} scm_read_line (port) Read a newline-terminated line from @var{port}, allocating storage as @@ -3505,6 +4104,7 @@ delimiter may be either a newline or the @var{eof-object}; if @end deffn write-line +@c snarfed from rdelim.c:255 @deffn {Scheme Procedure} write-line obj [port] @deffnx {C Function} scm_write_line (obj, port) Display @var{obj} and a newline character to @var{port}. If @@ -3517,6 +4117,7 @@ used. This function is equivalent to: @end deffn read-options-interface +@c snarfed from read.c:109 @deffn {Scheme Procedure} read-options-interface [setting] @deffnx {C Function} scm_read_options (setting) Option interface for the read options. Instead of using @@ -3525,6 +4126,7 @@ this procedure directly, use the procedures @code{read-enable}, @end deffn read +@c snarfed from read.c:129 @deffn {Scheme Procedure} read [port] @deffnx {C Function} scm_read (port) Read an s-expression from the input port @var{port}, or from @@ -3533,6 +4135,7 @@ Any whitespace before the next token is discarded. @end deffn read-hash-extend +@c snarfed from read.c:866 @deffn {Scheme Procedure} read-hash-extend chr proc @deffnx {C Function} scm_read_hash_extend (chr, proc) Install the procedure @var{proc} for reading expressions @@ -3543,6 +4146,7 @@ returned will be the return value of @code{read}. @end deffn call-with-dynamic-root +@c snarfed from root.c:320 @deffn {Scheme Procedure} call-with-dynamic-root thunk handler @deffnx {C Function} scm_call_with_dynamic_root (thunk, handler) Evaluate @code{(thunk)} in a new dynamic context, returning its value. @@ -3590,6 +4194,7 @@ be under a new dynamic root.) @end deffn dynamic-root +@c snarfed from root.c:333 @deffn {Scheme Procedure} dynamic-root @deffnx {C Function} scm_dynamic_root () Return an object representing the current dynamic root. @@ -3600,6 +4205,7 @@ in no way depend on this. @end deffn read-string!/partial +@c snarfed from rw.c:101 @deffn {Scheme Procedure} read-string!/partial str [port_or_fdes [start [end]]] @deffnx {C Function} scm_read_string_x_partial (str, port_or_fdes, start, end) Read characters from a port or file descriptor into a @@ -3642,6 +4248,7 @@ end-of-file check. @end deffn write-string/partial +@c snarfed from rw.c:205 @deffn {Scheme Procedure} write-string/partial str [port_or_fdes [start [end]]] @deffnx {C Function} scm_write_string_partial (str, port_or_fdes, start, end) Write characters from a string @var{str} to a port or file @@ -3688,6 +4295,7 @@ return 0 immediately if the request size is 0 bytes. @end deffn sigaction +@c snarfed from scmsigs.c:285 @deffn {Scheme Procedure} sigaction signum [handler [flags [thread]]] @deffnx {C Function} scm_sigaction_for_thread (signum, handler, flags, thread) Install or report the signal handler for a specified signal. @@ -3722,6 +4330,7 @@ structures. @end deffn restore-signals +@c snarfed from scmsigs.c:456 @deffn {Scheme Procedure} restore-signals @deffnx {C Function} scm_restore_signals () Return all signal handlers to the values they had before any call to @@ -3729,6 +4338,7 @@ Return all signal handlers to the values they had before any call to @end deffn alarm +@c snarfed from scmsigs.c:493 @deffn {Scheme Procedure} alarm i @deffnx {C Function} scm_alarm (i) Set a timer to raise a @code{SIGALRM} signal after the specified @@ -3743,6 +4353,7 @@ no previous alarm, the return value is zero. @end deffn setitimer +@c snarfed from scmsigs.c:520 @deffn {Scheme Procedure} setitimer which_timer interval_seconds interval_microseconds value_seconds value_microseconds @deffnx {C Function} scm_setitimer (which_timer, interval_seconds, interval_microseconds, value_seconds, value_microseconds) Set the timer specified by @var{which_timer} according to the given @@ -3763,6 +4374,7 @@ the seconds and microseconds of the timer @code{it_value}. @end deffn getitimer +@c snarfed from scmsigs.c:561 @deffn {Scheme Procedure} getitimer which_timer @deffnx {C Function} scm_getitimer (which_timer) Return information about the timer specified by @var{which_timer} @@ -3779,6 +4391,7 @@ the seconds and microseconds of the timer @code{it_value}. @end deffn pause +@c snarfed from scmsigs.c:588 @deffn {Scheme Procedure} pause @deffnx {C Function} scm_pause () Pause the current process (thread?) until a signal arrives whose @@ -3787,6 +4400,7 @@ handler procedure. The return value is unspecified. @end deffn sleep +@c snarfed from scmsigs.c:601 @deffn {Scheme Procedure} sleep i @deffnx {C Function} scm_sleep (i) Wait for the given number of seconds (an integer) or until a signal @@ -3795,13 +4409,14 @@ of seconds remaining otherwise. @end deffn usleep +@c snarfed from scmsigs.c:610 @deffn {Scheme Procedure} usleep i @deffnx {C Function} scm_usleep (i) -Sleep for I microseconds. @code{usleep} is not available on -all platforms. +Sleep for @var{i} microseconds. @end deffn raise +@c snarfed from scmsigs.c:620 @deffn {Scheme Procedure} raise sig @deffnx {C Function} scm_raise (sig) Sends a specified signal @var{sig} to the current process, where @@ -3809,19 +4424,43 @@ Sends a specified signal @var{sig} to the current process, where @end deffn system +@c snarfed from simpos.c:64 @deffn {Scheme Procedure} system [cmd] @deffnx {C Function} scm_system (cmd) Execute @var{cmd} using the operating system's "command processor". Under Unix this is usually the default shell @code{sh}. The value returned is @var{cmd}'s exit status as -returned by @code{waitpid}, which can be interpreted using the -functions above. +returned by @code{waitpid}, which can be interpreted using +@code{status:exit-val} and friends. If @code{system} is called without arguments, return a boolean indicating whether the command processor is available. @end deffn + system* +@c snarfed from simpos.c:114 +@deffn {Scheme Procedure} system* . args +@deffnx {C Function} scm_system_star (args) +Execute the command indicated by @var{args}. The first element must +be a string indicating the command to be executed, and the remaining +items must be strings representing each of the arguments to that +command. + +This function returns the exit status of the command as provided by +@code{waitpid}. This value can be handled with @code{status:exit-val} +and the related functions. + +@code{system*} is similar to @code{system}, but accepts only one +string per-argument, and performs no shell interpretation. The +command is executed using fork and execlp. Accordingly this function +may be safer than @code{system} in situations where shell +interpretation is not required. + +Example: (system* "echo" "foo" "bar") +@end deffn + getenv +@c snarfed from simpos.c:184 @deffn {Scheme Procedure} getenv nam @deffnx {C Function} scm_getenv (nam) Looks up the string @var{name} in the current environment. The return @@ -3830,6 +4469,7 @@ found, in which case the string @code{VALUE} is returned. @end deffn primitive-exit +@c snarfed from simpos.c:200 @deffn {Scheme Procedure} primitive-exit [status] @deffnx {C Function} scm_primitive_exit (status) Terminate the current process without unwinding the Scheme stack. @@ -3838,6 +4478,7 @@ is @var{status} if supplied, otherwise zero. @end deffn restricted-vector-sort! +@c snarfed from sort.c:291 @deffn {Scheme Procedure} restricted-vector-sort! vec less startpos endpos @deffnx {C Function} scm_restricted_vector_sort_x (vec, less, startpos, endpos) Sort the vector @var{vec}, using @var{less} for comparing @@ -3847,6 +4488,7 @@ is not specified. @end deffn sorted? +@c snarfed from sort.c:321 @deffn {Scheme Procedure} sorted? items less @deffnx {C Function} scm_sorted_p (items, less) Return @code{#t} iff @var{items} is a list or a vector such that @@ -3855,6 +4497,7 @@ applied to all elements i - 1 and i @end deffn merge +@c snarfed from sort.c:393 @deffn {Scheme Procedure} merge alist blist less @deffnx {C Function} scm_merge (alist, blist, less) Merge two already sorted lists into one. @@ -3867,6 +4510,7 @@ Note: this does _not_ accept vectors. @end deffn merge! +@c snarfed from sort.c:508 @deffn {Scheme Procedure} merge! alist blist less @deffnx {C Function} scm_merge_x (alist, blist, less) Takes two lists @var{alist} and @var{blist} such that @@ -3879,6 +4523,7 @@ Note: this does _not_ accept vectors. @end deffn sort! +@c snarfed from sort.c:577 @deffn {Scheme Procedure} sort! items less @deffnx {C Function} scm_sort_x (items, less) Sort the sequence @var{items}, which may be a list or a @@ -3889,6 +4534,7 @@ This is not a stable sort. @end deffn sort +@c snarfed from sort.c:609 @deffn {Scheme Procedure} sort items less @deffnx {C Function} scm_sort (items, less) Sort the sequence @var{items}, which may be a list or a @@ -3897,6 +4543,7 @@ elements. This is not a stable sort. @end deffn stable-sort! +@c snarfed from sort.c:717 @deffn {Scheme Procedure} stable-sort! items less @deffnx {C Function} scm_stable_sort_x (items, less) Sort the sequence @var{items}, which may be a list or a @@ -3907,6 +4554,7 @@ This is a stable sort. @end deffn stable-sort +@c snarfed from sort.c:756 @deffn {Scheme Procedure} stable-sort items less @deffnx {C Function} scm_stable_sort (items, less) Sort the sequence @var{items}, which may be a list or a @@ -3915,6 +4563,7 @@ This is a stable sort. @end deffn sort-list! +@c snarfed from sort.c:797 @deffn {Scheme Procedure} sort-list! items less @deffnx {C Function} scm_sort_list_x (items, less) Sort the list @var{items}, using @var{less} for comparing the @@ -3924,6 +4573,7 @@ This is a stable sort. @end deffn sort-list +@c snarfed from sort.c:812 @deffn {Scheme Procedure} sort-list items less @deffnx {C Function} scm_sort_list (items, less) Sort the list @var{items}, using @var{less} for comparing the @@ -3931,12 +4581,14 @@ list elements. This is a stable sort. @end deffn source-properties +@c snarfed from srcprop.c:152 @deffn {Scheme Procedure} source-properties obj @deffnx {C Function} scm_source_properties (obj) Return the source property association list of @var{obj}. @end deffn set-source-properties! +@c snarfed from srcprop.c:175 @deffn {Scheme Procedure} set-source-properties! obj plist @deffnx {C Function} scm_set_source_properties_x (obj, plist) Install the association list @var{plist} as the source property @@ -3944,6 +4596,7 @@ list for @var{obj}. @end deffn source-property +@c snarfed from srcprop.c:193 @deffn {Scheme Procedure} source-property obj key @deffnx {C Function} scm_source_property (obj, key) Return the source property specified by @var{key} from @@ -3951,6 +4604,7 @@ Return the source property specified by @var{key} from @end deffn set-source-property! +@c snarfed from srcprop.c:224 @deffn {Scheme Procedure} set-source-property! obj key datum @deffnx {C Function} scm_set_source_property_x (obj, key, datum) Set the source property of object @var{obj}, which is specified by @@ -3958,12 +4612,14 @@ Set the source property of object @var{obj}, which is specified by @end deffn stack? +@c snarfed from stacks.c:384 @deffn {Scheme Procedure} stack? obj @deffnx {C Function} scm_stack_p (obj) Return @code{#t} if @var{obj} is a calling stack. @end deffn make-stack +@c snarfed from stacks.c:415 @deffn {Scheme Procedure} make-stack obj . args @deffnx {C Function} scm_make_stack (obj, args) Create a new stack. If @var{obj} is @code{#t}, the current @@ -3997,30 +4653,35 @@ taken as 0. @end deffn stack-id +@c snarfed from stacks.c:507 @deffn {Scheme Procedure} stack-id stack @deffnx {C Function} scm_stack_id (stack) Return the identifier given to @var{stack} by @code{start-stack}. @end deffn stack-ref +@c snarfed from stacks.c:548 @deffn {Scheme Procedure} stack-ref stack index @deffnx {C Function} scm_stack_ref (stack, index) Return the @var{index}'th frame from @var{stack}. @end deffn stack-length +@c snarfed from stacks.c:561 @deffn {Scheme Procedure} stack-length stack @deffnx {C Function} scm_stack_length (stack) Return the length of @var{stack}. @end deffn frame? +@c snarfed from stacks.c:574 @deffn {Scheme Procedure} frame? obj @deffnx {C Function} scm_frame_p (obj) Return @code{#t} if @var{obj} is a stack frame. @end deffn last-stack-frame +@c snarfed from stacks.c:585 @deffn {Scheme Procedure} last-stack-frame obj @deffnx {C Function} scm_last_stack_frame (obj) Return a stack which consists of a single frame, which is the @@ -4029,18 +4690,21 @@ debug object or a continuation. @end deffn frame-number +@c snarfed from stacks.c:627 @deffn {Scheme Procedure} frame-number frame @deffnx {C Function} scm_frame_number (frame) Return the frame number of @var{frame}. @end deffn frame-source +@c snarfed from stacks.c:637 @deffn {Scheme Procedure} frame-source frame @deffnx {C Function} scm_frame_source (frame) Return the source of @var{frame}. @end deffn frame-procedure +@c snarfed from stacks.c:648 @deffn {Scheme Procedure} frame-procedure frame @deffnx {C Function} scm_frame_procedure (frame) Return the procedure for @var{frame}, or @code{#f} if no @@ -4048,12 +4712,14 @@ procedure is associated with @var{frame}. @end deffn frame-arguments +@c snarfed from stacks.c:660 @deffn {Scheme Procedure} frame-arguments frame @deffnx {C Function} scm_frame_arguments (frame) Return the arguments of @var{frame}. @end deffn frame-previous +@c snarfed from stacks.c:671 @deffn {Scheme Procedure} frame-previous frame @deffnx {C Function} scm_frame_previous (frame) Return the previous frame of @var{frame}, or @code{#f} if @@ -4061,6 +4727,7 @@ Return the previous frame of @var{frame}, or @code{#f} if @end deffn frame-next +@c snarfed from stacks.c:687 @deffn {Scheme Procedure} frame-next frame @deffnx {C Function} scm_frame_next (frame) Return the next frame of @var{frame}, or @code{#f} if @@ -4068,30 +4735,35 @@ Return the next frame of @var{frame}, or @code{#f} if @end deffn frame-real? +@c snarfed from stacks.c:702 @deffn {Scheme Procedure} frame-real? frame @deffnx {C Function} scm_frame_real_p (frame) Return @code{#t} if @var{frame} is a real frame. @end deffn frame-procedure? +@c snarfed from stacks.c:712 @deffn {Scheme Procedure} frame-procedure? frame @deffnx {C Function} scm_frame_procedure_p (frame) Return @code{#t} if a procedure is associated with @var{frame}. @end deffn frame-evaluating-args? +@c snarfed from stacks.c:722 @deffn {Scheme Procedure} frame-evaluating-args? frame @deffnx {C Function} scm_frame_evaluating_args_p (frame) Return @code{#t} if @var{frame} contains evaluated arguments. @end deffn frame-overflow? +@c snarfed from stacks.c:732 @deffn {Scheme Procedure} frame-overflow? frame @deffnx {C Function} scm_frame_overflow_p (frame) Return @code{#t} if @var{frame} is an overflow frame. @end deffn get-internal-real-time +@c snarfed from stime.c:117 @deffn {Scheme Procedure} get-internal-real-time @deffnx {C Function} scm_get_internal_real_time () Return the number of time units since the interpreter was @@ -4099,6 +4771,7 @@ started. @end deffn times +@c snarfed from stime.c:164 @deffn {Scheme Procedure} times @deffnx {C Function} scm_times () Return an object with information about real and processor @@ -4125,6 +4798,7 @@ terminated child processes. @end deffn get-internal-run-time +@c snarfed from stime.c:196 @deffn {Scheme Procedure} get-internal-run-time @deffnx {C Function} scm_get_internal_run_time () Return the number of time units of processor time used by the @@ -4133,6 +4807,7 @@ included but subprocesses are not. @end deffn current-time +@c snarfed from stime.c:213 @deffn {Scheme Procedure} current-time @deffnx {C Function} scm_current_time () Return the number of seconds since 1970-01-01 00:00:00 UTC, @@ -4140,6 +4815,7 @@ excluding leap seconds. @end deffn gettimeofday +@c snarfed from stime.c:231 @deffn {Scheme Procedure} gettimeofday @deffnx {C Function} scm_gettimeofday () Return a pair containing the number of seconds and microseconds @@ -4149,6 +4825,7 @@ operating system. @end deffn localtime +@c snarfed from stime.c:335 @deffn {Scheme Procedure} localtime time [zone] @deffnx {C Function} scm_localtime (time, zone) Return an object representing the broken down components of @@ -4159,6 +4836,7 @@ optionally specified by @var{zone} (a string), otherwise the @end deffn gmtime +@c snarfed from stime.c:420 @deffn {Scheme Procedure} gmtime time @deffnx {C Function} scm_gmtime (time) Return an object representing the broken down components of @@ -4167,6 +4845,7 @@ Return an object representing the broken down components of @end deffn mktime +@c snarfed from stime.c:498 @deffn {Scheme Procedure} mktime sbd_time [zone] @deffnx {C Function} scm_mktime (sbd_time, zone) @var{bd-time} is an object representing broken down time and @code{zone} @@ -4180,6 +4859,7 @@ as @var{bd-time} but with normalized values. @end deffn tzset +@c snarfed from stime.c:581 @deffn {Scheme Procedure} tzset @deffnx {C Function} scm_tzset () Initialize the timezone from the TZ environment variable @@ -4189,6 +4869,7 @@ timezone. @end deffn strftime +@c snarfed from stime.c:598 @deffn {Scheme Procedure} strftime format stime @deffnx {C Function} scm_strftime (format, stime) Formats a time specification @var{time} using @var{template}. @var{time} @@ -4201,6 +4882,7 @@ is the formatted string. @end deffn strptime +@c snarfed from stime.c:696 @deffn {Scheme Procedure} strptime format string @deffnx {C Function} scm_strptime (format, string) Performs the reverse action to @code{strftime}, parsing @@ -4216,17 +4898,20 @@ which were used for the conversion. @end deffn string? +@c snarfed from strings.c:481 @deffn {Scheme Procedure} string? obj @deffnx {C Function} scm_string_p (obj) Return @code{#t} if @var{obj} is a string, else @code{#f}. @end deffn list->string +@c snarfed from strings.c:489 @deffn {Scheme Procedure} list->string implemented by the C function "scm_string" @end deffn string +@c snarfed from strings.c:495 @deffn {Scheme Procedure} string . chrs @deffnx {Scheme Procedure} list->string chrs @deffnx {C Function} scm_string (chrs) @@ -4235,6 +4920,7 @@ Return a newly allocated string composed of the arguments, @end deffn make-string +@c snarfed from strings.c:533 @deffn {Scheme Procedure} make-string k [chr] @deffnx {C Function} scm_make_string (k, chr) Return a newly allocated string of @@ -4244,12 +4930,14 @@ of the @var{string} are unspecified. @end deffn string-length +@c snarfed from strings.c:559 @deffn {Scheme Procedure} string-length string @deffnx {C Function} scm_string_length (string) Return the number of characters in @var{string}. @end deffn string-ref +@c snarfed from strings.c:578 @deffn {Scheme Procedure} string-ref str k @deffnx {C Function} scm_string_ref (str, k) Return character @var{k} of @var{str} using zero-origin @@ -4257,6 +4945,7 @@ indexing. @var{k} must be a valid index of @var{str}. @end deffn string-set! +@c snarfed from strings.c:601 @deffn {Scheme Procedure} string-set! str k chr @deffnx {C Function} scm_string_set_x (str, k, chr) Store @var{chr} in element @var{k} of @var{str} and return @@ -4265,6 +4954,7 @@ an unspecified value. @var{k} must be a valid index of @end deffn substring +@c snarfed from strings.c:637 @deffn {Scheme Procedure} substring str start [end] @deffnx {C Function} scm_substring (str, start, end) Return a newly allocated string formed from the characters @@ -4276,7 +4966,34 @@ exact integers satisfying: 0 <= @var{start} <= @var{end} <= (string-length @var{str}). @end deffn + substring/copy +@c snarfed from strings.c:660 +@deffn {Scheme Procedure} substring/copy str start [end] +@deffnx {C Function} scm_substring_copy (str, start, end) +Return a newly allocated string formed from the characters +of @var{str} beginning with index @var{start} (inclusive) and +ending with index @var{end} (exclusive). +@var{str} must be a string, @var{start} and @var{end} must be +exact integers satisfying: + +0 <= @var{start} <= @var{end} <= (string-length @var{str}). +@end deffn + + substring/shared +@c snarfed from strings.c:683 +@deffn {Scheme Procedure} substring/shared str start [end] +@deffnx {C Function} scm_substring_shared (str, start, end) +Return string that indirectly refers to the characters +of @var{str} beginning with index @var{start} (inclusive) and +ending with index @var{end} (exclusive). +@var{str} must be a string, @var{start} and @var{end} must be +exact integers satisfying: + +0 <= @var{start} <= @var{end} <= (string-length @var{str}). +@end deffn + string-append +@c snarfed from strings.c:702 @deffn {Scheme Procedure} string-append . args @deffnx {C Function} scm_string_append (args) Return a newly allocated string whose characters form the @@ -4284,6 +5001,7 @@ concatenation of the given strings, @var{args}. @end deffn string-index +@c snarfed from strop.c:113 @deffn {Scheme Procedure} string-index str chr [frm [to]] @deffnx {C Function} scm_string_index (str, chr, frm, to) Return the index of the first occurrence of @var{chr} in @@ -4305,6 +5023,7 @@ procedure essentially implements the @code{index} or @end deffn string-rindex +@c snarfed from strop.c:143 @deffn {Scheme Procedure} string-rindex str chr [frm [to]] @deffnx {C Function} scm_string_rindex (str, chr, frm, to) Like @code{string-index}, but search from the right of the @@ -4325,6 +5044,7 @@ the C library. @end deffn substring-move! +@c snarfed from strop.c:163 @deffn {Scheme Procedure} substring-move! str1 start1 end1 str2 start2 @deffnx {C Function} scm_substring_move_x (str1, start1, end1, str2, start2) Copy the substring of @var{str1} bounded by @var{start1} and @var{end1} @@ -4333,6 +5053,7 @@ into @var{str2} beginning at position @var{start2}. @end deffn substring-fill! +@c snarfed from strop.c:198 @deffn {Scheme Procedure} substring-fill! str start end fill @deffnx {C Function} scm_substring_fill_x (str, start, end, fill) Change every character in @var{str} between @var{start} and @@ -4347,6 +5068,7 @@ y @end deffn string-null? +@c snarfed from strop.c:227 @deffn {Scheme Procedure} string-null? str @deffnx {C Function} scm_string_null_p (str) Return @code{#t} if @var{str}'s length is zero, and @@ -4359,6 +5081,7 @@ y @result{} "foo" @end deffn string->list +@c snarfed from strop.c:241 @deffn {Scheme Procedure} string->list str @deffnx {C Function} scm_string_to_list (str) Return a newly allocated list of the characters that make up @@ -4368,12 +5091,14 @@ concerned. @end deffn string-copy +@c snarfed from strop.c:274 @deffn {Scheme Procedure} string-copy str @deffnx {C Function} scm_string_copy (str) Return a newly allocated copy of the given @var{string}. @end deffn string-fill! +@c snarfed from strop.c:285 @deffn {Scheme Procedure} string-fill! str chr @deffnx {C Function} scm_string_fill_x (str, chr) Store @var{char} in every element of the given @var{string} and @@ -4381,6 +5106,7 @@ return an unspecified value. @end deffn string-upcase! +@c snarfed from strop.c:327 @deffn {Scheme Procedure} string-upcase! str @deffnx {C Function} scm_string_upcase_x (str) Destructively upcase every character in @var{str} and return @@ -4393,6 +5119,7 @@ y @result{} "ARRDEFG" @end deffn string-upcase +@c snarfed from strop.c:340 @deffn {Scheme Procedure} string-upcase str @deffnx {C Function} scm_string_upcase (str) Return a freshly allocated string containing the characters of @@ -4400,6 +5127,7 @@ Return a freshly allocated string containing the characters of @end deffn string-downcase! +@c snarfed from strop.c:376 @deffn {Scheme Procedure} string-downcase! str @deffnx {C Function} scm_string_downcase_x (str) Destructively downcase every character in @var{str} and return @@ -4412,6 +5140,7 @@ y @result{} "arrdefg" @end deffn string-downcase +@c snarfed from strop.c:389 @deffn {Scheme Procedure} string-downcase str @deffnx {C Function} scm_string_downcase (str) Return a freshly allocation string containing the characters in @@ -4419,6 +5148,7 @@ Return a freshly allocation string containing the characters in @end deffn string-capitalize! +@c snarfed from strop.c:441 @deffn {Scheme Procedure} string-capitalize! str @deffnx {C Function} scm_string_capitalize_x (str) Upcase the first character of every word in @var{str} @@ -4432,6 +5162,7 @@ y @result{} "Hello World" @end deffn string-capitalize +@c snarfed from strop.c:455 @deffn {Scheme Procedure} string-capitalize str @deffnx {C Function} scm_string_capitalize (str) Return a freshly allocated string with the characters in @@ -4440,6 +5171,7 @@ capitalized. @end deffn string-split +@c snarfed from strop.c:484 @deffn {Scheme Procedure} string-split str chr @deffnx {C Function} scm_string_split (str, chr) Split the string @var{str} into the a list of the substrings delimited @@ -4463,6 +5195,7 @@ result list. @end deffn string-ci->symbol +@c snarfed from strop.c:520 @deffn {Scheme Procedure} string-ci->symbol str @deffnx {C Function} scm_string_ci_to_symbol (str) Return the symbol whose name is @var{str}. @var{str} is @@ -4471,6 +5204,7 @@ is currently reading symbols case-insensitively. @end deffn string=? +@c snarfed from strorder.c:38 @deffn {Scheme Procedure} string=? s1 s2 Lexicographic equality predicate; return @code{#t} if the two strings are the same length and contain the same characters in @@ -4483,6 +5217,7 @@ characters. @end deffn string-ci=? +@c snarfed from strorder.c:77 @deffn {Scheme Procedure} string-ci=? s1 s2 Case-insensitive string equality predicate; return @code{#t} if the two strings are the same length and their component @@ -4491,30 +5226,35 @@ return @code{#f}. @end deffn string? +@c snarfed from strorder.c:168 @deffn {Scheme Procedure} string>? s1 s2 Lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than @var{s2}. @end deffn string>=? +@c snarfed from strorder.c:182 @deffn {Scheme Procedure} string>=? s1 s2 Lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than or equal to @var{s2}. @end deffn string-ci? +@c snarfed from strorder.c:253 @deffn {Scheme Procedure} string-ci>? s1 s2 Case insensitive lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than @@ -4536,6 +5278,7 @@ Case insensitive lexicographic ordering predicate; return @end deffn string-ci>=? +@c snarfed from strorder.c:268 @deffn {Scheme Procedure} string-ci>=? s1 s2 Case insensitive lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than or @@ -4543,6 +5286,7 @@ equal to @var{s2} regardless of case. @end deffn object->string +@c snarfed from strports.c:332 @deffn {Scheme Procedure} object->string obj [printer] @deffnx {C Function} scm_object_to_string (obj, printer) Return a Scheme string obtained by printing @var{obj}. @@ -4551,6 +5295,7 @@ argument @var{printer} (default: @code{write}). @end deffn call-with-output-string +@c snarfed from strports.c:356 @deffn {Scheme Procedure} call-with-output-string proc @deffnx {C Function} scm_call_with_output_string (proc) Calls the one-argument procedure @var{proc} with a newly created output @@ -4559,6 +5304,7 @@ written into the port is returned. @end deffn call-with-input-string +@c snarfed from strports.c:375 @deffn {Scheme Procedure} call-with-input-string string proc @deffnx {C Function} scm_call_with_input_string (string, proc) Calls the one-argument procedure @var{proc} with a newly @@ -4567,6 +5313,7 @@ read. The value yielded by the @var{proc} is returned. @end deffn open-input-string +@c snarfed from strports.c:388 @deffn {Scheme Procedure} open-input-string str @deffnx {C Function} scm_open_input_string (str) Take a string and return an input port that delivers characters @@ -4576,6 +5323,7 @@ by the garbage collector if it becomes inaccessible. @end deffn open-output-string +@c snarfed from strports.c:402 @deffn {Scheme Procedure} open-output-string @deffnx {C Function} scm_open_output_string () Return an output port that will accumulate characters for @@ -4586,6 +5334,7 @@ inaccessible. @end deffn get-output-string +@c snarfed from strports.c:419 @deffn {Scheme Procedure} get-output-string port @deffnx {C Function} scm_get_output_string (port) Given an output port created by @code{open-output-string}, @@ -4594,6 +5343,7 @@ output to the port so far. @end deffn eval-string +@c snarfed from strports.c:488 @deffn {Scheme Procedure} eval-string string [module] @deffnx {C Function} scm_eval_string_in_module (string, module) Evaluate @var{string} as the text representation of a Scheme @@ -4606,6 +5356,7 @@ procedure returns. @end deffn make-struct-layout +@c snarfed from struct.c:55 @deffn {Scheme Procedure} make-struct-layout fields @deffnx {C Function} scm_make_struct_layout (fields) Return a new structure layout object. @@ -4621,6 +5372,7 @@ indicate that the field is a tail-array. @end deffn struct? +@c snarfed from struct.c:222 @deffn {Scheme Procedure} struct? x @deffnx {C Function} scm_struct_p (x) Return @code{#t} iff @var{x} is a structure object, else @@ -4628,12 +5380,14 @@ Return @code{#t} iff @var{x} is a structure object, else @end deffn struct-vtable? +@c snarfed from struct.c:231 @deffn {Scheme Procedure} struct-vtable? x @deffnx {C Function} scm_struct_vtable_p (x) Return @code{#t} iff @var{x} is a vtable structure. @end deffn make-struct +@c snarfed from struct.c:417 @deffn {Scheme Procedure} make-struct vtable tail_array_size . init @deffnx {C Function} scm_make_struct (vtable, tail_array_size, init) Create a new structure. @@ -4664,6 +5418,7 @@ For more information, see the documentation for @code{make-vtable-vtable}. @end deffn make-vtable-vtable +@c snarfed from struct.c:501 @deffn {Scheme Procedure} make-vtable-vtable user_fields tail_array_size . init @deffnx {C Function} scm_make_vtable_vtable (user_fields, tail_array_size, init) Return a new, self-describing vtable structure. @@ -4725,6 +5480,7 @@ ball @result{} # @end deffn struct-ref +@c snarfed from struct.c:541 @deffn {Scheme Procedure} struct-ref handle pos @deffnx {Scheme Procedure} struct-set! struct n value @deffnx {C Function} scm_struct_ref (handle, pos) @@ -4737,6 +5493,7 @@ integer value small enough to fit in one machine word. @end deffn struct-set! +@c snarfed from struct.c:620 @deffn {Scheme Procedure} struct-set! handle pos val @deffnx {C Function} scm_struct_set_x (handle, pos, val) Set the slot of the structure @var{handle} with index @var{pos} @@ -4745,30 +5502,35 @@ to. @end deffn struct-vtable +@c snarfed from struct.c:691 @deffn {Scheme Procedure} struct-vtable handle @deffnx {C Function} scm_struct_vtable (handle) Return the vtable structure that describes the type of @var{struct}. @end deffn struct-vtable-tag +@c snarfed from struct.c:702 @deffn {Scheme Procedure} struct-vtable-tag handle @deffnx {C Function} scm_struct_vtable_tag (handle) Return the vtable tag of the structure @var{handle}. @end deffn struct-vtable-name +@c snarfed from struct.c:741 @deffn {Scheme Procedure} struct-vtable-name vtable @deffnx {C Function} scm_struct_vtable_name (vtable) Return the name of the vtable @var{vtable}. @end deffn set-struct-vtable-name! +@c snarfed from struct.c:751 @deffn {Scheme Procedure} set-struct-vtable-name! vtable name @deffnx {C Function} scm_set_struct_vtable_name_x (vtable, name) Set the name of the vtable @var{vtable} to @var{name}. @end deffn symbol? +@c snarfed from symbols.c:156 @deffn {Scheme Procedure} symbol? obj @deffnx {C Function} scm_symbol_p (obj) Return @code{#t} if @var{obj} is a symbol, otherwise return @@ -4776,6 +5538,7 @@ Return @code{#t} if @var{obj} is a symbol, otherwise return @end deffn symbol-interned? +@c snarfed from symbols.c:166 @deffn {Scheme Procedure} symbol-interned? symbol @deffnx {C Function} scm_symbol_interned_p (symbol) Return @code{#t} if @var{symbol} is interned, otherwise return @@ -4783,12 +5546,14 @@ Return @code{#t} if @var{symbol} is interned, otherwise return @end deffn make-symbol +@c snarfed from symbols.c:178 @deffn {Scheme Procedure} make-symbol name @deffnx {C Function} scm_make_symbol (name) Return a new uninterned symbol with the name @var{name}. The returned symbol is guaranteed to be unique and future calls to @code{string->symbol} will not return it. @end deffn symbol->string +@c snarfed from symbols.c:210 @deffn {Scheme Procedure} symbol->string s @deffnx {C Function} scm_symbol_to_string (s) Return the name of @var{symbol} as a string. If the symbol was @@ -4817,6 +5582,7 @@ standard case is lower case: @end deffn string->symbol +@c snarfed from symbols.c:240 @deffn {Scheme Procedure} string->symbol string @deffnx {C Function} scm_string_to_symbol (string) Return the symbol whose name is @var{string}. This procedure @@ -4842,6 +5608,7 @@ standard case is lower case: @end deffn gensym +@c snarfed from symbols.c:256 @deffn {Scheme Procedure} gensym [prefix] @deffnx {C Function} scm_gensym (prefix) Create a new symbol with a name constructed from a prefix and @@ -4852,36 +5619,155 @@ resetting the counter. @end deffn symbol-hash +@c snarfed from symbols.c:282 @deffn {Scheme Procedure} symbol-hash symbol @deffnx {C Function} scm_symbol_hash (symbol) Return a hash value for @var{symbol}. @end deffn symbol-fref +@c snarfed from symbols.c:292 @deffn {Scheme Procedure} symbol-fref s @deffnx {C Function} scm_symbol_fref (s) Return the contents of @var{symbol}'s @dfn{function slot}. @end deffn symbol-pref +@c snarfed from symbols.c:303 @deffn {Scheme Procedure} symbol-pref s @deffnx {C Function} scm_symbol_pref (s) Return the @dfn{property list} currently associated with @var{symbol}. @end deffn symbol-fset! +@c snarfed from symbols.c:314 @deffn {Scheme Procedure} symbol-fset! s val @deffnx {C Function} scm_symbol_fset_x (s, val) Change the binding of @var{symbol}'s function slot. @end deffn symbol-pset! +@c snarfed from symbols.c:326 @deffn {Scheme Procedure} symbol-pset! s val @deffnx {C Function} scm_symbol_pset_x (s, val) Change the binding of @var{symbol}'s property slot. @end deffn + call-with-new-thread +@c snarfed from threads.c:428 +@deffn {Scheme Procedure} call-with-new-thread thunk handler +@deffnx {C Function} scm_call_with_new_thread (thunk, handler) +Evaluate @code{(@var{thunk})} in a new thread, and new dynamic context, returning a new thread object representing the thread. If an error occurs during evaluation, call error-thunk, passing it an error code describing the condition. If this happens, the error-thunk is called outside the scope of the new root -- it is called in the same dynamic context in which with-new-thread was evaluated, but not in the callers thread. All the evaluation rules for dynamic roots apply to threads. +@end deffn + + yield +@c snarfed from threads.c:443 +@deffn {Scheme Procedure} yield +@deffnx {C Function} scm_yield () +Move the calling thread to the end of the scheduling queue. +@end deffn + + join-thread +@c snarfed from threads.c:453 +@deffn {Scheme Procedure} join-thread thread +@deffnx {C Function} scm_join_thread (thread) +Suspend execution of the calling thread until the target @var{thread} terminates, unless the target @var{thread} has already terminated. +@end deffn + + make-fair-mutex +@c snarfed from threads.c:508 +@deffn {Scheme Procedure} make-fair-mutex +@deffnx {C Function} scm_make_fair_mutex () +Create a new fair mutex object. +@end deffn + + make-fair-condition-variable +@c snarfed from threads.c:628 +@deffn {Scheme Procedure} make-fair-condition-variable +@deffnx {C Function} scm_make_fair_condition_variable () +Make a new fair condition variable. +@end deffn + + make-mutex +@c snarfed from threads.c:691 +@deffn {Scheme Procedure} make-mutex +@deffnx {C Function} scm_make_mutex () +Create a new mutex object. +@end deffn + + lock-mutex +@c snarfed from threads.c:707 +@deffn {Scheme Procedure} lock-mutex mx +@deffnx {C Function} scm_lock_mutex (mx) +Lock @var{mutex}. If the mutex is already locked, the calling thread blocks until the mutex becomes available. The function returns when the calling thread owns the lock on @var{mutex}. Locking a mutex that a thread already owns will succeed right away and will not block the thread. That is, Guile's mutexes are @emph{recursive}. +@end deffn + + try-mutex +@c snarfed from threads.c:733 +@deffn {Scheme Procedure} try-mutex mx +@deffnx {C Function} scm_try_mutex (mx) +Try to lock @var{mutex}. If the mutex is already locked by someone else, return @code{#f}. Else lock the mutex and return @code{#t}. +@end deffn + + unlock-mutex +@c snarfed from threads.c:768 +@deffn {Scheme Procedure} unlock-mutex mx +@deffnx {C Function} scm_unlock_mutex (mx) +Unlocks @var{mutex} if the calling thread owns the lock on @var{mutex}. Calling unlock-mutex on a mutex not owned by the current thread results in undefined behaviour. Once a mutex has been unlocked, one thread blocked on @var{mutex} is awakened and grabs the mutex lock. Every call to @code{lock-mutex} by this thread must be matched with a call to @code{unlock-mutex}. Only the last call to @code{unlock-mutex} will actually unlock the mutex. +@end deffn + + make-condition-variable +@c snarfed from threads.c:808 +@deffn {Scheme Procedure} make-condition-variable +@deffnx {C Function} scm_make_condition_variable () +Make a new condition variable. +@end deffn + + wait-condition-variable +@c snarfed from threads.c:827 +@deffn {Scheme Procedure} wait-condition-variable cv mx [t] +@deffnx {C Function} scm_timed_wait_condition_variable (cv, mx, t) +Wait until @var{cond-var} has been signalled. While waiting, @var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and is locked again when this function returns. When @var{time} is given, it specifies a point in time where the waiting should be aborted. It can be either a integer as returned by @code{current-time} or a pair as returned by @code{gettimeofday}. When the waiting is aborted the mutex is locked and @code{#f} is returned. When the condition variable is in fact signalled, the mutex is also locked and @code{#t} is returned. +@end deffn + + signal-condition-variable +@c snarfed from threads.c:884 +@deffn {Scheme Procedure} signal-condition-variable cv +@deffnx {C Function} scm_signal_condition_variable (cv) +Wake up one thread that is waiting for @var{cv} +@end deffn + + broadcast-condition-variable +@c snarfed from threads.c:901 +@deffn {Scheme Procedure} broadcast-condition-variable cv +@deffnx {C Function} scm_broadcast_condition_variable (cv) +Wake up all threads that are waiting for @var{cv}. +@end deffn + + current-thread +@c snarfed from threads.c:1103 +@deffn {Scheme Procedure} current-thread +@deffnx {C Function} scm_current_thread () +Return the thread that called this function. +@end deffn + + all-threads +@c snarfed from threads.c:1112 +@deffn {Scheme Procedure} all-threads +@deffnx {C Function} scm_all_threads () +Return a list of all threads. +@end deffn + + thread-exited? +@c snarfed from threads.c:1127 +@deffn {Scheme Procedure} thread-exited? thread +@deffnx {C Function} scm_thread_exited_p (thread) +Return @code{#t} iff @var{thread} has exited. + +@end deffn + catch +@c snarfed from throw.c:500 @deffn {Scheme Procedure} catch key thunk handler @deffnx {C Function} scm_catch (key, thunk, handler) Invoke @var{thunk} in the dynamic context of @var{handler} for @@ -4905,6 +5791,7 @@ match this call to @code{catch}. @end deffn lazy-catch +@c snarfed from throw.c:528 @deffn {Scheme Procedure} lazy-catch key thunk handler @deffnx {C Function} scm_lazy_catch (key, thunk, handler) This behaves exactly like @code{catch}, except that it does @@ -4914,6 +5801,7 @@ it must throw to another catch, or otherwise exit non-locally. @end deffn throw +@c snarfed from throw.c:561 @deffn {Scheme Procedure} throw key . args @deffnx {C Function} scm_throw (key, args) Invoke the catch form matching @var{key}, passing @var{args} to the @@ -4926,6 +5814,7 @@ If there is no handler at all, Guile prints an error and then exits. @end deffn values +@c snarfed from values.c:53 @deffn {Scheme Procedure} values . args @deffnx {C Function} scm_values (args) Delivers all of its arguments to its continuation. Except for @@ -4936,18 +5825,21 @@ were not created by @code{call-with-values} is unspecified. @end deffn make-variable +@c snarfed from variable.c:52 @deffn {Scheme Procedure} make-variable init @deffnx {C Function} scm_make_variable (init) Return a variable initialized to value @var{init}. @end deffn make-undefined-variable +@c snarfed from variable.c:62 @deffn {Scheme Procedure} make-undefined-variable @deffnx {C Function} scm_make_undefined_variable () Return a variable that is initially unbound. @end deffn variable? +@c snarfed from variable.c:73 @deffn {Scheme Procedure} variable? obj @deffnx {C Function} scm_variable_p (obj) Return @code{#t} iff @var{obj} is a variable object, else @@ -4955,6 +5847,7 @@ return @code{#f}. @end deffn variable-ref +@c snarfed from variable.c:85 @deffn {Scheme Procedure} variable-ref var @deffnx {C Function} scm_variable_ref (var) Dereference @var{var} and return its value. @@ -4963,6 +5856,7 @@ and @code{make-undefined-variable}. @end deffn variable-set! +@c snarfed from variable.c:101 @deffn {Scheme Procedure} variable-set! var val @deffnx {C Function} scm_variable_set_x (var, val) Set the value of the variable @var{var} to @var{val}. @@ -4971,6 +5865,7 @@ value. Return an unspecified value. @end deffn variable-bound? +@c snarfed from variable.c:113 @deffn {Scheme Procedure} variable-bound? var @deffnx {C Function} scm_variable_bound_p (var) Return @code{#t} iff @var{var} is bound to a value. @@ -4978,6 +5873,7 @@ Throws an error if @var{var} is not a variable object. @end deffn vector? +@c snarfed from vectors.c:35 @deffn {Scheme Procedure} vector? obj @deffnx {C Function} scm_vector_p (obj) Return @code{#t} if @var{obj} is a vector, otherwise return @@ -4985,11 +5881,13 @@ Return @code{#t} if @var{obj} is a vector, otherwise return @end deffn list->vector +@c snarfed from vectors.c:52 @deffn {Scheme Procedure} list->vector implemented by the C function "scm_vector" @end deffn vector +@c snarfed from vectors.c:69 @deffn {Scheme Procedure} vector . l @deffnx {Scheme Procedure} list->vector l @deffnx {C Function} scm_vector (l) @@ -5002,6 +5900,7 @@ given arguments. Analogous to @code{list}. @end deffn make-vector +@c snarfed from vectors.c:163 @deffn {Scheme Procedure} make-vector k [fill] @deffnx {C Function} scm_make_vector (k, fill) Return a newly allocated vector of @var{k} elements. If a @@ -5011,6 +5910,7 @@ unspecified. @end deffn vector->list +@c snarfed from vectors.c:211 @deffn {Scheme Procedure} vector->list v @deffnx {C Function} scm_vector_to_list (v) Return a newly allocated list composed of the elements of @var{v}. @@ -5022,6 +5922,7 @@ Return a newly allocated list composed of the elements of @var{v}. @end deffn vector-fill! +@c snarfed from vectors.c:228 @deffn {Scheme Procedure} vector-fill! v fill @deffnx {C Function} scm_vector_fill_x (v, fill) Store @var{fill} in every position of @var{vector}. The value @@ -5029,6 +5930,7 @@ returned by @code{vector-fill!} is unspecified. @end deffn vector-move-left! +@c snarfed from vectors.c:260 @deffn {Scheme Procedure} vector-move-left! vec1 start1 end1 vec2 start2 @deffnx {C Function} scm_vector_move_left_x (vec1, start1, end1, vec2, start2) Copy elements from @var{vec1}, positions @var{start1} to @var{end1}, @@ -5042,6 +5944,7 @@ same vector, @code{vector-move-left!} is usually appropriate when @end deffn vector-move-right! +@c snarfed from vectors.c:290 @deffn {Scheme Procedure} vector-move-right! vec1 start1 end1 vec2 start2 @deffnx {C Function} scm_vector_move_right_x (vec1, start1, end1, vec2, start2) Copy elements from @var{vec1}, positions @var{start1} to @var{end1}, @@ -5055,6 +5958,7 @@ same vector, @code{vector-move-right!} is usually appropriate when @end deffn major-version +@c snarfed from version.c:35 @deffn {Scheme Procedure} major-version @deffnx {C Function} scm_major_version () Return a string containing Guile's major version number. @@ -5062,6 +5966,7 @@ E.g., the 1 in "1.6.5". @end deffn minor-version +@c snarfed from version.c:48 @deffn {Scheme Procedure} minor-version @deffnx {C Function} scm_minor_version () Return a string containing Guile's minor version number. @@ -5069,6 +5974,7 @@ E.g., the 6 in "1.6.5". @end deffn micro-version +@c snarfed from version.c:61 @deffn {Scheme Procedure} micro-version @deffnx {C Function} scm_micro_version () Return a string containing Guile's micro version number. @@ -5076,6 +5982,7 @@ E.g., the 5 in "1.6.5". @end deffn version +@c snarfed from version.c:83 @deffn {Scheme Procedure} version @deffnx {Scheme Procedure} major-version @deffnx {Scheme Procedure} minor-version @@ -5092,7 +5999,22 @@ or micro version number, respectively. @end lisp @end deffn + effective-version +@c snarfed from version.c:113 +@deffn {Scheme Procedure} effective-version +@deffnx {C Function} scm_effective_version () +Return a string describing Guile's effective version number. +@lisp +(version) @result{} "1.6.0" +(effective-version) @result{} "1.6" +(major-version) @result{} "1" +(minor-version) @result{} "6" +(micro-version) @result{} "0" +@end lisp +@end deffn + make-soft-port +@c snarfed from vports.c:183 @deffn {Scheme Procedure} make-soft-port pv modes @deffnx {C Function} scm_make_soft_port (pv, modes) Return a port capable of receiving or delivering characters as @@ -5142,6 +6064,7 @@ For example: @end deffn make-weak-vector +@c snarfed from weaks.c:117 @deffn {Scheme Procedure} make-weak-vector size [fill] @deffnx {C Function} scm_make_weak_vector (size, fill) Return a weak vector with @var{size} elements. If the optional @@ -5151,11 +6074,13 @@ empty list. @end deffn list->weak-vector +@c snarfed from weaks.c:125 @deffn {Scheme Procedure} list->weak-vector implemented by the C function "scm_weak_vector" @end deffn weak-vector +@c snarfed from weaks.c:133 @deffn {Scheme Procedure} weak-vector . l @deffnx {Scheme Procedure} list->weak-vector l @deffnx {C Function} scm_weak_vector (l) @@ -5166,17 +6091,19 @@ the same way @code{list->vector} would. @end deffn weak-vector? +@c snarfed from weaks.c:164 @deffn {Scheme Procedure} weak-vector? obj @deffnx {C Function} scm_weak_vector_p (obj) Return @code{#t} if @var{obj} is a weak vector. Note that all weak hashes are also weak vectors. @end deffn - make-weak-key-hash-table -@deffn {Scheme Procedure} make-weak-key-hash-table size -@deffnx {Scheme Procedure} make-weak-value-hash-table size -@deffnx {Scheme Procedure} make-doubly-weak-hash-table size -@deffnx {C Function} scm_make_weak_key_hash_table (size) + make-weak-key-alist-vector +@c snarfed from weaks.c:182 +@deffn {Scheme Procedure} make-weak-key-alist-vector [size] +@deffnx {Scheme Procedure} make-weak-value-alist-vector size +@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size +@deffnx {C Function} scm_make_weak_key_alist_vector (size) Return a weak hash table with @var{size} buckets. As with any hash table, choosing a good size for the table requires some caution. @@ -5185,43 +6112,49 @@ You can modify weak hash tables in exactly the same way you would modify regular hash tables. (@pxref{Hash Tables}) @end deffn - make-weak-value-hash-table -@deffn {Scheme Procedure} make-weak-value-hash-table size -@deffnx {C Function} scm_make_weak_value_hash_table (size) + make-weak-value-alist-vector +@c snarfed from weaks.c:194 +@deffn {Scheme Procedure} make-weak-value-alist-vector [size] +@deffnx {C Function} scm_make_weak_value_alist_vector (size) Return a hash table with weak values with @var{size} buckets. (@pxref{Hash Tables}) @end deffn - make-doubly-weak-hash-table -@deffn {Scheme Procedure} make-doubly-weak-hash-table size -@deffnx {C Function} scm_make_doubly_weak_hash_table (size) + make-doubly-weak-alist-vector +@c snarfed from weaks.c:206 +@deffn {Scheme Procedure} make-doubly-weak-alist-vector size +@deffnx {C Function} scm_make_doubly_weak_alist_vector (size) Return a hash table with weak keys and values with @var{size} buckets. (@pxref{Hash Tables}) @end deffn - weak-key-hash-table? -@deffn {Scheme Procedure} weak-key-hash-table? obj -@deffnx {Scheme Procedure} weak-value-hash-table? obj -@deffnx {Scheme Procedure} doubly-weak-hash-table? obj -@deffnx {C Function} scm_weak_key_hash_table_p (obj) + weak-key-alist-vector? +@c snarfed from weaks.c:221 +@deffn {Scheme Procedure} weak-key-alist-vector? obj +@deffnx {Scheme Procedure} weak-value-alist-vector? obj +@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj +@deffnx {C Function} scm_weak_key_alist_vector_p (obj) Return @code{#t} if @var{obj} is the specified weak hash table. Note that a doubly weak hash table is neither a weak key nor a weak value hash table. @end deffn - weak-value-hash-table? -@deffn {Scheme Procedure} weak-value-hash-table? obj -@deffnx {C Function} scm_weak_value_hash_table_p (obj) + weak-value-alist-vector? +@c snarfed from weaks.c:231 +@deffn {Scheme Procedure} weak-value-alist-vector? obj +@deffnx {C Function} scm_weak_value_alist_vector_p (obj) Return @code{#t} if @var{obj} is a weak value hash table. @end deffn - doubly-weak-hash-table? -@deffn {Scheme Procedure} doubly-weak-hash-table? obj -@deffnx {C Function} scm_doubly_weak_hash_table_p (obj) + doubly-weak-alist-vector? +@c snarfed from weaks.c:241 +@deffn {Scheme Procedure} doubly-weak-alist-vector? obj +@deffnx {C Function} scm_doubly_weak_alist_vector_p (obj) Return @code{#t} if @var{obj} is a doubly weak hash table. @end deffn dynamic-link +@c snarfed from dynl.c:149 @deffn {Scheme Procedure} dynamic-link filename @deffnx {C Function} scm_dynamic_link (filename) Find the shared object (shared library) denoted by @@ -5237,6 +6170,7 @@ such as @file{/usr/lib} and @file{/usr/local/lib}. @end deffn dynamic-object? +@c snarfed from dynl.c:168 @deffn {Scheme Procedure} dynamic-object? obj @deffnx {C Function} scm_dynamic_object_p (obj) Return @code{#t} if @var{obj} is a dynamic object handle, @@ -5244,6 +6178,7 @@ or @code{#f} otherwise. @end deffn dynamic-unlink +@c snarfed from dynl.c:182 @deffn {Scheme Procedure} dynamic-unlink dobj @deffnx {C Function} scm_dynamic_unlink (dobj) Unlink a dynamic object from the application, if possible. The @@ -5254,6 +6189,7 @@ object. @end deffn dynamic-func +@c snarfed from dynl.c:207 @deffn {Scheme Procedure} dynamic-func name dobj @deffnx {C Function} scm_dynamic_func (name, dobj) Return a ``handle'' for the function @var{name} in the @@ -5268,6 +6204,7 @@ since it will be added automatically when necessary. @end deffn dynamic-call +@c snarfed from dynl.c:253 @deffn {Scheme Procedure} dynamic-call func dobj @deffnx {C Function} scm_dynamic_call (func, dobj) Call a C function in a dynamic object. Two styles of @@ -5292,6 +6229,7 @@ and its return value is ignored. @end deffn dynamic-args-call +@c snarfed from dynl.c:285 @deffn {Scheme Procedure} dynamic-args-call func dobj args @deffnx {C Function} scm_dynamic_args_call (func, dobj, args) Call the C function indicated by @var{func} and @var{dobj}, @@ -5310,6 +6248,7 @@ converted to a Scheme number and returned from the call to @end deffn array-fill! +@c snarfed from ramap.c:438 @deffn {Scheme Procedure} array-fill! ra fill @deffnx {C Function} scm_array_fill_x (ra, fill) Store @var{fill} in every element of @var{array}. The value returned @@ -5317,11 +6256,13 @@ is unspecified. @end deffn array-copy-in-order! +@c snarfed from ramap.c:810 @deffn {Scheme Procedure} array-copy-in-order! implemented by the C function "scm_array_copy_x" @end deffn array-copy! +@c snarfed from ramap.c:819 @deffn {Scheme Procedure} array-copy! src dst @deffnx {Scheme Procedure} array-copy-in-order! src dst @deffnx {C Function} scm_array_copy_x (src, dst) @@ -5332,11 +6273,13 @@ dimension. The order is unspecified. @end deffn array-map-in-order! +@c snarfed from ramap.c:1494 @deffn {Scheme Procedure} array-map-in-order! implemented by the C function "scm_array_map_x" @end deffn array-map! +@c snarfed from ramap.c:1505 @deffn {Scheme Procedure} array-map! ra0 proc . lra @deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra @deffnx {C Function} scm_array_map_x (ra0, proc, lra) @@ -5349,6 +6292,7 @@ unspecified. The order of application is unspecified. @end deffn array-for-each +@c snarfed from ramap.c:1651 @deffn {Scheme Procedure} array-for-each proc ra0 . lra @deffnx {C Function} scm_array_for_each (proc, ra0, lra) Apply @var{proc} to each tuple of elements of @var{array0} @dots{} @@ -5356,6 +6300,7 @@ in row-major order. The value returned is unspecified. @end deffn array-index-map! +@c snarfed from ramap.c:1679 @deffn {Scheme Procedure} array-index-map! ra proc @deffnx {C Function} scm_array_index_map_x (ra, proc) Apply @var{proc} to the indices of each element of @var{array} in @@ -5379,12 +6324,14 @@ Another example: @end deffn uniform-vector-length +@c snarfed from unif.c:211 @deffn {Scheme Procedure} uniform-vector-length v @deffnx {C Function} scm_uniform_vector_length (v) Return the number of elements in @var{uve}. @end deffn array? +@c snarfed from unif.c:245 @deffn {Scheme Procedure} array? v [prot] @deffnx {C Function} scm_array_p (v, prot) Return @code{#t} if the @var{obj} is an array, and @code{#f} if @@ -5393,6 +6340,7 @@ and is described elsewhere. @end deffn array-rank +@c snarfed from unif.c:328 @deffn {Scheme Procedure} array-rank ra @deffnx {C Function} scm_array_rank (ra) Return the number of dimensions of @var{obj}. If @var{obj} is @@ -5400,6 +6348,7 @@ not an array, @code{0} is returned. @end deffn array-dimensions +@c snarfed from unif.c:366 @deffn {Scheme Procedure} array-dimensions ra @deffnx {C Function} scm_array_dimensions (ra) @code{Array-dimensions} is similar to @code{array-shape} but replaces @@ -5410,24 +6359,28 @@ elements with a @code{0} minimum with one greater than the maximum. So: @end deffn shared-array-root +@c snarfed from unif.c:413 @deffn {Scheme Procedure} shared-array-root ra @deffnx {C Function} scm_shared_array_root (ra) Return the root vector of a shared array. @end deffn shared-array-offset +@c snarfed from unif.c:424 @deffn {Scheme Procedure} shared-array-offset ra @deffnx {C Function} scm_shared_array_offset (ra) Return the root vector index of the first element in the array. @end deffn shared-array-increments +@c snarfed from unif.c:435 @deffn {Scheme Procedure} shared-array-increments ra @deffnx {C Function} scm_shared_array_increments (ra) For each dimension, return the distance between elements in the root vector. @end deffn dimensions->uniform-array +@c snarfed from unif.c:554 @deffn {Scheme Procedure} dimensions->uniform-array dims prot [fill] @deffnx {Scheme Procedure} make-uniform-vector length prototype [fill] @deffnx {C Function} scm_dimensions_to_uniform_array (dims, prot, fill) @@ -5438,6 +6391,7 @@ fill the array, otherwise @var{prototype} is used. @end deffn make-shared-array +@c snarfed from unif.c:643 @deffn {Scheme Procedure} make-shared-array oldra mapfunc . dims @deffnx {C Function} scm_make_shared_array (oldra, mapfunc, dims) @code{make-shared-array} can be used to create shared subarrays of other @@ -5458,6 +6412,7 @@ it can be otherwise arbitrary. A simple example: @end deffn transpose-array +@c snarfed from unif.c:774 @deffn {Scheme Procedure} transpose-array ra . args @deffnx {C Function} scm_transpose_array (ra, args) Return an array sharing contents with @var{array}, but with @@ -5482,6 +6437,7 @@ have smaller rank than @var{array}. @end deffn enclose-array +@c snarfed from unif.c:879 @deffn {Scheme Procedure} enclose-array ra . axes @deffnx {C Function} scm_enclose_array (ra, axes) @var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than @@ -5508,6 +6464,7 @@ examples: @end deffn array-in-bounds? +@c snarfed from unif.c:966 @deffn {Scheme Procedure} array-in-bounds? v . args @deffnx {C Function} scm_array_in_bounds_p (v, args) Return @code{#t} if its arguments would be acceptable to @@ -5515,11 +6472,13 @@ Return @code{#t} if its arguments would be acceptable to @end deffn array-ref +@c snarfed from unif.c:1044 @deffn {Scheme Procedure} array-ref implemented by the C function "scm_uniform_vector_ref" @end deffn uniform-vector-ref +@c snarfed from unif.c:1051 @deffn {Scheme Procedure} uniform-vector-ref v args @deffnx {Scheme Procedure} array-ref v . args @deffnx {C Function} scm_uniform_vector_ref (v, args) @@ -5528,11 +6487,13 @@ Return the element at the @code{(index1, index2)} element in @end deffn uniform-array-set1! +@c snarfed from unif.c:1219 @deffn {Scheme Procedure} uniform-array-set1! implemented by the C function "scm_array_set_x" @end deffn array-set! +@c snarfed from unif.c:1228 @deffn {Scheme Procedure} array-set! v obj . args @deffnx {Scheme Procedure} uniform-array-set1! v obj args @deffnx {C Function} scm_array_set_x (v, obj, args) @@ -5541,6 +6502,7 @@ Set the element at the @code{(index1, index2)} element in @var{array} to @end deffn array-contents +@c snarfed from unif.c:1335 @deffn {Scheme Procedure} array-contents ra [strict] @deffnx {C Function} scm_array_contents (ra, strict) If @var{array} may be @dfn{unrolled} into a one dimensional shared array @@ -5556,6 +6518,7 @@ memory. @end deffn uniform-array-read! +@c snarfed from unif.c:1449 @deffn {Scheme Procedure} uniform-array-read! ra [port_or_fd [start [end]]] @deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end] @deffnx {C Function} scm_uniform_array_read_x (ra, port_or_fd, start, end) @@ -5576,6 +6539,7 @@ returned by @code{(current-input-port)}. @end deffn uniform-array-write +@c snarfed from unif.c:1632 @deffn {Scheme Procedure} uniform-array-write v [port_or_fd [start [end]]] @deffnx {Scheme Procedure} uniform-vector-write uve [port-or-fdes] [start] [end] @deffnx {C Function} scm_uniform_array_write (v, port_or_fd, start, end) @@ -5593,6 +6557,7 @@ omitted, in which case it defaults to the value returned by @end deffn bit-count +@c snarfed from unif.c:1759 @deffn {Scheme Procedure} bit-count b bitvector @deffnx {C Function} scm_bit_count (b, bitvector) Return the number of occurrences of the boolean @var{b} in @@ -5600,44 +6565,85 @@ Return the number of occurrences of the boolean @var{b} in @end deffn bit-position +@c snarfed from unif.c:1804 @deffn {Scheme Procedure} bit-position item v k @deffnx {C Function} scm_bit_position (item, v, k) -Return the minimum index of an occurrence of @var{bool} in -@var{bv} which is at least @var{k}. If no @var{bool} occurs -within the specified range @code{#f} is returned. +Return the index of the first occurrance of @var{item} in bit +vector @var{v}, starting from @var{k}. If there is no +@var{item} entry between @var{k} and the end of +@var{bitvector}, then return @code{#f}. For example, + +@example +(bit-position #t #*000101 0) @result{} 3 +(bit-position #f #*0001111 3) @result{} #f +@end example @end deffn bit-set*! +@c snarfed from unif.c:1890 @deffn {Scheme Procedure} bit-set*! v kv obj @deffnx {C Function} scm_bit_set_star_x (v, kv, obj) -If uve is a bit-vector @var{bv} and uve must be of the same -length. If @var{bool} is @code{#t}, uve is OR'ed into -@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is -AND'ed into @var{bv}. +Set entries of bit vector @var{v} to @var{obj}, with @var{kv} +selecting the entries to change. The return value is +unspecified. -If uve is a unsigned long integer vector all the elements of uve -must be between 0 and the @code{length} of @var{bv}. The bits -of @var{bv} corresponding to the indexes in uve are set to -@var{bool}. The return value is unspecified. +If @var{kv} is a bit vector, then those entries where it has +@code{#t} are the ones in @var{v} which are set to @var{obj}. +@var{kv} and @var{v} must be the same length. When @var{obj} +is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when +@var{obj} is @code{#f} it can be seen as an ANDNOT. + +@example +(define bv #*01000010) +(bit-set*! bv #*10010001 #t) +bv +@result{} #*11010011 +@end example + +If @var{kv} is a uniform vector of unsigned long integers, then +they're indexes into @var{v} which are set to @var{obj}. + +@example +(define bv #*01000010) +(bit-set*! bv #u(5 2 7) #t) +bv +@result{} #*01100111 +@end example @end deffn bit-count* +@c snarfed from unif.c:1956 @deffn {Scheme Procedure} bit-count* v kv obj @deffnx {C Function} scm_bit_count_star (v, kv, obj) -Return -@lisp -(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t). -@end lisp -@var{bv} is not modified. +Return a count of how many entries in bit vector @var{v} are +equal to @var{obj}, with @var{kv} selecting the entries to +consider. + +If @var{kv} is a bit vector, then those entries where it has +@code{#t} are the ones in @var{v} which are considered. +@var{kv} and @var{v} must be the same length. + +If @var{kv} is a uniform vector of unsigned long integers, then +it's the indexes in @var{v} to consider. + +For example, + +@example +(bit-count* #*01110111 #*11001101 #t) @result{} 3 +(bit-count* #*01110111 #u(7 0 4) #f) @result{} 2 +@end example @end deffn bit-invert! +@c snarfed from unif.c:2021 @deffn {Scheme Procedure} bit-invert! v @deffnx {C Function} scm_bit_invert_x (v) -Modify @var{bv} by replacing each element with its negation. +Modify the bit vector @var{v} by replacing each element with +its negation. @end deffn array->list +@c snarfed from unif.c:2103 @deffn {Scheme Procedure} array->list v @deffnx {C Function} scm_array_to_list (v) Return a list consisting of all the elements, in order, of @@ -5645,6 +6651,7 @@ Return a list consisting of all the elements, in order, of @end deffn list->uniform-array +@c snarfed from unif.c:2205 @deffn {Scheme Procedure} list->uniform-array ndim prot lst @deffnx {Scheme Procedure} list->uniform-vector prot lst @deffnx {C Function} scm_list_to_uniform_array (ndim, prot, lst) @@ -5655,6 +6662,7 @@ done. @end deffn array-prototype +@c snarfed from unif.c:2562 @deffn {Scheme Procedure} array-prototype ra @deffnx {C Function} scm_array_prototype (ra) Return an object that would produce an array of the same type @@ -5663,6 +6671,7 @@ as @var{array}, if used as the @var{prototype} for @end deffn chown +@c snarfed from filesys.c:220 @deffn {Scheme Procedure} chown object owner group @deffnx {C Function} scm_chown (object, owner, group) Change the ownership and group of the file referred to by @var{object} to @@ -5680,6 +6689,7 @@ as @code{-1}, then that ID is not changed. @end deffn chmod +@c snarfed from filesys.c:258 @deffn {Scheme Procedure} chmod object mode @deffnx {C Function} scm_chmod (object, mode) Changes the permissions of the file referred to by @var{obj}. @@ -5692,6 +6702,7 @@ The return value is unspecified. @end deffn umask +@c snarfed from filesys.c:290 @deffn {Scheme Procedure} umask [mode] @deffnx {C Function} scm_umask (mode) If @var{mode} is omitted, returns a decimal number representing the current @@ -5702,6 +6713,7 @@ E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18. @end deffn open-fdes +@c snarfed from filesys.c:312 @deffn {Scheme Procedure} open-fdes path flags [mode] @deffnx {C Function} scm_open_fdes (path, flags, mode) Similar to @code{open} but return a file descriptor instead of @@ -5709,6 +6721,7 @@ a port. @end deffn open +@c snarfed from filesys.c:353 @deffn {Scheme Procedure} open path flags [mode] @deffnx {C Function} scm_open (path, flags, mode) Open the file named by @var{path} for reading and/or writing. @@ -5741,6 +6754,7 @@ for additional flags. @end deffn close +@c snarfed from filesys.c:391 @deffn {Scheme Procedure} close fd_or_port @deffnx {C Function} scm_close (fd_or_port) Similar to close-port (@pxref{Closing, close-port}), @@ -5751,6 +6765,7 @@ their revealed counts set to zero. @end deffn close-fdes +@c snarfed from filesys.c:418 @deffn {Scheme Procedure} close-fdes fd @deffnx {C Function} scm_close_fdes (fd) A simple wrapper for the @code{close} system call. @@ -5761,6 +6776,7 @@ The return value is unspecified. @end deffn stat +@c snarfed from filesys.c:620 @deffn {Scheme Procedure} stat object @deffnx {C Function} scm_stat (object) Return an object containing various information about the file @@ -5822,6 +6838,7 @@ An integer representing the access permission bits. @end deffn link +@c snarfed from filesys.c:682 @deffn {Scheme Procedure} link oldpath newpath @deffnx {C Function} scm_link (oldpath, newpath) Creates a new name @var{newpath} in the file system for the @@ -5831,6 +6848,7 @@ system. @end deffn rename-file +@c snarfed from filesys.c:720 @deffn {Scheme Procedure} rename-file oldname newname @deffnx {C Function} scm_rename (oldname, newname) Renames the file specified by @var{oldname} to @var{newname}. @@ -5838,12 +6856,14 @@ The return value is unspecified. @end deffn delete-file +@c snarfed from filesys.c:737 @deffn {Scheme Procedure} delete-file str @deffnx {C Function} scm_delete_file (str) Deletes (or "unlinks") the file specified by @var{path}. @end deffn mkdir +@c snarfed from filesys.c:754 @deffn {Scheme Procedure} mkdir path [mode] @deffnx {C Function} scm_mkdir (path, mode) Create a new directory named by @var{path}. If @var{mode} is omitted @@ -5853,6 +6873,7 @@ umask. Otherwise they are set to the decimal value specified with @end deffn rmdir +@c snarfed from filesys.c:781 @deffn {Scheme Procedure} rmdir path @deffnx {C Function} scm_rmdir (path) Remove the existing directory named by @var{path}. The directory must @@ -5860,6 +6881,7 @@ be empty for this to succeed. The return value is unspecified. @end deffn directory-stream? +@c snarfed from filesys.c:805 @deffn {Scheme Procedure} directory-stream? obj @deffnx {C Function} scm_directory_stream_p (obj) Return a boolean indicating whether @var{object} is a directory @@ -5867,6 +6889,7 @@ stream as returned by @code{opendir}. @end deffn opendir +@c snarfed from filesys.c:816 @deffn {Scheme Procedure} opendir dirname @deffnx {C Function} scm_opendir (dirname) Open the directory specified by @var{path} and return a directory @@ -5874,6 +6897,7 @@ stream. @end deffn readdir +@c snarfed from filesys.c:837 @deffn {Scheme Procedure} readdir port @deffnx {C Function} scm_readdir (port) Return (as a string) the next directory entry from the directory stream @@ -5882,6 +6906,7 @@ end of file object is returned. @end deffn rewinddir +@c snarfed from filesys.c:876 @deffn {Scheme Procedure} rewinddir port @deffnx {C Function} scm_rewinddir (port) Reset the directory port @var{stream} so that the next call to @@ -5889,6 +6914,7 @@ Reset the directory port @var{stream} so that the next call to @end deffn closedir +@c snarfed from filesys.c:893 @deffn {Scheme Procedure} closedir port @deffnx {C Function} scm_closedir (port) Close the directory stream @var{stream}. @@ -5896,6 +6922,7 @@ The return value is unspecified. @end deffn chdir +@c snarfed from filesys.c:943 @deffn {Scheme Procedure} chdir str @deffnx {C Function} scm_chdir (str) Change the current working directory to @var{path}. @@ -5903,12 +6930,14 @@ The return value is unspecified. @end deffn getcwd +@c snarfed from filesys.c:958 @deffn {Scheme Procedure} getcwd @deffnx {C Function} scm_getcwd () Return the name of the current working directory. @end deffn select +@c snarfed from filesys.c:1159 @deffn {Scheme Procedure} select reads writes excepts [secs [usecs]] @deffnx {C Function} scm_select (reads, writes, excepts, secs, usecs) This procedure has a variety of uses: waiting for the ability @@ -5943,6 +6972,7 @@ An additional @code{select!} interface is provided. @end deffn fcntl +@c snarfed from filesys.c:1297 @deffn {Scheme Procedure} fcntl object cmd [value] @deffnx {C Function} scm_fcntl (object, cmd, value) Apply @var{command} to the specified file descriptor or the underlying @@ -5973,6 +7003,7 @@ The value used to indicate the "close on exec" flag with @code{F_GETFL} or @end deffn fsync +@c snarfed from filesys.c:1329 @deffn {Scheme Procedure} fsync object @deffnx {C Function} scm_fsync (object) Copies any unwritten data for the specified output file descriptor to disk. @@ -5982,6 +7013,7 @@ The return value is unspecified. @end deffn symlink +@c snarfed from filesys.c:1354 @deffn {Scheme Procedure} symlink oldpath newpath @deffnx {C Function} scm_symlink (oldpath, newpath) Create a symbolic link named @var{path-to} with the value (i.e., pointing to) @@ -5989,6 +7021,7 @@ Create a symbolic link named @var{path-to} with the value (i.e., pointing to) @end deffn readlink +@c snarfed from filesys.c:1373 @deffn {Scheme Procedure} readlink path @deffnx {C Function} scm_readlink (path) Return the value of the symbolic link named by @var{path} (a @@ -5996,6 +7029,7 @@ string), i.e., the file that the link points to. @end deffn lstat +@c snarfed from filesys.c:1415 @deffn {Scheme Procedure} lstat str @deffnx {C Function} scm_lstat (str) Similar to @code{stat}, but does not follow symbolic links, i.e., @@ -6004,6 +7038,7 @@ file it points to. @var{path} must be a string. @end deffn copy-file +@c snarfed from filesys.c:1438 @deffn {Scheme Procedure} copy-file oldfile newfile @deffnx {C Function} scm_copy_file (oldfile, newfile) Copy the file specified by @var{path-from} to @var{path-to}. @@ -6011,6 +7046,7 @@ The return value is unspecified. @end deffn dirname +@c snarfed from filesys.c:1501 @deffn {Scheme Procedure} dirname filename @deffnx {C Function} scm_dirname (filename) Return the directory name component of the file name @@ -6019,6 +7055,7 @@ component, @code{.} is returned. @end deffn basename +@c snarfed from filesys.c:1544 @deffn {Scheme Procedure} basename filename [suffix] @deffnx {C Function} scm_basename (filename, suffix) Return the base name of the file name @var{filename}. The @@ -6028,6 +7065,7 @@ If @var{suffix} is provided, and is equal to the end of @end deffn pipe +@c snarfed from posix.c:231 @deffn {Scheme Procedure} pipe @deffnx {C Function} scm_pipe () Return a newly created pipe: a pair of ports which are linked @@ -6046,13 +7084,26 @@ from the input port. @end deffn getgroups +@c snarfed from posix.c:252 @deffn {Scheme Procedure} getgroups @deffnx {C Function} scm_getgroups () Return a vector of integers representing the current supplementary group IDs. @end deffn + setgroups +@c snarfed from posix.c:285 +@deffn {Scheme Procedure} setgroups group_vec +@deffnx {C Function} scm_setgroups (group_vec) +Set the current set of supplementary group IDs to the integers +in the given vector @var{vec}. The return value is +unspecified. + +Generally only the superuser can set the process group IDs. +@end deffn + getpw +@c snarfed from posix.c:333 @deffn {Scheme Procedure} getpw [user] @deffnx {C Function} scm_getpwuid (user) Look up an entry in the user database. @var{obj} can be an integer, @@ -6061,6 +7112,7 @@ or getpwent respectively. @end deffn setpw +@c snarfed from posix.c:383 @deffn {Scheme Procedure} setpw [arg] @deffnx {C Function} scm_setpwent (arg) If called with a true argument, initialize or reset the password data @@ -6069,6 +7121,7 @@ stream. Otherwise, close the stream. The @code{setpwent} and @end deffn getgr +@c snarfed from posix.c:402 @deffn {Scheme Procedure} getgr [name] @deffnx {C Function} scm_getgrgid (name) Look up an entry in the group database. @var{obj} can be an integer, @@ -6077,6 +7130,7 @@ or getgrent respectively. @end deffn setgr +@c snarfed from posix.c:438 @deffn {Scheme Procedure} setgr [arg] @deffnx {C Function} scm_setgrent (arg) If called with a true argument, initialize or reset the group data @@ -6085,6 +7139,7 @@ stream. Otherwise, close the stream. The @code{setgrent} and @end deffn kill +@c snarfed from posix.c:474 @deffn {Scheme Procedure} kill pid sig @deffnx {C Function} scm_kill (pid, sig) Sends a signal to the specified process or group of processes. @@ -6117,6 +7172,7 @@ Interrupt signal. @end deffn waitpid +@c snarfed from posix.c:525 @deffn {Scheme Procedure} waitpid pid [options] @deffnx {C Function} scm_waitpid (pid, options) This procedure collects status information from a child process which @@ -6163,6 +7219,7 @@ The integer status value. @end deffn status:exit-val +@c snarfed from posix.c:551 @deffn {Scheme Procedure} status:exit-val status @deffnx {C Function} scm_status_exit_val (status) Return the exit status value, as would be set if a process @@ -6171,6 +7228,7 @@ if any, otherwise @code{#f}. @end deffn status:term-sig +@c snarfed from posix.c:569 @deffn {Scheme Procedure} status:term-sig status @deffnx {C Function} scm_status_term_sig (status) Return the signal number which terminated the process, if any, @@ -6178,6 +7236,7 @@ otherwise @code{#f}. @end deffn status:stop-sig +@c snarfed from posix.c:585 @deffn {Scheme Procedure} status:stop-sig status @deffnx {C Function} scm_status_stop_sig (status) Return the signal number which stopped the process, if any, @@ -6185,6 +7244,7 @@ otherwise @code{#f}. @end deffn getppid +@c snarfed from posix.c:603 @deffn {Scheme Procedure} getppid @deffnx {C Function} scm_getppid () Return an integer representing the process ID of the parent @@ -6192,18 +7252,21 @@ process. @end deffn getuid +@c snarfed from posix.c:615 @deffn {Scheme Procedure} getuid @deffnx {C Function} scm_getuid () Return an integer representing the current real user ID. @end deffn getgid +@c snarfed from posix.c:626 @deffn {Scheme Procedure} getgid @deffnx {C Function} scm_getgid () Return an integer representing the current real group ID. @end deffn geteuid +@c snarfed from posix.c:640 @deffn {Scheme Procedure} geteuid @deffnx {C Function} scm_geteuid () Return an integer representing the current effective user ID. @@ -6213,6 +7276,7 @@ system supports effective IDs. @end deffn getegid +@c snarfed from posix.c:657 @deffn {Scheme Procedure} getegid @deffnx {C Function} scm_getegid () Return an integer representing the current effective group ID. @@ -6222,6 +7286,7 @@ system supports effective IDs. @end deffn setuid +@c snarfed from posix.c:673 @deffn {Scheme Procedure} setuid id @deffnx {C Function} scm_setuid (id) Sets both the real and effective user IDs to the integer @var{id}, provided @@ -6230,6 +7295,7 @@ The return value is unspecified. @end deffn setgid +@c snarfed from posix.c:686 @deffn {Scheme Procedure} setgid id @deffnx {C Function} scm_setgid (id) Sets both the real and effective group IDs to the integer @var{id}, provided @@ -6238,6 +7304,7 @@ The return value is unspecified. @end deffn seteuid +@c snarfed from posix.c:701 @deffn {Scheme Procedure} seteuid id @deffnx {C Function} scm_seteuid (id) Sets the effective user ID to the integer @var{id}, provided the process @@ -6248,6 +7315,7 @@ The return value is unspecified. @end deffn setegid +@c snarfed from posix.c:726 @deffn {Scheme Procedure} setegid id @deffnx {C Function} scm_setegid (id) Sets the effective group ID to the integer @var{id}, provided the process @@ -6258,6 +7326,7 @@ The return value is unspecified. @end deffn getpgrp +@c snarfed from posix.c:749 @deffn {Scheme Procedure} getpgrp @deffnx {C Function} scm_getpgrp () Return an integer representing the current process group ID. @@ -6265,6 +7334,7 @@ This is the POSIX definition, not BSD. @end deffn setpgid +@c snarfed from posix.c:767 @deffn {Scheme Procedure} setpgid pid pgid @deffnx {C Function} scm_setpgid (pid, pgid) Move the process @var{pid} into the process group @var{pgid}. @var{pid} or @@ -6275,6 +7345,7 @@ The return value is unspecified. @end deffn setsid +@c snarfed from posix.c:784 @deffn {Scheme Procedure} setsid @deffnx {C Function} scm_setsid () Creates a new session. The current process becomes the session leader @@ -6284,6 +7355,7 @@ The return value is an integer representing the new process group ID. @end deffn ttyname +@c snarfed from posix.c:808 @deffn {Scheme Procedure} ttyname port @deffnx {C Function} scm_ttyname (port) Return a string with the name of the serial terminal device @@ -6291,6 +7363,7 @@ underlying @var{port}. @end deffn ctermid +@c snarfed from posix.c:847 @deffn {Scheme Procedure} ctermid @deffnx {C Function} scm_ctermid () Return a string containing the file name of the controlling @@ -6298,6 +7371,7 @@ terminal for the current process. @end deffn tcgetpgrp +@c snarfed from posix.c:871 @deffn {Scheme Procedure} tcgetpgrp port @deffnx {C Function} scm_tcgetpgrp (port) Return the process group ID of the foreground process group @@ -6313,6 +7387,7 @@ foreground. @end deffn tcsetpgrp +@c snarfed from posix.c:895 @deffn {Scheme Procedure} tcsetpgrp port pgid @deffnx {C Function} scm_tcsetpgrp (port, pgid) Set the foreground process group ID for the terminal used by the file @@ -6323,6 +7398,7 @@ controlling terminal. The return value is unspecified. @end deffn execl +@c snarfed from posix.c:927 @deffn {Scheme Procedure} execl filename . args @deffnx {C Function} scm_execl (filename, args) Executes the file named by @var{path} as a new process image. @@ -6339,6 +7415,7 @@ call, but we call it @code{execl} because of its Scheme calling interface. @end deffn execlp +@c snarfed from posix.c:958 @deffn {Scheme Procedure} execlp filename . args @deffnx {C Function} scm_execlp (filename, args) Similar to @code{execl}, however if @@ -6351,6 +7428,7 @@ call, but we call it @code{execlp} because of its Scheme calling interface. @end deffn execle +@c snarfed from posix.c:992 @deffn {Scheme Procedure} execle filename env . args @deffnx {C Function} scm_execle (filename, env, args) Similar to @code{execl}, but the environment of the new process is @@ -6362,6 +7440,7 @@ call, but we call it @code{execle} because of its Scheme calling interface. @end deffn primitive-fork +@c snarfed from posix.c:1028 @deffn {Scheme Procedure} primitive-fork @deffnx {C Function} scm_fork () Creates a new "child" process by duplicating the current "parent" process. @@ -6373,6 +7452,7 @@ with the scsh fork. @end deffn uname +@c snarfed from posix.c:1048 @deffn {Scheme Procedure} uname @deffnx {C Function} scm_uname () Return an object with some information about the computer @@ -6380,6 +7460,7 @@ system the program is running on. @end deffn environ +@c snarfed from posix.c:1077 @deffn {Scheme Procedure} environ [env] @deffnx {C Function} scm_environ (env) If @var{env} is omitted, return the current environment (in the @@ -6392,6 +7473,7 @@ then the return value is unspecified. @end deffn tmpnam +@c snarfed from posix.c:1110 @deffn {Scheme Procedure} tmpnam @deffnx {C Function} scm_tmpnam () Return a name in the file system that does not match any @@ -6402,6 +7484,7 @@ Care should be taken if opening the file, e.g., use the @end deffn mkstemp! +@c snarfed from posix.c:1136 @deffn {Scheme Procedure} mkstemp! tmpl @deffnx {C Function} scm_mkstemp (tmpl) Create a new unique file in the file system and returns a new @@ -6412,6 +7495,7 @@ place to return the name of the temporary file. @end deffn utime +@c snarfed from posix.c:1171 @deffn {Scheme Procedure} utime pathname [actime [modtime]] @deffnx {C Function} scm_utime (pathname, actime, modtime) @code{utime} sets the access and modification times for the @@ -6427,6 +7511,7 @@ modification time to the current time. @end deffn access? +@c snarfed from posix.c:1219 @deffn {Scheme Procedure} access? path how @deffnx {C Function} scm_access (path, how) Return @code{#t} if @var{path} corresponds to an existing file @@ -6455,12 +7540,14 @@ test for existence of the file. @end deffn getpid +@c snarfed from posix.c:1232 @deffn {Scheme Procedure} getpid @deffnx {C Function} scm_getpid () Return an integer representing the current process ID. @end deffn putenv +@c snarfed from posix.c:1249 @deffn {Scheme Procedure} putenv str @deffnx {C Function} scm_putenv (str) Modifies the environment of the current process, which is @@ -6477,6 +7564,7 @@ The return value is unspecified. @end deffn setlocale +@c snarfed from posix.c:1333 @deffn {Scheme Procedure} setlocale category [locale] @deffnx {C Function} scm_setlocale (category, locale) If @var{locale} is omitted, return the current value of the @@ -6491,6 +7579,7 @@ the locale will be set using environment variables. @end deffn mknod +@c snarfed from posix.c:1376 @deffn {Scheme Procedure} mknod path type perms dev @deffnx {C Function} scm_mknod (path, type, perms, dev) Creates a new special file, such as a file corresponding to a device. @@ -6511,6 +7600,7 @@ The return value is unspecified. @end deffn nice +@c snarfed from posix.c:1422 @deffn {Scheme Procedure} nice incr @deffnx {C Function} scm_nice (incr) Increment the priority of the current process by @var{incr}. A higher @@ -6519,6 +7609,7 @@ The return value is unspecified. @end deffn sync +@c snarfed from posix.c:1436 @deffn {Scheme Procedure} sync @deffnx {C Function} scm_sync () Flush the operating system disk buffers. @@ -6526,6 +7617,7 @@ The return value is unspecified. @end deffn crypt +@c snarfed from posix.c:1467 @deffn {Scheme Procedure} crypt key salt @deffnx {C Function} scm_crypt (key, salt) Encrypt @var{key} using @var{salt} as the salt value to the @@ -6533,6 +7625,7 @@ crypt(3) library call. @end deffn chroot +@c snarfed from posix.c:1499 @deffn {Scheme Procedure} chroot path @deffnx {C Function} scm_chroot (path) Change the root directory to that specified in @var{path}. @@ -6543,6 +7636,7 @@ root directory. @end deffn getlogin +@c snarfed from posix.c:1533 @deffn {Scheme Procedure} getlogin @deffnx {C Function} scm_getlogin () Return a string containing the name of the user logged in on @@ -6551,6 +7645,7 @@ information cannot be obtained. @end deffn cuserid +@c snarfed from posix.c:1551 @deffn {Scheme Procedure} cuserid @deffnx {C Function} scm_cuserid () Return a string containing a user name associated with the @@ -6559,6 +7654,7 @@ information cannot be obtained. @end deffn getpriority +@c snarfed from posix.c:1577 @deffn {Scheme Procedure} getpriority which who @deffnx {C Function} scm_getpriority (which, who) Return the scheduling priority of the process, process group @@ -6574,6 +7670,7 @@ specified processes. @end deffn setpriority +@c snarfed from posix.c:1611 @deffn {Scheme Procedure} setpriority which who prio @deffnx {C Function} scm_setpriority (which, who, prio) Set the scheduling priority of the process, process group @@ -6592,6 +7689,7 @@ The return value is not specified. @end deffn getpass +@c snarfed from posix.c:1636 @deffn {Scheme Procedure} getpass prompt @deffnx {C Function} scm_getpass (prompt) Display @var{prompt} to the standard error output and read @@ -6604,6 +7702,7 @@ characters is disabled. @end deffn flock +@c snarfed from posix.c:1741 @deffn {Scheme Procedure} flock file operation @deffnx {C Function} scm_flock (file, operation) Apply or remove an advisory lock on an open file. @@ -6626,6 +7725,7 @@ file descriptor or an open file descriptor port. @end deffn sethostname +@c snarfed from posix.c:1766 @deffn {Scheme Procedure} sethostname name @deffnx {C Function} scm_sethostname (name) Set the host name of the current processor to @var{name}. May @@ -6634,12 +7734,14 @@ specified. @end deffn gethostname +@c snarfed from posix.c:1784 @deffn {Scheme Procedure} gethostname @deffnx {C Function} scm_gethostname () Return the host name of the current processor. @end deffn gethost +@c snarfed from net_db.c:134 @deffn {Scheme Procedure} gethost [host] @deffnx {Scheme Procedure} gethostbyname hostname @deffnx {Scheme Procedure} gethostbyaddr address @@ -6656,6 +7758,7 @@ Unusual conditions may result in errors thrown to the @end deffn getnet +@c snarfed from net_db.c:216 @deffn {Scheme Procedure} getnet [net] @deffnx {Scheme Procedure} getnetbyname net-name @deffnx {Scheme Procedure} getnetbyaddr net-number @@ -6668,6 +7771,7 @@ given. @end deffn getproto +@c snarfed from net_db.c:268 @deffn {Scheme Procedure} getproto [protocol] @deffnx {Scheme Procedure} getprotobyname name @deffnx {Scheme Procedure} getprotobynumber number @@ -6679,6 +7783,7 @@ argument. @code{getproto} will accept either type, behaving like @end deffn getserv +@c snarfed from net_db.c:334 @deffn {Scheme Procedure} getserv [name [protocol]] @deffnx {Scheme Procedure} getservbyname name protocol @deffnx {Scheme Procedure} getservbyport port protocol @@ -6694,6 +7799,7 @@ as its first argument; if given no arguments, it behaves like @end deffn sethost +@c snarfed from net_db.c:385 @deffn {Scheme Procedure} sethost [stayopen] @deffnx {C Function} scm_sethost (stayopen) If @var{stayopen} is omitted, this is equivalent to @code{endhostent}. @@ -6701,6 +7807,7 @@ Otherwise it is equivalent to @code{sethostent stayopen}. @end deffn setnet +@c snarfed from net_db.c:401 @deffn {Scheme Procedure} setnet [stayopen] @deffnx {C Function} scm_setnet (stayopen) If @var{stayopen} is omitted, this is equivalent to @code{endnetent}. @@ -6708,6 +7815,7 @@ Otherwise it is equivalent to @code{setnetent stayopen}. @end deffn setproto +@c snarfed from net_db.c:417 @deffn {Scheme Procedure} setproto [stayopen] @deffnx {C Function} scm_setproto (stayopen) If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}. @@ -6715,6 +7823,7 @@ Otherwise it is equivalent to @code{setprotoent stayopen}. @end deffn setserv +@c snarfed from net_db.c:433 @deffn {Scheme Procedure} setserv [stayopen] @deffnx {C Function} scm_setserv (stayopen) If @var{stayopen} is omitted, this is equivalent to @code{endservent}. @@ -6722,6 +7831,7 @@ Otherwise it is equivalent to @code{setservent stayopen}. @end deffn htons +@c snarfed from socket.c:80 @deffn {Scheme Procedure} htons value @deffnx {C Function} scm_htons (value) Convert a 16 bit quantity from host to network byte ordering. @@ -6730,6 +7840,7 @@ and returned as a new integer. @end deffn ntohs +@c snarfed from socket.c:91 @deffn {Scheme Procedure} ntohs value @deffnx {C Function} scm_ntohs (value) Convert a 16 bit quantity from network to host byte ordering. @@ -6738,6 +7849,7 @@ and returned as a new integer. @end deffn htonl +@c snarfed from socket.c:102 @deffn {Scheme Procedure} htonl value @deffnx {C Function} scm_htonl (value) Convert a 32 bit quantity from host to network byte ordering. @@ -6746,6 +7858,7 @@ and returned as a new integer. @end deffn ntohl +@c snarfed from socket.c:115 @deffn {Scheme Procedure} ntohl value @deffnx {C Function} scm_ntohl (value) Convert a 32 bit quantity from network to host byte ordering. @@ -6754,6 +7867,7 @@ and returned as a new integer. @end deffn inet-aton +@c snarfed from socket.c:135 @deffn {Scheme Procedure} inet-aton address @deffnx {C Function} scm_inet_aton (address) Convert an IPv4 Internet address from printable string @@ -6765,6 +7879,7 @@ Convert an IPv4 Internet address from printable string @end deffn inet-ntoa +@c snarfed from socket.c:158 @deffn {Scheme Procedure} inet-ntoa inetid @deffnx {C Function} scm_inet_ntoa (inetid) Convert an IPv4 Internet address to a printable @@ -6776,6 +7891,7 @@ Convert an IPv4 Internet address to a printable @end deffn inet-netof +@c snarfed from socket.c:178 @deffn {Scheme Procedure} inet-netof address @deffnx {C Function} scm_inet_netof (address) Return the network number part of the given IPv4 @@ -6787,6 +7903,7 @@ Internet address. E.g., @end deffn inet-lnaof +@c snarfed from socket.c:196 @deffn {Scheme Procedure} inet-lnaof address @deffnx {C Function} scm_lnaof (address) Return the local-address-with-network part of the given @@ -6799,6 +7916,7 @@ E.g., @end deffn inet-makeaddr +@c snarfed from socket.c:214 @deffn {Scheme Procedure} inet-makeaddr net lna @deffnx {C Function} scm_inet_makeaddr (net, lna) Make an IPv4 Internet address by combining the network number @@ -6811,6 +7929,7 @@ Make an IPv4 Internet address by combining the network number @end deffn inet-pton +@c snarfed from socket.c:399 @deffn {Scheme Procedure} inet-pton family address @deffnx {C Function} scm_inet_pton (family, address) Convert a string containing a printable network address to @@ -6826,6 +7945,7 @@ the result is an integer with normal host byte ordering. @end deffn inet-ntop +@c snarfed from socket.c:437 @deffn {Scheme Procedure} inet-ntop family address @deffnx {C Function} scm_inet_ntop (family, address) Convert a network address into a printable string. @@ -6841,6 +7961,7 @@ ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff @end deffn socket +@c snarfed from socket.c:479 @deffn {Scheme Procedure} socket family style proto @deffnx {C Function} scm_socket (family, style, proto) Return a new socket port of the type specified by @var{family}, @@ -6859,6 +7980,7 @@ has been connected to another socket. @end deffn socketpair +@c snarfed from socket.c:500 @deffn {Scheme Procedure} socketpair family style proto @deffnx {C Function} scm_socketpair (family, style, proto) Return a pair of connected (but unnamed) socket ports of the @@ -6869,6 +7991,7 @@ family. Zero is likely to be the only meaningful value for @end deffn getsockopt +@c snarfed from socket.c:525 @deffn {Scheme Procedure} getsockopt sock level optname @deffnx {C Function} scm_getsockopt (sock, level, optname) Return the value of a particular socket option for the socket @@ -6883,6 +8006,7 @@ returns a pair of integers. @end deffn setsockopt +@c snarfed from socket.c:593 @deffn {Scheme Procedure} setsockopt sock level optname value @deffnx {C Function} scm_setsockopt (sock, level, optname, value) Set the value of a particular socket option for the socket @@ -6899,6 +8023,7 @@ The return value is unspecified. @end deffn shutdown +@c snarfed from socket.c:697 @deffn {Scheme Procedure} shutdown sock how @deffnx {C Function} scm_shutdown (sock, how) Sockets can be closed simply by using @code{close-port}. The @@ -6921,6 +8046,7 @@ The return value is unspecified. @end deffn connect +@c snarfed from socket.c:842 @deffn {Scheme Procedure} connect sock fam address . args @deffnx {C Function} scm_connect (sock, fam, address, args) Initiate a connection from a socket using a specified address @@ -6947,6 +8073,7 @@ The return value is unspecified. @end deffn bind +@c snarfed from socket.c:901 @deffn {Scheme Procedure} bind sock fam address . args @deffnx {C Function} scm_bind (sock, fam, address, args) Assign an address to the socket port @var{sock}. @@ -6995,6 +8122,7 @@ The return value is unspecified. @end deffn listen +@c snarfed from socket.c:934 @deffn {Scheme Procedure} listen sock backlog @deffnx {C Function} scm_listen (sock, backlog) Enable @var{sock} to accept connection @@ -7008,6 +8136,7 @@ The return value is unspecified. @end deffn accept +@c snarfed from socket.c:1046 @deffn {Scheme Procedure} accept sock @deffnx {C Function} scm_accept (sock) Accept a connection on a bound, listening socket. @@ -7027,6 +8156,7 @@ connection and will continue to accept new requests. @end deffn getsockname +@c snarfed from socket.c:1073 @deffn {Scheme Procedure} getsockname sock @deffnx {C Function} scm_getsockname (sock) Return the address of @var{sock}, in the same form as the @@ -7035,6 +8165,7 @@ of a socket in the @code{AF_FILE} namespace cannot be read. @end deffn getpeername +@c snarfed from socket.c:1095 @deffn {Scheme Procedure} getpeername sock @deffnx {C Function} scm_getpeername (sock) Return the address that @var{sock} @@ -7044,6 +8175,7 @@ is connected to, in the same form as the object returned by @end deffn recv! +@c snarfed from socket.c:1130 @deffn {Scheme Procedure} recv! sock buf [flags] @deffnx {C Function} scm_recv (sock, buf, flags) Receive data from a socket port. @@ -7069,6 +8201,7 @@ any unread buffered port data is ignored. @end deffn send +@c snarfed from socket.c:1173 @deffn {Scheme Procedure} send sock message [flags] @deffnx {C Function} scm_send (sock, message, flags) Transmit the string @var{message} on a socket port @var{sock}. @@ -7087,6 +8220,7 @@ any unflushed buffered port data is ignored. @end deffn recvfrom! +@c snarfed from socket.c:1224 @deffn {Scheme Procedure} recvfrom! sock str [flags [start [end]]] @deffnx {C Function} scm_recvfrom (sock, str, flags, start, end) Return data from the socket port @var{sock} and also @@ -7115,6 +8249,7 @@ descriptor: any unread buffered port data is ignored. @end deffn sendto +@c snarfed from socket.c:1289 @deffn {Scheme Procedure} sendto sock message fam address . args_and_flags @deffnx {C Function} scm_sendto (sock, message, fam, address, args_and_flags) Transmit the string @var{message} on the socket port @@ -7138,6 +8273,7 @@ any unflushed buffered port data is ignored. @end deffn regexp? +@c snarfed from regex-posix.c:105 @deffn {Scheme Procedure} regexp? obj @deffnx {C Function} scm_regexp_p (obj) Return @code{#t} if @var{obj} is a compiled regular expression, @@ -7145,6 +8281,7 @@ or @code{#f} otherwise. @end deffn make-regexp +@c snarfed from regex-posix.c:150 @deffn {Scheme Procedure} make-regexp pat . flags @deffnx {C Function} scm_make_regexp (pat, flags) Compile the regular expression described by @var{pat}, and @@ -7187,6 +8324,7 @@ one which comes last will override the earlier one. @end deffn regexp-exec +@c snarfed from regex-posix.c:216 @deffn {Scheme Procedure} regexp-exec rx str [start [flags]] @deffnx {C Function} scm_regexp_exec (rx, str, start, flags) Match the compiled regular expression @var{rx} against @@ -7209,63 +8347,3 @@ is used). Use this when the end of the string should not be considered the end of a line. @end table @end deffn - - single-active-thread? -@deffn {Scheme Procedure} single-active-thread? -implemented by the C function "scm_single_thread_p" -@end deffn - - yield -@deffn {Scheme Procedure} yield -implemented by the C function "scm_yield" -@end deffn - - call-with-new-thread -@deffn {Scheme Procedure} call-with-new-thread -implemented by the C function "scm_call_with_new_thread" -@end deffn - - current-thread -@deffn {Scheme Procedure} current-thread -implemented by the C function "scm_current_thread" -@end deffn - - all-threads -@deffn {Scheme Procedure} all-threads -implemented by the C function "scm_all_threads" -@end deffn - - join-thread -@deffn {Scheme Procedure} join-thread -implemented by the C function "scm_join_thread" -@end deffn - - make-mutex -@deffn {Scheme Procedure} make-mutex -implemented by the C function "scm_make_mutex" -@end deffn - - lock-mutex -@deffn {Scheme Procedure} lock-mutex -implemented by the C function "scm_lock_mutex" -@end deffn - - unlock-mutex -@deffn {Scheme Procedure} unlock-mutex -implemented by the C function "scm_unlock_mutex" -@end deffn - - make-condition-variable -@deffn {Scheme Procedure} make-condition-variable -implemented by the C function "scm_make_condition_variable" -@end deffn - - wait-condition-variable -@deffn {Scheme Procedure} wait-condition-variable -implemented by the C function "scm_wait_condition_variable" -@end deffn - - signal-condition-variable -@deffn {Scheme Procedure} signal-condition-variable -implemented by the C function "scm_signal_condition_variable" -@end deffn From b1092b3aaf82e7648f7d9d5e87cf325979b2e6a5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 16:43:50 +0000 Subject: [PATCH 055/100] (scm_inf_p): Synced docstring back from manual. --- libguile/numbers.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 966aa0d33..14acd2ab7 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -544,16 +544,16 @@ SCM_DEFINE (scm_even_p, "even?", 1, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0, - (SCM n), - "Return @code{#t} if @var{n} is infinite, @code{#f}\n" - "otherwise.") + (SCM x), + "Return @code{#t} if @var{x} is either @samp{+inf.0}\n" + "or @samp{-inf.0}, @code{#f} otherwise.") #define FUNC_NAME s_scm_inf_p { - if (SCM_REALP (n)) - return scm_from_bool (xisinf (SCM_REAL_VALUE (n))); - else if (SCM_COMPLEXP (n)) - return scm_from_bool (xisinf (SCM_COMPLEX_REAL (n)) - || xisinf (SCM_COMPLEX_IMAG (n))); + if (SCM_REALP (x)) + return scm_from_bool (xisinf (SCM_REAL_VALUE (x))); + else if (SCM_COMPLEXP (x)) + return scm_from_bool (xisinf (SCM_COMPLEX_REAL (x)) + || xisinf (SCM_COMPLEX_IMAG (x))); else return SCM_BOOL_F; } From 4b0d27f2660eadbddd64871def00edcf8502f567 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 16:44:00 +0000 Subject: [PATCH 056/100] *** empty log message *** --- doc/ref/ChangeLog | 7 +++++++ libguile/ChangeLog | 4 ++++ 2 files changed, 11 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index ff28dfa43..4032a567e 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,10 @@ +2004-08-24 Marius Vollmer + + Ran a (docstring-process-module "(guile)") and moved entries from + new-docstrings.texi to their appropriate place. + + * api-undocumented.texi: New file. + 2004-08-21 Marius Vollmer From Richard Todd, Thanks! diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 09c741d6e..26346676d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2004-08-24 Marius Vollmer + + * numbers.c (scm_inf_p): Synced docstring back from manual. + 2004-08-22 Marius Vollmer * strings.c (get_str_buf_start): New helper function. From 63181a97f5d1104e43219548ff71fbf13096c598 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 22:12:08 +0000 Subject: [PATCH 057/100] * srfi-13.c, srfi-13.h, srfi-14.c, srfi-14.h: New files. * strop.h, strop.c: Removed, they are now empty. * Makefile.am: Updated for new and removed files. --- libguile/Makefile.am | 10 +- libguile/srfi-13.c | 3323 ++++++++++++++++++++++++++++++++++++++++++ libguile/srfi-13.h | 119 ++ libguile/srfi-14.c | 1486 +++++++++++++++++++ libguile/srfi-14.h | 112 ++ libguile/strop.c | 0 libguile/strop.h | 0 7 files changed, 5045 insertions(+), 5 deletions(-) create mode 100644 libguile/srfi-13.c create mode 100644 libguile/srfi-13.h create mode 100644 libguile/srfi-14.c create mode 100644 libguile/srfi-14.h delete mode 100644 libguile/strop.c delete mode 100644 libguile/strop.h diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 66631d716..31f82dd78 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with Automake to create Makefile.in ## -## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -102,7 +102,7 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ load.c macros.c mallocs.c modules.c numbers.c objects.c objprop.c \ options.c pairs.c ports.c print.c procprop.c procs.c properties.c \ random.c rdelim.c read.c root.c rw.c scmsigs.c script.c simpos.c smob.c \ - sort.c srcprop.c stackchk.c stacks.c stime.c strings.c strop.c \ + sort.c srcprop.c stackchk.c stacks.c stime.c strings.c srfi-13.c srfi-14.c \ strorder.c strports.c struct.c symbols.c threads.c throw.c values.c \ variable.c vectors.c version.c vports.c weaks.c @@ -118,7 +118,7 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ numbers.x objects.x objprop.x options.x pairs.x ports.x print.x \ procprop.x procs.x properties.x random.x rdelim.x read.x root.x rw.x \ scmsigs.x script.x simpos.x smob.x sort.x srcprop.x \ - stackchk.x stacks.x stime.x strings.x strop.x strorder.x strports.x \ + stackchk.x stacks.x stime.x strings.x srfi-13.x srfi-14.x strorder.x strports.x \ struct.x symbols.x threads.x throw.x values.x variable.x vectors.x \ version.x vports.x weaks.x @@ -138,7 +138,7 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ options.doc pairs.doc ports.doc print.doc procprop.doc \ procs.doc properties.doc random.doc rdelim.doc read.doc root.doc rw.doc \ scmsigs.doc script.doc simpos.doc smob.doc sort.doc \ - srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc strop.doc \ + srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc srfi-13.doc srfi-14.doc \ strorder.doc strports.doc struct.doc symbols.doc threads.doc throw.doc \ values.doc variable.doc vectors.doc version.doc vports.doc weaks.doc @@ -194,7 +194,7 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ regex-posix.h print.h procprop.h procs.h properties.h random.h ramap.h \ rdelim.h read.h root.h rw.h scmsigs.h validate.h script.h simpos.h smob.h \ snarf.h socket.h sort.h srcprop.h stackchk.h stacks.h stime.h strings.h \ - strop.h strorder.h strports.h struct.h symbols.h tags.h threads.h \ + srfi-13.h srfi-14.h strorder.h strports.h struct.h symbols.h tags.h threads.h \ throw.h unif.h values.h variable.h vectors.h vports.h weaks.h nodist_modinclude_HEADERS = version.h scmconfig.h diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c new file mode 100644 index 000000000..8f1a89ff5 --- /dev/null +++ b/libguile/srfi-13.c @@ -0,0 +1,3323 @@ +/* srfi-13.c --- SRFI-13 procedures for Guile + * + * Copyright (C) 2001, 2004 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + +#include +#include + +#include "libguile.h" + +#include "libguile/srfi-13.h" +#include "libguile/srfi-14.h" + +/* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages + messing with the internal representation of strings. We define our + own version since we use it so much and are messing with Guile + internals anyway. +*/ + +#define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \ + pos_start, start, c_start, \ + pos_end, end, c_end) \ + do { \ + SCM_VALIDATE_STRING (pos_str, str); \ + c_str = scm_i_string_chars (str); \ + scm_i_get_substring_spec (scm_i_string_length (str), \ + start, &c_start, end, &c_end); \ + } while (0) + +#define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \ + pos_start, start, c_start, \ + pos_end, end, c_end) \ + do { \ + SCM_VALIDATE_STRING (pos_str, str); \ + scm_i_get_substring_spec (scm_i_string_length (str), \ + start, &c_start, end, &c_end); \ + } while (0) + +/* Likewise for SCM_VALIDATE_STRING_COPY. */ + +#define MY_VALIDATE_STRING_COPY(pos, str, cvar) \ + do { \ + scm_validate_string (pos, str); \ + cvar = scm_i_string_chars (str); \ + } while (0) + + +SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0, + (SCM str), + "Return @code{#t} if @var{str}'s length is zero, and\n" + "@code{#f} otherwise.\n" + "@lisp\n" + "(string-null? \"\") @result{} #t\n" + "y @result{} \"foo\"\n" + "(string-null? y) @result{} #f\n" + "@end lisp") +#define FUNC_NAME s_scm_string_null_p +{ + SCM_VALIDATE_STRING (1, str); + return scm_from_bool (scm_i_string_length (str) == 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, + (SCM char_pred, SCM s, SCM start, SCM end), + "Check if the predicate @var{pred} is true for any character in\n" + "the string @var{s}.\n" + "\n" + "Calls to @var{pred} are made from left to right across @var{s}.\n" + "When it returns true (ie.@: non-@code{#f}), that return value\n" + "is the return from @code{string-any}.\n" + "\n" + "The SRFI-13 specification requires that the call to @var{pred}\n" + "on the last character of @var{s} (assuming that point is\n" + "reached) be a tail call, but currently in Guile this is not the\n" + "case.") +#define FUNC_NAME s_scm_string_any +{ + const char *cstr; + int cstart, cend; + SCM res; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); + + if (SCM_CHARP (char_pred)) + { + return (memchr (cstr+cstart, (int) SCM_CHAR (char_pred), + cend-cstart) == NULL + ? SCM_BOOL_F : SCM_BOOL_T); + } + else if (SCM_CHARSETP (char_pred)) + { + int i; + for (i = cstart; i < cend; i++) + if (SCM_CHARSET_GET (char_pred, cstr[i])) + return SCM_BOOL_T; + } + else + { + SCM_VALIDATE_PROC (1, char_pred); + + cstr += cstart; + while (cstart < cend) + { + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (*cstr)); + if (scm_is_true (res)) + return res; + cstr++; + cstart++; + } + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0, + (SCM char_pred, SCM s, SCM start, SCM end), + "Check if the predicate @var{pred} is true for every character\n" + "in the string @var{s}.\n" + "\n" + "Calls to @var{pred} are made from left to right across @var{s}.\n" + "If the predicate is true for every character then the return\n" + "value from the last @var{pred} call is the return from\n" + "@code{string-every}.\n" + "\n" + "If there are no characters in @var{s} (ie.@: @var{start} equals\n" + "@var{end}) then the return is @code{#t}.\n" + "\n" + "The SRFI-13 specification requires that the call to @var{pred}\n" + "on the last character of @var{s} (assuming that point is\n" + "reached) be a tail call, but currently in Guile this is not the\n" + "case.") +#define FUNC_NAME s_scm_string_every +{ + const char *cstr; + int cstart, cend; + SCM res; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + char cchr = SCM_CHAR (char_pred); + int i; + for (i = cstart; i < cend; i++) + if (cstr[i] != cchr) + return SCM_BOOL_F; + return SCM_BOOL_T; + } + else if (SCM_CHARSETP (char_pred)) + { + int i; + for (i = cstart; i < cend; i++) + if (! SCM_CHARSET_GET (char_pred, cstr[i])) + return SCM_BOOL_F; + return SCM_BOOL_T; + } + else + { + SCM_VALIDATE_PROC (1, char_pred); + + res = SCM_BOOL_T; + cstr += cstart; + while (cstart < cend) + { + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (*cstr)); + if (scm_is_false (res)) + return res; + cstr++; + cstart++; + } + return res; + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0, + (SCM proc, SCM len), + "@var{proc} is an integer->char procedure. Construct a string\n" + "of size @var{len} by applying @var{proc} to each index to\n" + "produce the corresponding string element. The order in which\n" + "@var{proc} is applied to the indices is not specified.") +#define FUNC_NAME s_scm_string_tabulate +{ + size_t clen, i; + SCM res; + SCM ch; + char *p; + + SCM_VALIDATE_PROC (1, proc); + clen = scm_to_size_t (len); + SCM_ASSERT_RANGE (2, len, clen >= 0); + + res = scm_i_make_string (clen, &p); + i = 0; + while (i < clen) + { + /* The RES string remains untouched since nobody knows about it + yet. No need to refetch P. + */ + ch = scm_call_1 (proc, scm_from_int (i)); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); + *p++ = SCM_CHAR (ch); + i++; + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_substring_to_list, "string->list", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Convert the string @var{str} into a list of characters.") +#define FUNC_NAME s_scm_substring_to_list +{ + const char *cstr; + int cstart, cend; + SCM result = SCM_EOL; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + while (cstart < cend) + { + cend--; + result = scm_cons (SCM_MAKE_CHAR (cstr[cend]), result); + } + return result; +} +#undef FUNC_NAME + +/* We export scm_substring_to_list as "string->list" since it is + compatible and more general. This function remains for the benefit + of C code that used it. +*/ + +SCM +scm_string_to_list (SCM str) +{ + return scm_substring_to_list (str, SCM_UNDEFINED, SCM_UNDEFINED); +} + +SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0, + (SCM chrs), + "An efficient implementation of @code{(compose string->list\n" + "reverse)}:\n" + "\n" + "@smalllisp\n" + "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n" + "@end smalllisp") +#define FUNC_NAME s_scm_reverse_list_to_string +{ + SCM result; + long i = scm_ilength (chrs); + char *data; + + if (i < 0) + SCM_WRONG_TYPE_ARG (1, chrs); + result = scm_i_make_string (i, &data); + + { + + data += i; + while (!SCM_NULLP (chrs)) + { + SCM elt = SCM_CAR (chrs); + + SCM_VALIDATE_CHAR (SCM_ARGn, elt); + data--; + *data = SCM_CHAR (elt); + chrs = SCM_CDR (chrs); + } + } + return result; +} +#undef FUNC_NAME + + +SCM_SYMBOL (scm_sym_infix, "infix"); +SCM_SYMBOL (scm_sym_strict_infix, "strict-infix"); +SCM_SYMBOL (scm_sym_suffix, "suffix"); +SCM_SYMBOL (scm_sym_prefix, "prefix"); + +SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, + (SCM ls, SCM delimiter, SCM grammar), + "Append the string in the string list @var{ls}, using the string\n" + "@var{delim} as a delimiter between the elements of @var{ls}.\n" + "@var{grammar} is a symbol which specifies how the delimiter is\n" + "placed between the strings, and defaults to the symbol\n" + "@code{infix}.\n" + "\n" + "@table @code\n" + "@item infix\n" + "Insert the separator between list elements. An empty string\n" + "will produce an empty list.\n" + "@item string-infix\n" + "Like @code{infix}, but will raise an error if given the empty\n" + "list.\n" + "@item suffix\n" + "Insert the separator after every list element.\n" + "@item prefix\n" + "Insert the separator before each list element.\n" + "@end table") +#define FUNC_NAME s_scm_string_join +{ +#define GRAM_INFIX 0 +#define GRAM_STRICT_INFIX 1 +#define GRAM_SUFFIX 2 +#define GRAM_PREFIX 3 + SCM tmp; + SCM result; + int gram = GRAM_INFIX; + int del_len = 0, extra_len = 0; + int len = 0; + char * p; + long strings = scm_ilength (ls); + + /* Validate the string list. */ + if (strings < 0) + SCM_WRONG_TYPE_ARG (1, ls); + + /* Validate the delimiter and record its length. */ + if (SCM_UNBNDP (delimiter)) + { + delimiter = scm_from_locale_string (" "); + del_len = 1; + } + else + { + SCM_VALIDATE_STRING (2, delimiter); + del_len = scm_i_string_length (delimiter); + } + + /* Validate the grammar symbol and remember the grammar. */ + if (SCM_UNBNDP (grammar)) + gram = GRAM_INFIX; + else if (scm_is_eq (grammar, scm_sym_infix)) + gram = GRAM_INFIX; + else if (scm_is_eq (grammar, scm_sym_strict_infix)) + gram = GRAM_STRICT_INFIX; + else if (scm_is_eq (grammar, scm_sym_suffix)) + gram = GRAM_SUFFIX; + else if (scm_is_eq (grammar, scm_sym_prefix)) + gram = GRAM_PREFIX; + else + SCM_WRONG_TYPE_ARG (3, grammar); + + /* Check grammar constraints and calculate the space required for + the delimiter(s). */ + switch (gram) + { + case GRAM_INFIX: + if (!SCM_NULLP (ls)) + extra_len = (strings > 0) ? ((strings - 1) * del_len) : 0; + break; + case GRAM_STRICT_INFIX: + if (strings == 0) + SCM_MISC_ERROR ("strict-infix grammar requires non-empty list", + SCM_EOL); + extra_len = (strings - 1) * del_len; + break; + default: + extra_len = strings * del_len; + break; + } + + tmp = ls; + while (SCM_CONSP (tmp)) + { + SCM elt = SCM_CAR (tmp); + SCM_VALIDATE_STRING (1, elt); + len += scm_i_string_length (elt); + tmp = SCM_CDR (tmp); + } + + result = scm_i_make_string (len + extra_len, &p); + + tmp = ls; + switch (gram) + { + case GRAM_INFIX: + case GRAM_STRICT_INFIX: + while (!SCM_NULLP (tmp)) + { + SCM elt = SCM_CAR (tmp); + memmove (p, scm_i_string_chars (elt), + scm_i_string_length (elt)); + p += scm_i_string_length (elt); + if (!SCM_NULLP (SCM_CDR (tmp)) && del_len > 0) + { + memmove (p, scm_i_string_chars (delimiter), del_len); + p += del_len; + } + tmp = SCM_CDR (tmp); + } + break; + case GRAM_SUFFIX: + while (!SCM_NULLP (tmp)) + { + SCM elt = SCM_CAR (tmp); + memmove (p, scm_i_string_chars (elt), + scm_i_string_length (elt)); + p += scm_i_string_length (elt); + if (del_len > 0) + { + memmove (p, scm_i_string_chars (delimiter), del_len); + p += del_len; + } + tmp = SCM_CDR (tmp); + } + break; + case GRAM_PREFIX: + while (!SCM_NULLP (tmp)) + { + SCM elt = SCM_CAR (tmp); + if (del_len > 0) + { + memmove (p, scm_i_string_chars (delimiter), del_len); + p += del_len; + } + memmove (p, scm_i_string_chars (elt), + scm_i_string_length (elt)); + p += scm_i_string_length (elt); + tmp = SCM_CDR (tmp); + } + break; + } + return result; +#undef GRAM_INFIX +#undef GRAM_STRICT_INFIX +#undef GRAM_SUFFIX +#undef GRAM_PREFIX +} +#undef FUNC_NAME + + +/* There are a number of functions to consider here for Scheme and C: + + string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy + substring/copy STR start [end] ;; Guile variant of R5RS substring + + scm_string_copy (str) ;; Old function from Guile + scm_substring_copy (str, [start, [end]]) + ;; C version of SRFI-13 string-copy + ;; and C version of substring/copy + + The C function underlying string-copy is not exported to C + programs. scm_substring_copy is defined in strings.c as the + underlying function of substring/copy and allows an optional START + argument. +*/ + +SCM scm_srfi13_substring_copy (SCM str, SCM start, SCM end); + +SCM_DEFINE (scm_srfi13_substring_copy, "string-copy", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Return a freshly allocated copy of the string @var{str}. If\n" + "given, @var{start} and @var{end} delimit the portion of\n" + "@var{str} which is copied.") +#define FUNC_NAME s_scm_srfi13_substring_copy +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return scm_c_substring_copy (str, cstart, cend); +} +#undef FUNC_NAME + +SCM +scm_string_copy (SCM str) +{ + return scm_c_substring (str, 0, scm_c_string_length (str)); +} + +SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0, + (SCM target, SCM tstart, SCM s, SCM start, SCM end), + "Copy the sequence of characters from index range [@var{start},\n" + "@var{end}) in string @var{s} to string @var{target}, beginning\n" + "at index @var{tstart}. The characters are copied left-to-right\n" + "or right-to-left as needed -- the copy is guaranteed to work,\n" + "even if @var{target} and @var{s} are the same string. It is an\n" + "error if the copy operation runs off the end of the target\n" + "string.") +#define FUNC_NAME s_scm_string_copy_x +{ + const char *cstr; + char *ctarget; + size_t cstart, cend, ctstart, dummy, len; + SCM sdummy = SCM_UNDEFINED; + + MY_VALIDATE_SUBSTRING_SPEC (1, target, + 2, tstart, ctstart, + 2, sdummy, dummy); + MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, + 4, start, cstart, + 5, end, cend); + len = cend - cstart; + SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart); + + ctarget = scm_i_string_writable_chars (target); + memmove (ctarget + ctstart, cstr + cstart, len); + scm_i_string_stop_writing (); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0, + (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2), + "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n" + "into @var{str2} beginning at position @var{start2}.\n" + "@var{str1} and @var{str2} can be the same string.") +#define FUNC_NAME s_scm_substring_move_x +{ + return scm_string_copy_x (str2, start2, str1, start1, end1); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0, + (SCM s, SCM n), + "Return the @var{n} first characters of @var{s}.") +#define FUNC_NAME s_scm_string_take +{ + return scm_substring (s, SCM_INUM0, n); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0, + (SCM s, SCM n), + "Return all but the first @var{n} characters of @var{s}.") +#define FUNC_NAME s_scm_string_drop +{ + return scm_substring (s, n, SCM_UNDEFINED); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0, + (SCM s, SCM n), + "Return the @var{n} last characters of @var{s}.") +#define FUNC_NAME s_scm_string_take_right +{ + return scm_substring (s, + scm_difference (scm_string_length (s), n), + SCM_UNDEFINED); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0, + (SCM s, SCM n), + "Return all but the last @var{n} characters of @var{s}.") +#define FUNC_NAME s_scm_string_drop_right +{ + return scm_substring (s, + SCM_INUM0, + scm_difference (scm_string_length (s), n)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0, + (SCM s, SCM len, SCM chr, SCM start, SCM end), + "Take that characters from @var{start} to @var{end} from the\n" + "string @var{s} and return a new string, right-padded by the\n" + "character @var{chr} to length @var{len}. If the resulting\n" + "string is longer than @var{len}, it is truncated on the right.") +#define FUNC_NAME s_scm_string_pad +{ + char cchr; + const char *cstr; + size_t cstart, cend, clen; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 4, start, cstart, + 5, end, cend); + clen = scm_to_size_t (len); + + if (SCM_UNBNDP (chr)) + cchr = ' '; + else + { + SCM_VALIDATE_CHAR (3, chr); + cchr = SCM_CHAR (chr); + } + if (clen < (cend - cstart)) + return scm_c_substring (s, cend - clen, cend); + else + { + SCM result; + char *dst; + + result = scm_i_make_string (clen, &dst); + memset (dst, cchr, (clen - (cend - cstart))); + memmove (dst + clen - (cend - cstart), cstr + cstart, cend - cstart); + return result; + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0, + (SCM s, SCM len, SCM chr, SCM start, SCM end), + "Take that characters from @var{start} to @var{end} from the\n" + "string @var{s} and return a new string, left-padded by the\n" + "character @var{chr} to length @var{len}. If the resulting\n" + "string is longer than @var{len}, it is truncated on the left.") +#define FUNC_NAME s_scm_string_pad_right +{ + char cchr; + const char *cstr; + size_t cstart, cend, clen; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 4, start, cstart, + 5, end, cend); + clen = scm_to_size_t (len); + + if (SCM_UNBNDP (chr)) + cchr = ' '; + else + { + SCM_VALIDATE_CHAR (3, chr); + cchr = SCM_CHAR (chr); + } + if (clen < (cend - cstart)) + return scm_c_substring (s, cstart, cstart + clen); + else + { + SCM result; + char *dst; + + result = scm_i_make_string (clen, &dst); + memset (dst + (cend - cstart), cchr, clen - (cend - cstart)); + memmove (dst, cstr + cstart, cend - cstart); + return result; + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Trim @var{s} by skipping over all characters on the left\n" + "that satisfy the parameter @var{char_pred}:\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "if it is the character @var{ch}, characters equal to\n" + "@var{ch} are trimmed,\n" + "\n" + "@item\n" + "if it is a procedure @var{pred} characters that\n" + "satisfy @var{pred} are trimmed,\n" + "\n" + "@item\n" + "if it is a character set, characters in that set are trimmed.\n" + "@end itemize\n" + "\n" + "If called without a @var{char_pred} argument, all whitespace is\n" + "trimmed.") +#define FUNC_NAME s_scm_string_trim +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_UNBNDP (char_pred)) + { + while (cstart < cend) + { + if (!isspace((int) (unsigned char) cstr[cstart])) + break; + cstart++; + } + } + else if (SCM_CHARP (char_pred)) + { + char chr = SCM_CHAR (char_pred); + while (cstart < cend) + { + if (chr != cstr[cstart]) + break; + cstart++; + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) + break; + cstart++; + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); + if (scm_is_false (res)) + break; + cstr = scm_i_string_chars (s); + cstart++; + } + } + return scm_c_substring (s, cstart, cend); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Trim @var{s} by skipping over all characters on the rightt\n" + "that satisfy the parameter @var{char_pred}:\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "if it is the character @var{ch}, characters equal to @var{ch}\n" + "are trimmed,\n" + "\n" + "@item\n" + "if it is a procedure @var{pred} characters that satisfy\n" + "@var{pred} are trimmed,\n" + "\n" + "@item\n" + "if it is a character sets, all characters in that set are\n" + "trimmed.\n" + "@end itemize\n" + "\n" + "If called without a @var{char_pred} argument, all whitespace is\n" + "trimmed.") +#define FUNC_NAME s_scm_string_trim_right +{ + const char *cstr; + int cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_UNBNDP (char_pred)) + { + while (cstart < cend) + { + if (!isspace((int) (unsigned char) cstr[cend - 1])) + break; + cend--; + } + } + else if (SCM_CHARP (char_pred)) + { + char chr = SCM_CHAR (char_pred); + while (cstart < cend) + { + if (chr != cstr[cend - 1]) + break; + cend--; + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1])) + break; + cend--; + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1])); + if (scm_is_false (res)) + break; + cstr = scm_i_string_chars (s); + cend--; + } + } + return scm_c_substring (s, cstart, cend); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Trim @var{s} by skipping over all characters on both sides of\n" + "the string that satisfy the parameter @var{char_pred}:\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "if it is the character @var{ch}, characters equal to @var{ch}\n" + "are trimmed,\n" + "\n" + "@item\n" + "if it is a procedure @var{pred} characters that satisfy\n" + "@var{pred} are trimmed,\n" + "\n" + "@item\n" + "if it is a character set, the characters in the set are\n" + "trimmed.\n" + "@end itemize\n" + "\n" + "If called without a @var{char_pred} argument, all whitespace is\n" + "trimmed.") +#define FUNC_NAME s_scm_string_trim_both +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_UNBNDP (char_pred)) + { + while (cstart < cend) + { + if (!isspace((int) (unsigned char) cstr[cstart])) + break; + cstart++; + } + while (cstart < cend) + { + if (!isspace((int) (unsigned char) cstr[cend - 1])) + break; + cend--; + } + } + else if (SCM_CHARP (char_pred)) + { + char chr = SCM_CHAR (char_pred); + while (cstart < cend) + { + if (chr != cstr[cstart]) + break; + cstart++; + } + while (cstart < cend) + { + if (chr != cstr[cend - 1]) + break; + cend--; + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) + break; + cstart++; + } + while (cstart < cend) + { + if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1])) + break; + cend--; + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); + if (scm_is_false (res)) + break; + cstr = scm_i_string_chars (s); + cstart++; + } + while (cstart < cend) + { + SCM res; + + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1])); + if (scm_is_false (res)) + break; + cstr = scm_i_string_chars (s); + cend--; + } + } + return scm_c_substring (s, cstart, cend); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0, + (SCM str, SCM chr, SCM start, SCM end), + "Stores @var{chr} in every element of the given @var{str} and\n" + "returns an unspecified value.") +#define FUNC_NAME s_scm_substring_fill_x +{ + char *cstr; + size_t cstart, cend; + int c; + size_t k; + + /* Older versions of Guile provided the function + scm_substring_fill_x with the following order of arguments: + + str, start, end, chr + + We accomodate this here by detecting such a usage and reordering + the arguments. + */ + if (SCM_CHARP (end)) + { + SCM tmp = end; + end = start; + start = chr; + chr = tmp; + } + + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 3, start, cstart, + 4, end, cend); + SCM_VALIDATE_CHAR_COPY (2, chr, c); + + cstr = scm_i_string_writable_chars (str); + for (k = cstart; k < cend; k++) + cstr[k] = c; + scm_i_string_stop_writing (); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM +scm_string_fill_x (SCM str, SCM chr) +{ + return scm_substring_fill_x (str, chr, SCM_UNDEFINED, SCM_UNDEFINED); +} + +SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0, + (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2), + "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n" + "mismatch index, depending upon whether @var{s1} is less than,\n" + "equal to, or greater than @var{s2}. The mismatch index is the\n" + "largest index @var{i} such that for every 0 <= @var{j} <\n" + "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n" + "@var{i} is the first position that does not match.") +#define FUNC_NAME s_scm_string_compare +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 6, start1, cstart1, + 7, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 8, start2, cstart2, + 9, end2, cend2); + SCM_VALIDATE_PROC (3, proc_lt); + SCM_VALIDATE_PROC (4, proc_eq); + SCM_VALIDATE_PROC (5, proc_gt); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); + else if (cstr1[cstart1] > cstr2[cstart2]) + return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); + else if (cstart2 < cend2) + return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); + else + return scm_call_1 (proc_eq, scm_from_size_t (cstart1)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0, + (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2), + "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n" + "mismatch index, depending upon whether @var{s1} is less than,\n" + "equal to, or greater than @var{s2}. The mismatch index is the\n" + "largest index @var{i} such that for every 0 <= @var{j} <\n" + "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n" + "@var{i} is the first position that does not match. The\n" + "character comparison is done case-insensitively.") +#define FUNC_NAME s_scm_string_compare_ci +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 6, start1, cstart1, + 7, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 8, start2, cstart2, + 9, end2, cend2); + SCM_VALIDATE_PROC (3, proc_lt); + SCM_VALIDATE_PROC (4, proc_eq); + SCM_VALIDATE_PROC (5, proc_gt); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) + return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); + else if (cstart2 < cend2) + return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); + else + return scm_call_1 (proc_eq, scm_from_size_t (cstart1)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n" + "value otherwise.") +#define FUNC_NAME s_scm_string_eq +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + if ((cend1 - cstart1) != (cend2 - cstart2)) + goto false; + + while (cstart1 < cend1) + { + if (cstr1[cstart1] < cstr2[cstart2]) + goto false; + else if (cstr1[cstart1] > cstr2[cstart2]) + goto false; + cstart1++; + cstart2++; + } + + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n" + "value otherwise.") +#define FUNC_NAME s_scm_string_neq +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + goto true; + else if (cstr1[cstart1] > cstr2[cstart2]) + goto true; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto true; + else if (cstart2 < cend2) + goto true; + else + goto false; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n" + "true value otherwise.") +#define FUNC_NAME s_scm_string_lt +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + goto true; + else if (cstr1[cstart1] > cstr2[cstart2]) + goto false; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto false; + else if (cstart2 < cend2) + goto true; + else + goto false; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n" + "true value otherwise.") +#define FUNC_NAME s_scm_string_gt +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + goto false; + else if (cstr1[cstart1] > cstr2[cstart2]) + goto true; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto true; + else if (cstart2 < cend2) + goto false; + else + goto false; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n" + "value otherwise.") +#define FUNC_NAME s_scm_string_le +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + goto true; + else if (cstr1[cstart1] > cstr2[cstart2]) + goto false; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto false; + else if (cstart2 < cend2) + goto true; + else + goto true; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n" + "otherwise.") +#define FUNC_NAME s_scm_string_ge +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] < cstr2[cstart2]) + goto false; + else if (cstr1[cstart1] > cstr2[cstart2]) + goto true; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto true; + else if (cstart2 < cend2) + goto false; + else + goto true; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n" + "value otherwise. The character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_ci_eq +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) + goto false; + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + goto false; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto false; + else if (cstart2 < cend2) + goto false; + else + goto true; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n" + "value otherwise. The character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_ci_neq +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) + goto true; + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + goto true; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto true; + else if (cstart2 < cend2) + goto true; + else + goto false; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n" + "true value otherwise. The character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_ci_lt +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) + goto true; + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + goto false; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto false; + else if (cstart2 < cend2) + goto true; + else + goto false; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n" + "true value otherwise. The character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_ci_gt +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) + goto false; + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + goto true; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto true; + else if (cstart2 < cend2) + goto false; + else + goto false; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n" + "value otherwise. The character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_ci_le +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) + goto true; + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + goto false; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto false; + else if (cstart2 < cend2) + goto true; + else + goto true; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n" + "otherwise. The character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_ci_ge +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) + goto false; + else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) + goto true; + cstart1++; + cstart2++; + } + if (cstart1 < cend1) + goto true; + else if (cstart2 < cend2) + goto false; + else + goto true; + + true: + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + + false: + scm_remember_upto_here_2 (s1, s2); + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_substring_hash, "string-hash", 1, 3, 0, + (SCM s, SCM bound, SCM start, SCM end), + "Compute a hash value for @var{S}. the optional argument " + "@var{bound} is a non-negative exact " + "integer specifying the range of the hash function. " + "A positive value restricts the return value to the " + "range [0,bound).") +#define FUNC_NAME s_scm_substring_hash +{ + if (SCM_UNBNDP (bound)) + bound = scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM); + if (SCM_UNBNDP (start)) + start = SCM_INUM0; + return scm_hash (scm_substring_shared (s, start, end), bound); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_substring_hash_ci, "string-hash-ci", 1, 3, 0, + (SCM s, SCM bound, SCM start, SCM end), + "Compute a hash value for @var{S}. the optional argument " + "@var{bound} is a non-negative exact " + "integer specifying the range of the hash function. " + "A positive value restricts the return value to the " + "range [0,bound).") +#define FUNC_NAME s_scm_substring_hash_ci +{ + return scm_substring_hash (scm_substring_downcase (s, start, end), + bound, + SCM_UNDEFINED, SCM_UNDEFINED); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return the length of the longest common prefix of the two\n" + "strings.") +#define FUNC_NAME s_scm_string_prefix_length +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] != cstr2[cstart2]) + return scm_from_size_t (len); + len++; + cstart1++; + cstart2++; + } + return scm_from_size_t (len); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return the length of the longest common prefix of the two\n" + "strings, ignoring character case.") +#define FUNC_NAME s_scm_string_prefix_length_ci +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2])) + return scm_from_size_t (len); + len++; + cstart1++; + cstart2++; + } + return scm_from_size_t (len); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return the length of the longest common suffix of the two\n" + "strings.") +#define FUNC_NAME s_scm_string_suffix_length +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + while (cstart1 < cend1 && cstart2 < cend2) + { + cend1--; + cend2--; + if (cstr1[cend1] != cstr2[cend2]) + return scm_from_size_t (len); + len++; + } + return scm_from_size_t (len); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return the length of the longest common suffix of the two\n" + "strings, ignoring character case.") +#define FUNC_NAME s_scm_string_suffix_length_ci +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + while (cstart1 < cend1 && cstart2 < cend2) + { + cend1--; + cend2--; + if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2])) + return scm_from_size_t (len); + len++; + } + return scm_from_size_t (len); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Is @var{s1} a prefix of @var{s2}?") +#define FUNC_NAME s_scm_string_prefix_p +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0, len1; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + len1 = cend1 - cstart1; + while (cstart1 < cend1 && cstart2 < cend2) + { + if (cstr1[cstart1] != cstr2[cstart2]) + return scm_from_bool (len == len1); + len++; + cstart1++; + cstart2++; + } + return scm_from_bool (len == len1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Is @var{s1} a prefix of @var{s2}, ignoring character case?") +#define FUNC_NAME s_scm_string_prefix_ci_p +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0, len1; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + len1 = cend1 - cstart1; + while (cstart1 < cend1 && cstart2 < cend2) + { + if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2])) + return scm_from_bool (len == len1); + len++; + cstart1++; + cstart2++; + } + return scm_from_bool (len == len1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Is @var{s1} a suffix of @var{s2}?") +#define FUNC_NAME s_scm_string_suffix_p +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0, len1; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + len1 = cend1 - cstart1; + while (cstart1 < cend1 && cstart2 < cend2) + { + cend1--; + cend2--; + if (cstr1[cend1] != cstr2[cend2]) + return scm_from_bool (len == len1); + len++; + } + return scm_from_bool (len == len1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Is @var{s1} a suffix of @var{s2}, ignoring character case?") +#define FUNC_NAME s_scm_string_suffix_ci_p +{ + const char *cstr1, *cstr2; + size_t cstart1, cend1, cstart2, cend2; + size_t len = 0, len1; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + len1 = cend1 - cstart1; + while (cstart1 < cend1 && cstart2 < cend2) + { + cend1--; + cend2--; + if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2])) + return scm_from_bool (len == len1); + len++; + } + return scm_from_bool (len == len1); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Search through the string @var{s} from left to right, returning\n" + "the index of the first occurence of a character which\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "equals @var{char_pred}, if it is character,\n" + "\n" + "@item\n" + "satisifies the predicate @var{char_pred}, if it is a procedure,\n" + "\n" + "@item\n" + "is in the set @var{char_pred}, if it is a character set.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_index +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + char cchr = SCM_CHAR (char_pred); + while (cstart < cend) + { + if (cchr == cstr[cstart]) + return scm_from_size_t (cstart); + cstart++; + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + if (SCM_CHARSET_GET (char_pred, cstr[cstart])) + return scm_from_size_t (cstart); + cstart++; + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); + if (scm_is_true (res)) + return scm_from_size_t (cstart); + cstr = scm_i_string_chars (s); + cstart++; + } + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Search through the string @var{s} from right to left, returning\n" + "the index of the last occurence of a character which\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "equals @var{char_pred}, if it is character,\n" + "\n" + "@item\n" + "satisifies the predicate @var{char_pred}, if it is a procedure,\n" + "\n" + "@item\n" + "is in the set if @var{char_pred} is a character set.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_index_right +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + char cchr = SCM_CHAR (char_pred); + while (cstart < cend) + { + cend--; + if (cchr == cstr[cend]) + return scm_from_size_t (cend); + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + cend--; + if (SCM_CHARSET_GET (char_pred, cstr[cend])) + return scm_from_size_t (cend); + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + cend--; + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend])); + if (scm_is_true (res)) + return scm_from_size_t (cend); + cstr = scm_i_string_chars (s); + } + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM +scm_string_rindex (SCM str, SCM chr, SCM frm, SCM to) +{ + return scm_string_index_right (str, chr, frm, to); +} + +SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Search through the string @var{s} from left to right, returning\n" + "the index of the first occurence of a character which\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "does not equal @var{char_pred}, if it is character,\n" + "\n" + "@item\n" + "does not satisify the predicate @var{char_pred}, if it is a\n" + "procedure,\n" + "\n" + "@item\n" + "is not in the set if @var{char_pred} is a character set.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_skip +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + char cchr = SCM_CHAR (char_pred); + while (cstart < cend) + { + if (cchr != cstr[cstart]) + return scm_from_size_t (cstart); + cstart++; + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) + return scm_from_size_t (cstart); + cstart++; + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); + if (scm_is_false (res)) + return scm_from_size_t (cstart); + cstr = scm_i_string_chars (s); + cstart++; + } + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Search through the string @var{s} from right to left, returning\n" + "the index of the last occurence of a character which\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "does not equal @var{char_pred}, if it is character,\n" + "\n" + "@item\n" + "does not satisfy the predicate @var{char_pred}, if it is a\n" + "procedure,\n" + "\n" + "@item\n" + "is not in the set if @var{char_pred} is a character set.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_skip_right +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + char cchr = SCM_CHAR (char_pred); + while (cstart < cend) + { + cend--; + if (cchr != cstr[cend]) + return scm_from_size_t (cend); + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + cend--; + if (!SCM_CHARSET_GET (char_pred, cstr[cend])) + return scm_from_size_t (cend); + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + cend--; + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend])); + if (scm_is_false (res)) + return scm_from_size_t (cend); + cstr = scm_i_string_chars (s); + } + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Return the count of the number of characters in the string\n" + "@var{s} which\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "equals @var{char_pred}, if it is character,\n" + "\n" + "@item\n" + "satisifies the predicate @var{char_pred}, if it is a procedure.\n" + "\n" + "@item\n" + "is in the set @var{char_pred}, if it is a character set.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_count +{ + const char *cstr; + size_t cstart, cend; + size_t count = 0; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + char cchr = SCM_CHAR (char_pred); + while (cstart < cend) + { + if (cchr == cstr[cstart]) + count++; + cstart++; + } + } + else if (SCM_CHARSETP (char_pred)) + { + while (cstart < cend) + { + if (SCM_CHARSET_GET (char_pred, cstr[cstart])) + count++; + cstart++; + } + } + else + { + SCM_VALIDATE_PROC (2, char_pred); + while (cstart < cend) + { + SCM res; + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); + if (scm_is_true (res)) + count++; + cstr = scm_i_string_chars (s); + cstart++; + } + } + return scm_from_size_t (count); +} +#undef FUNC_NAME + + +/* FIXME::martin: This should definitely get implemented more + efficiently -- maybe with Knuth-Morris-Pratt, like in the reference + implementation. */ +SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Does string @var{s1} contain string @var{s2}? Return the index\n" + "in @var{s1} where @var{s2} occurs as a substring, or false.\n" + "The optional start/end indices restrict the operation to the\n" + "indicated substrings.") +#define FUNC_NAME s_scm_string_contains +{ + const char *cs1, * cs2; + size_t cstart1, cend1, cstart2, cend2; + size_t len2, i, j; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2, + 5, start2, cstart2, + 6, end2, cend2); + len2 = cend2 - cstart2; + while (cstart1 <= cend1 - len2) + { + i = cstart1; + j = cstart2; + while (i < cend1 && j < cend2 && cs1[i] == cs2[j]) + { + i++; + j++; + } + if (j == cend2) + return scm_from_size_t (cstart1); + cstart1++; + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +/* FIXME::martin: This should definitely get implemented more + efficiently -- maybe with Knuth-Morris-Pratt, like in the reference + implementation. */ +SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Does string @var{s1} contain string @var{s2}? Return the index\n" + "in @var{s1} where @var{s2} occurs as a substring, or false.\n" + "The optional start/end indices restrict the operation to the\n" + "indicated substrings. Character comparison is done\n" + "case-insensitively.") +#define FUNC_NAME s_scm_string_contains_ci +{ + const char *cs1, * cs2; + size_t cstart1, cend1, cstart2, cend2; + size_t len2, i, j; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2, + 5, start2, cstart2, + 6, end2, cend2); + len2 = cend2 - cstart2; + while (cstart1 <= cend1 - len2) + { + i = cstart1; + j = cstart2; + while (i < cend1 && j < cend2 && + scm_c_downcase (cs1[i]) == scm_c_downcase (cs2[j])) + { + i++; + j++; + } + if (j == cend2) + return scm_from_size_t (cstart1); + cstart1++; + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +/* Helper function for the string uppercase conversion functions. + * No argument checking is performed. */ +static SCM +string_upcase_x (SCM v, int start, int end) +{ + size_t k; + char *dst; + + dst = scm_i_string_writable_chars (v); + for (k = start; k < end; ++k) + dst[k] = scm_c_upcase (dst[k]); + scm_i_string_stop_writing (); + + return v; +} + +SCM_DEFINE (scm_substring_upcase_x, "string-upcase!", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Destructively upcase every character in @code{str}.\n" + "\n" + "@lisp\n" + "(string-upcase! y)\n" + "@result{} \"ARRDEFG\"\n" + "y\n" + "@result{} \"ARRDEFG\"\n" + "@end lisp") +#define FUNC_NAME s_scm_substring_upcase_x +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_upcase_x (str, cstart, cend); +} +#undef FUNC_NAME + +SCM +scm_string_upcase_x (SCM str) +{ + return scm_substring_upcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED); +} + +SCM_DEFINE (scm_substring_upcase, "string-upcase", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Upcase every character in @code{str}.") +#define FUNC_NAME s_scm_substring_upcase +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_upcase_x (scm_string_copy (str), cstart, cend); +} +#undef FUNC_NAME + +SCM +scm_string_upcase (SCM str) +{ + return scm_substring_upcase (str, SCM_UNDEFINED, SCM_UNDEFINED); +} + +/* Helper function for the string lowercase conversion functions. + * No argument checking is performed. */ +static SCM +string_downcase_x (SCM v, int start, int end) +{ + size_t k; + char *dst; + + dst = scm_i_string_writable_chars (v); + for (k = start; k < end; ++k) + dst[k] = scm_c_downcase (dst[k]); + scm_i_string_stop_writing (); + + return v; +} + +SCM_DEFINE (scm_substring_downcase_x, "string-downcase!", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Destructively downcase every character in @var{str}.\n" + "\n" + "@lisp\n" + "y\n" + "@result{} \"ARRDEFG\"\n" + "(string-downcase! y)\n" + "@result{} \"arrdefg\"\n" + "y\n" + "@result{} \"arrdefg\"\n" + "@end lisp") +#define FUNC_NAME s_scm_substring_downcase_x +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_downcase_x (str, cstart, cend); +} +#undef FUNC_NAME + +SCM +scm_string_downcase_x (SCM str) +{ + return scm_substring_downcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED); +} + +SCM_DEFINE (scm_substring_downcase, "string-downcase", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Downcase every character in @var{str}.") +#define FUNC_NAME s_scm_substring_downcase +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_downcase_x (scm_string_copy (str), cstart, cend); +} +#undef FUNC_NAME + +SCM +scm_string_downcase (SCM str) +{ + return scm_substring_downcase (str, SCM_UNDEFINED, SCM_UNDEFINED); +} + +/* Helper function for the string capitalization functions. + * No argument checking is performed. */ +static SCM +string_titlecase_x (SCM str, int start, int end) +{ + unsigned char *sz; + size_t i; + int in_word = 0; + + sz = scm_i_string_writable_chars (str); + for(i = start; i < end; i++) + { + if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i])))) + { + if (!in_word) + { + sz[i] = scm_c_upcase(sz[i]); + in_word = 1; + } + else + { + sz[i] = scm_c_downcase(sz[i]); + } + } + else + in_word = 0; + } + scm_i_string_stop_writing (); + + return str; +} + + +SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Destructively titlecase every first character in a word in\n" + "@var{str}.") +#define FUNC_NAME s_scm_string_titlecase_x +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_titlecase_x (str, cstart, cend); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Titlecase every first character in a word in @var{str}.") +#define FUNC_NAME s_scm_string_titlecase +{ + const char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + return string_titlecase_x (scm_string_copy (str), cstart, cend); +} +#undef FUNC_NAME + +/* Old names, the functions. + */ + +SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, + (SCM str), + "Upcase the first character of every word in @var{str}\n" + "destructively and return @var{str}.\n" + "\n" + "@lisp\n" + "y @result{} \"hello world\"\n" + "(string-capitalize! y) @result{} \"Hello World\"\n" + "y @result{} \"Hello World\"\n" + "@end lisp") +#define FUNC_NAME s_scm_string_capitalize_x +{ + return scm_string_titlecase_x (str, SCM_UNDEFINED, SCM_UNDEFINED); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0, + (SCM str), + "Return a freshly allocated string with the characters in\n" + "@var{str}, where the first character of every word is\n" + "capitalized.") +#define FUNC_NAME s_scm_string_capitalize +{ + return scm_string_capitalize_x (scm_string_copy (str)); +} +#undef FUNC_NAME + + +/* Reverse the portion of @var{str} between str[cstart] (including) + and str[cend] excluding. */ +static void +string_reverse_x (char * str, int cstart, int cend) +{ + char tmp; + + cend--; + while (cstart < cend) + { + tmp = str[cstart]; + str[cstart] = str[cend]; + str[cend] = tmp; + cstart++; + cend--; + } +} + + +SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Reverse the string @var{str}. The optional arguments\n" + "@var{start} and @var{end} delimit the region of @var{str} to\n" + "operate on.") +#define FUNC_NAME s_scm_string_reverse +{ + const char *cstr; + char *ctarget; + size_t cstart, cend; + SCM result; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, + 2, start, cstart, + 3, end, cend); + result = scm_string_copy (str); + ctarget = scm_i_string_writable_chars (result); + string_reverse_x (ctarget, cstart, cend); + scm_i_string_stop_writing (); + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0, + (SCM str, SCM start, SCM end), + "Reverse the string @var{str} in-place. The optional arguments\n" + "@var{start} and @var{end} delimit the region of @var{str} to\n" + "operate on. The return value is unspecified.") +#define FUNC_NAME s_scm_string_reverse_x +{ + char *cstr; + size_t cstart, cend; + + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 2, start, cstart, + 3, end, cend); + + cstr = scm_i_string_writable_chars (str); + string_reverse_x (cstr, cstart, cend); + scm_i_string_stop_writing (); + + scm_remember_upto_here_1 (str); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1, + (SCM ls), + "Like @code{string-append}, but the result may share memory\n" + "with the argument strings.") +#define FUNC_NAME s_scm_string_append_shared +{ + long i; + + SCM_VALIDATE_REST_ARGUMENT (ls); + + /* Optimize the one-argument case. */ + i = scm_ilength (ls); + if (i == 1) + return SCM_CAR (ls); + else + return scm_string_append (ls); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0, + (SCM ls), + "Append the elements of @var{ls} (which must be strings)\n" + "together into a single string. Guaranteed to return a freshly\n" + "allocated string.") +#define FUNC_NAME s_scm_string_concatenate +{ + return scm_string_append (ls); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, 0, + (SCM ls, SCM final_string, SCM end), + "Without optional arguments, this procedure is equivalent to\n" + "\n" + "@smalllisp\n" + "(string-concatenate (reverse ls))\n" + "@end smalllisp\n" + "\n" + "If the optional argument @var{final_string} is specified, it is\n" + "consed onto the beginning to @var{ls} before performing the\n" + "list-reverse and string-concatenate operations. If @var{end}\n" + "is given, only the characters of @var{final_string} up to index\n" + "@var{end} are used.\n" + "\n" + "Guaranteed to return a freshly allocated string.") +#define FUNC_NAME s_scm_string_concatenate_reverse +{ + long strings; + SCM tmp, result; + size_t len = 0; + char * p; + size_t cend = 0; + + /* Check the optional arguments and calculate the additional length + of the result string. */ + if (!SCM_UNBNDP (final_string)) + { + SCM_VALIDATE_STRING (2, final_string); + if (!SCM_UNBNDP (end)) + { + cend = scm_to_unsigned_integer (end, + 0, + scm_i_string_length (final_string)); + } + else + { + cend = scm_i_string_length (final_string); + } + len += cend; + } + strings = scm_ilength (ls); + /* Validate the string list. */ + if (strings < 0) + SCM_WRONG_TYPE_ARG (1, ls); + + /* Calculate the length of the result string. */ + tmp = ls; + while (!SCM_NULLP (tmp)) + { + SCM elt = SCM_CAR (tmp); + SCM_VALIDATE_STRING (1, elt); + len += scm_i_string_length (elt); + tmp = SCM_CDR (tmp); + } + + result = scm_i_make_string (len, &p); + + p += len; + + /* Construct the result string, possibly by using the optional final + string. */ + if (!SCM_UNBNDP (final_string)) + { + p -= cend; + memmove (p, scm_i_string_chars (final_string), cend); + } + tmp = ls; + while (!SCM_NULLP (tmp)) + { + SCM elt = SCM_CAR (tmp); + p -= scm_i_string_length (elt); + memmove (p, scm_i_string_chars (elt), + scm_i_string_length (elt)); + tmp = SCM_CDR (tmp); + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_concatenate_shared, "string-concatenate/shared", 1, 0, 0, + (SCM ls), + "Like @code{string-concatenate}, but the result may share memory\n" + "with the strings in the list @var{ls}.") +#define FUNC_NAME s_scm_string_concatenate_shared +{ + return scm_string_append_shared (ls); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_concatenate_reverse_shared, "string-concatenate-reverse/shared", 1, 2, 0, + (SCM ls, SCM final_string, SCM end), + "Like @code{string-concatenate-reverse}, but the result may\n" + "share memory with the the strings in the @var{ls} arguments.") +#define FUNC_NAME s_scm_string_concatenate_reverse_shared +{ + /* Just call the non-sharing version. */ + return scm_string_concatenate_reverse (ls, final_string, end); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, + (SCM proc, SCM s, SCM start, SCM end), + "@var{proc} is a char->char procedure, it is mapped over\n" + "@var{s}. The order in which the procedure is applied to the\n" + "string elements is not specified.") +#define FUNC_NAME s_scm_string_map +{ + const char *cstr; + char *p; + size_t cstart, cend; + SCM result; + + SCM_VALIDATE_PROC (1, proc); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); + result = scm_i_make_string (cend - cstart, &p); + while (cstart < cend) + { + unsigned int c = (unsigned char) cstr[cstart]; + SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (c)); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); + cstr = scm_i_string_chars (s); + cstart++; + *p++ = SCM_CHAR (ch); + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0, + (SCM proc, SCM s, SCM start, SCM end), + "@var{proc} is a char->char procedure, it is mapped over\n" + "@var{s}. The order in which the procedure is applied to the\n" + "string elements is not specified. The string @var{s} is\n" + "modified in-place, the return value is not specified.") +#define FUNC_NAME s_scm_string_map_x +{ + size_t cstart, cend; + + SCM_VALIDATE_PROC (1, proc); + MY_VALIDATE_SUBSTRING_SPEC (2, s, + 3, start, cstart, + 4, end, cend); + while (cstart < cend) + { + SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart)); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); + scm_c_string_set_x (s, cstart, ch); + cstart++; + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0, + (SCM kons, SCM knil, SCM s, SCM start, SCM end), + "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n" + "as the terminating element, from left to right. @var{kons}\n" + "must expect two arguments: The actual character and the last\n" + "result of @var{kons}' application.") +#define FUNC_NAME s_scm_string_fold +{ + const char *cstr; + size_t cstart, cend; + SCM result; + + SCM_VALIDATE_PROC (1, kons); + MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, + 4, start, cstart, + 5, end, cend); + result = knil; + while (cstart < cend) + { + unsigned int c = (unsigned char) cstr[cstart]; + result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result); + cstr = scm_i_string_chars (s); + cstart++; + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0, + (SCM kons, SCM knil, SCM s, SCM start, SCM end), + "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n" + "as the terminating element, from right to left. @var{kons}\n" + "must expect two arguments: The actual character and the last\n" + "result of @var{kons}' application.") +#define FUNC_NAME s_scm_string_fold_right +{ + const char *cstr; + size_t cstart, cend; + SCM result; + + SCM_VALIDATE_PROC (1, kons); + MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, + 4, start, cstart, + 5, end, cend); + result = knil; + while (cstart < cend) + { + unsigned int c = (unsigned char) cstr[cend - 1]; + result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result); + cstr = scm_i_string_chars (s); + cend--; + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0, + (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final), + "@itemize @bullet\n" + "@item @var{g} is used to generate a series of @emph{seed}\n" + "values from the initial @var{seed}: @var{seed}, (@var{g}\n" + "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n" + "@dots{}\n" + "@item @var{p} tells us when to stop -- when it returns true\n" + "when applied to one of these seed values.\n" + "@item @var{f} maps each seed value to the corresponding\n" + "character in the result string. These chars are assembled\n" + "into the string in a left-to-right order.\n" + "@item @var{base} is the optional initial/leftmost portion\n" + "of the constructed string; it default to the empty\n" + "string.\n" + "@item @var{make_final} is applied to the terminal seed\n" + "value (on which @var{p} returns true) to produce\n" + "the final/rightmost portion of the constructed string.\n" + "It defaults to @code{(lambda (x) "")}.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_unfold +{ + SCM res, ans; + + SCM_VALIDATE_PROC (1, p); + SCM_VALIDATE_PROC (2, f); + SCM_VALIDATE_PROC (3, g); + if (!SCM_UNBNDP (base)) + { + SCM_VALIDATE_STRING (5, base); + ans = base; + } + else + ans = scm_i_make_string (0, NULL); + if (!SCM_UNBNDP (make_final)) + SCM_VALIDATE_PROC (6, make_final); + + res = scm_call_1 (p, seed); + while (scm_is_false (res)) + { + SCM str; + char *ptr; + SCM ch = scm_call_1 (f, seed); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); + str = scm_i_make_string (1, &ptr); + *ptr = SCM_CHAR (ch); + + ans = scm_string_append (scm_list_2 (ans, str)); + seed = scm_call_1 (g, seed); + res = scm_call_1 (p, seed); + } + if (!SCM_UNBNDP (make_final)) + { + res = scm_call_1 (make_final, seed); + return scm_string_append (scm_list_2 (ans, res)); + } + else + return ans; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0, + (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final), + "@itemize @bullet\n" + "@item @var{g} is used to generate a series of @emph{seed}\n" + "values from the initial @var{seed}: @var{seed}, (@var{g}\n" + "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n" + "@dots{}\n" + "@item @var{p} tells us when to stop -- when it returns true\n" + "when applied to one of these seed values.\n" + "@item @var{f} maps each seed value to the corresponding\n" + "character in the result string. These chars are assembled\n" + "into the string in a right-to-left order.\n" + "@item @var{base} is the optional initial/rightmost portion\n" + "of the constructed string; it default to the empty\n" + "string.\n" + "@item @var{make_final} is applied to the terminal seed\n" + "value (on which @var{p} returns true) to produce\n" + "the final/leftmost portion of the constructed string.\n" + "It defaults to @code{(lambda (x) "")}.\n" + "@end itemize") +#define FUNC_NAME s_scm_string_unfold_right +{ + SCM res, ans; + + SCM_VALIDATE_PROC (1, p); + SCM_VALIDATE_PROC (2, f); + SCM_VALIDATE_PROC (3, g); + if (!SCM_UNBNDP (base)) + { + SCM_VALIDATE_STRING (5, base); + ans = base; + } + else + ans = scm_i_make_string (0, NULL); + if (!SCM_UNBNDP (make_final)) + SCM_VALIDATE_PROC (6, make_final); + + res = scm_call_1 (p, seed); + while (scm_is_false (res)) + { + SCM str; + char *ptr; + SCM ch = scm_call_1 (f, seed); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); + str = scm_i_make_string (1, &ptr); + *ptr = SCM_CHAR (ch); + + ans = scm_string_append (scm_list_2 (str, ans)); + seed = scm_call_1 (g, seed); + res = scm_call_1 (p, seed); + } + if (!SCM_UNBNDP (make_final)) + { + res = scm_call_1 (make_final, seed); + return scm_string_append (scm_list_2 (res, ans)); + } + else + return ans; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0, + (SCM proc, SCM s, SCM start, SCM end), + "@var{proc} is mapped over @var{s} in left-to-right order. The\n" + "return value is not specified.") +#define FUNC_NAME s_scm_string_for_each +{ + const char *cstr; + size_t cstart, cend; + + SCM_VALIDATE_PROC (1, proc); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); + while (cstart < cend) + { + unsigned int c = (unsigned char) cstr[cstart]; + scm_call_1 (proc, SCM_MAKE_CHAR (c)); + cstr = scm_i_string_chars (s); + cstart++; + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0, + (SCM proc, SCM s, SCM start, SCM end), + "@var{proc} is mapped over @var{s} in left-to-right order. The\n" + "return value is not specified.") +#define FUNC_NAME s_scm_string_for_each_index +{ + const char *cstr; + size_t cstart, cend; + + SCM_VALIDATE_PROC (1, proc); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, + 3, start, cstart, + 4, end, cend); + while (cstart < cend) + { + scm_call_1 (proc, scm_from_size_t (cstart)); + cstart++; + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, + (SCM s, SCM from, SCM to, SCM start, SCM end), + "This is the @emph{extended substring} procedure that implements\n" + "replicated copying of a substring of some string.\n" + "\n" + "@var{s} is a string, @var{start} and @var{end} are optional\n" + "arguments that demarcate a substring of @var{s}, defaulting to\n" + "0 and the length of @var{s}. Replicate this substring up and\n" + "down index space, in both the positive and negative directions.\n" + "@code{xsubstring} returns the substring of this string\n" + "beginning at index @var{from}, and ending at @var{to}, which\n" + "defaults to @var{from} + (@var{end} - @var{start}).") +#define FUNC_NAME s_scm_xsubstring +{ + const char *cs; + char *p; + size_t cstart, cend, cfrom, cto; + SCM result; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cs, + 4, start, cstart, + 5, end, cend); + cfrom = scm_to_size_t (from); + if (SCM_UNBNDP (to)) + cto = cfrom + (cend - cstart); + else + cto = scm_to_size_t (to); + if (cstart == cend && cfrom != cto) + SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); + + result = scm_i_make_string (cto - cfrom, &p); + + while (cfrom < cto) + { + int t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart); + if (cfrom < 0) + *p = cs[(cend - cstart) - t]; + else + *p = cs[t]; + cfrom++; + p++; + } + scm_remember_upto_here_1 (s); + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, + (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end), + "Exactly the same as @code{xsubstring}, but the extracted text\n" + "is written into the string @var{target} starting at index\n" + "@var{tstart}. The operation is not defined if @code{(eq?\n" + "@var{target} @var{s})} or these arguments share storage -- you\n" + "cannot copy a string on top of itself.") +#define FUNC_NAME s_scm_string_xcopy_x +{ + char *p; + const char *cs; + size_t ctstart, csfrom, csto, cstart, cend; + SCM dummy = SCM_UNDEFINED; + int cdummy; + + MY_VALIDATE_SUBSTRING_SPEC (1, target, + 2, tstart, ctstart, + 2, dummy, cdummy); + MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cs, + 6, start, cstart, + 7, end, cend); + csfrom = scm_to_size_t (sfrom); + if (SCM_UNBNDP (sto)) + csto = csfrom + (cend - cstart); + else + csto = scm_to_size_t (sto); + if (cstart == cend && csfrom != csto) + SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); + SCM_ASSERT_RANGE (1, tstart, + ctstart + (csto - csfrom) <= scm_i_string_length (target)); + + p = scm_i_string_writable_chars (target) + ctstart; + while (csfrom < csto) + { + int t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart); + if (csfrom < 0) + *p = cs[(cend - cstart) - t]; + else + *p = cs[t]; + csfrom++; + p++; + } + scm_i_string_stop_writing (); + + scm_remember_upto_here_2 (target, s); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return the string @var{s1}, but with the characters\n" + "@var{start1} @dots{} @var{end1} replaced by the characters\n" + "@var{start2} @dots{} @var{end2} from @var{s2}.") +#define FUNC_NAME s_scm_string_replace +{ + const char *cstr1, *cstr2; + char *p; + size_t cstart1, cend1, cstart2, cend2; + SCM result; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + 5, start2, cstart2, + 6, end2, cend2); + result = scm_i_make_string (cstart1 + (cend2 - cstart2) + + scm_i_string_length (s1) - cend1, &p); + memmove (p, cstr1, cstart1 * sizeof (char)); + memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2) * sizeof (char)); + memmove (p + cstart1 + (cend2 - cstart2), + cstr1 + cend1, + (scm_i_string_length (s1) - cend1) * sizeof (char)); + scm_remember_upto_here_2 (s1, s2); + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, + (SCM s, SCM token_set, SCM start, SCM end), + "Split the string @var{s} into a list of substrings, where each\n" + "substring is a maximal non-empty contiguous sequence of\n" + "characters from the character set @var{token_set}, which\n" + "defaults to @code{char-set:graphic}.\n" + "If @var{start} or @var{end} indices are provided, they restrict\n" + "@code{string-tokenize} to operating on the indicated substring\n" + "of @var{s}.") +#define FUNC_NAME s_scm_string_tokenize +{ + const char *cstr; + size_t cstart, cend; + SCM result = SCM_EOL; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + + if (SCM_UNBNDP (token_set)) + token_set = scm_char_set_graphic; + + if (SCM_CHARSETP (token_set)) + { + int idx; + + while (cstart < cend) + { + while (cstart < cend) + { + if (SCM_CHARSET_GET (token_set, cstr[cend - 1])) + break; + cend--; + } + if (cstart >= cend) + break; + idx = cend; + while (cstart < cend) + { + if (!SCM_CHARSET_GET (token_set, cstr[cend - 1])) + break; + cend--; + } + result = scm_cons (scm_c_substring (s, cend, idx), result); + cstr = scm_i_string_chars (s); + } + } + else SCM_WRONG_TYPE_ARG (2, token_set); + scm_remember_upto_here_1 (s); + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, + (SCM str, SCM chr), + "Split the string @var{str} into the a list of the substrings delimited\n" + "by appearances of the character @var{chr}. Note that an empty substring\n" + "between separator characters will result in an empty string in the\n" + "result list.\n" + "\n" + "@lisp\n" + "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n" + "@result{}\n" + "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n" + "\n" + "(string-split \"::\" #\\:)\n" + "@result{}\n" + "(\"\" \"\" \"\")\n" + "\n" + "(string-split \"\" #\\:)\n" + "@result{}\n" + "(\"\")\n" + "@end lisp") +#define FUNC_NAME s_scm_string_split +{ + long idx, last_idx; + const char * p; + int ch; + SCM res = SCM_EOL; + + SCM_VALIDATE_STRING (1, str); + SCM_VALIDATE_CHAR (2, chr); + + idx = scm_i_string_length (str); + p = scm_i_string_chars (str); + ch = SCM_CHAR (chr); + while (idx >= 0) + { + last_idx = idx; + while (idx > 0 && p[idx - 1] != ch) + idx--; + if (idx >= 0) + { + res = scm_cons (scm_c_substring (str, idx, last_idx), res); + p = scm_i_string_chars (str); + idx--; + } + } + scm_remember_upto_here_1 (str); + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Filter the string @var{s}, retaining only those characters that\n" + "satisfy the @var{char_pred} argument. If the argument is a\n" + "procedure, it is applied to each character as a predicate, if\n" + "it is a character, it is tested for equality and if it is a\n" + "character set, it is tested for membership.") +#define FUNC_NAME s_scm_string_filter +{ + const char *cstr; + size_t cstart, cend; + SCM result; + size_t idx; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + SCM ls = SCM_EOL; + char chr; + + chr = SCM_CHAR (char_pred); + idx = cstart; + while (idx < cend) + { + if (cstr[idx] == chr) + ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + cstr = scm_i_string_chars (s); + idx++; + } + result = scm_reverse_list_to_string (ls); + } + else if (SCM_CHARSETP (char_pred)) + { + SCM ls = SCM_EOL; + + idx = cstart; + while (idx < cend) + { + if (SCM_CHARSET_GET (char_pred, cstr[idx])) + ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + cstr = scm_i_string_chars (s); + idx++; + } + result = scm_reverse_list_to_string (ls); + } + else + { + SCM ls = SCM_EOL; + + SCM_VALIDATE_PROC (2, char_pred); + idx = cstart; + while (idx < cend) + { + SCM res; + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx])); + if (scm_is_true (res)) + ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + cstr = scm_i_string_chars (s); + idx++; + } + result = scm_reverse_list_to_string (ls); + } + scm_remember_upto_here_1 (s); + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, + (SCM s, SCM char_pred, SCM start, SCM end), + "Filter the string @var{s}, retaining only those characters that\n" + "do not satisfy the @var{char_pred} argument. If the argument\n" + "is a procedure, it is applied to each character as a predicate,\n" + "if it is a character, it is tested for equality and if it is a\n" + "character set, it is tested for membership.") +#define FUNC_NAME s_scm_string_delete +{ + const char *cstr; + size_t cstart, cend; + SCM result; + size_t idx; + + MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, + 3, start, cstart, + 4, end, cend); + if (SCM_CHARP (char_pred)) + { + SCM ls = SCM_EOL; + char chr; + + chr = SCM_CHAR (char_pred); + idx = cstart; + while (idx < cend) + { + if (cstr[idx] != chr) + ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + cstr = scm_i_string_chars (s); + idx++; + } + result = scm_reverse_list_to_string (ls); + } + else if (SCM_CHARSETP (char_pred)) + { + SCM ls = SCM_EOL; + + idx = cstart; + while (idx < cend) + { + if (!SCM_CHARSET_GET (char_pred, cstr[idx])) + ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + cstr = scm_i_string_chars (s); + idx++; + } + result = scm_reverse_list_to_string (ls); + } + else + { + SCM ls = SCM_EOL; + + SCM_VALIDATE_PROC (2, char_pred); + idx = cstart; + while (idx < cend) + { + SCM res; + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx])); + if (scm_is_false (res)) + ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + cstr = scm_i_string_chars (s); + idx++; + } + result = scm_reverse_list_to_string (ls); + } + return result; +} +#undef FUNC_NAME + + +/* Initialize the SRFI-13 module. This function will be called by the + loading Scheme module. */ +void +scm_init_srfi_13 (void) +{ +#include "libguile/srfi-13.x" +} + +/* End of srfi-13.c. */ diff --git a/libguile/srfi-13.h b/libguile/srfi-13.h new file mode 100644 index 000000000..3eec270aa --- /dev/null +++ b/libguile/srfi-13.h @@ -0,0 +1,119 @@ +#ifndef SCM_SRFI_13_H +#define SCM_SRFI_13_H + +/* srfi-13.c --- SRFI-13 procedures for Guile + * + * Copyright (C) 2001, 2004 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + +#include "libguile/__scm.h" + +SCM_API SCM scm_string_null_p (SCM s); +SCM_API SCM scm_string_any (SCM pred, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_every (SCM pred, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_tabulate (SCM proc, SCM len); +SCM_API SCM scm_string_to_list (SCM str); +SCM_API SCM scm_substring_to_list (SCM str, SCM start, SCM end); +SCM_API SCM scm_reverse_list_to_string (SCM chrs); +SCM_API SCM scm_string_join (SCM ls, SCM delimiter, SCM grammar); +SCM_API SCM scm_string_copy (SCM str); +SCM_API SCM scm_string_copy_x (SCM target, SCM tstart, SCM s, SCM start, SCM end); +SCM_API SCM scm_substring_move_x (SCM str1, SCM start1, SCM end1, + SCM str2, SCM start2); +SCM_API SCM scm_string_take (SCM s, SCM n); +SCM_API SCM scm_string_drop (SCM s, SCM n); +SCM_API SCM scm_string_take_right (SCM s, SCM n); +SCM_API SCM scm_string_drop_right (SCM s, SCM n); +SCM_API SCM scm_string_pad (SCM s, SCM len, SCM chr, SCM start, SCM end); +SCM_API SCM scm_string_pad_right (SCM s, SCM len, SCM chr, SCM start, SCM end); +SCM_API SCM scm_string_trim (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_trim_right (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_trim_both (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_substring_fill_x (SCM str, SCM chr, SCM start, SCM end); +SCM_API SCM scm_string_fill_x (SCM str, SCM chr); +SCM_API SCM scm_string_compare (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_compare_ci (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ci_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ci_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ci_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ci_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ci_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_ci_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_substring_hash (SCM s, SCM bound, SCM start, SCM end); +SCM_API SCM scm_substring_hash_ci (SCM s, SCM bound, SCM start, SCM end); +SCM_API SCM scm_string_prefix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_prefix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_suffix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_suffix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_prefix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_prefix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_suffix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_suffix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_index (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_index_right (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_rindex (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_skip (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_skip_right (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_count (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_contains (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_contains_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_substring_upcase_x (SCM str, SCM start, SCM end); +SCM_API SCM scm_substring_upcase (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_upcase_x (SCM str); +SCM_API SCM scm_string_upcase (SCM str); +SCM_API SCM scm_substring_downcase_x (SCM str, SCM start, SCM end); +SCM_API SCM scm_substring_downcase (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_downcase_x (SCM str); +SCM_API SCM scm_string_downcase (SCM str); +SCM_API SCM scm_string_titlecase_x (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_titlecase (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_capitalize_x (SCM str); +SCM_API SCM scm_string_capitalize (SCM str); +SCM_API SCM scm_string_reverse (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_reverse_x (SCM str, SCM start, SCM end); +SCM_API SCM scm_string_append_shared (SCM ls); +SCM_API SCM scm_string_concatenate (SCM ls); +SCM_API SCM scm_string_concatenate_shared (SCM ls); +SCM_API SCM scm_string_concatenate_reverse (SCM ls, SCM final_string, SCM end); +SCM_API SCM scm_string_concatenate_reverse_shared (SCM ls, SCM final_string, SCM end); +SCM_API SCM scm_string_map (SCM proc, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_map_x (SCM proc, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_fold (SCM kons, SCM knil, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_fold_right (SCM kons, SCM knil, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final); +SCM_API SCM scm_string_unfold_right (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final); +SCM_API SCM scm_string_for_each (SCM proc, SCM s, SCM start, SCM end); +SCM_API SCM scm_string_for_each_index (SCM proc, SCM s, SCM start, SCM end); +SCM_API SCM scm_xsubstring (SCM s, SCM from, SCM to, SCM start, SCM end); +SCM_API SCM scm_string_xcopy_x (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end); +SCM_API SCM scm_string_replace (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); +SCM_API SCM scm_string_tokenize (SCM s, SCM token_char, SCM start, SCM end); +SCM_API SCM scm_string_split (SCM s, SCM chr); +SCM_API SCM scm_string_filter (SCM s, SCM char_pred, SCM start, SCM end); +SCM_API SCM scm_string_delete (SCM s, SCM char_pred, SCM start, SCM end); + +SCM_API void scm_init_srfi_13 (void); +SCM_API void scm_init_srfi_13_14 (void); + +#endif /* SCM_SRFI_13_H */ diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c new file mode 100644 index 000000000..c2a6a9a0c --- /dev/null +++ b/libguile/srfi-14.c @@ -0,0 +1,1486 @@ +/* srfi-14.c --- SRFI-14 procedures for Guile + * + * Copyright (C) 2001, 2004 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + +#include +#include + +#include "libguile.h" +#include "libguile/srfi-14.h" + + +#define SCM_CHARSET_SET(cs, idx) \ + (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= \ + (1L << ((idx) % SCM_BITS_PER_LONG))) + +#define BYTES_PER_CHARSET (SCM_CHARSET_SIZE / 8) +#define LONGS_PER_CHARSET (SCM_CHARSET_SIZE / SCM_BITS_PER_LONG) + + +/* Smob type code for character sets. */ +int scm_tc16_charset = 0; + + +/* Smob print hook for character sets. */ +static int +charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED) +{ + int i; + int first = 1; + + scm_puts ("#", port); + return 1; +} + + +/* Smob free hook for character sets. */ +static size_t +charset_free (SCM charset) +{ + return scm_smob_free (charset); +} + + +/* Create a new, empty character set. */ +static SCM +make_char_set (const char * func_name) +{ + long * p; + + p = scm_gc_malloc (BYTES_PER_CHARSET, "character-set"); + memset (p, 0, BYTES_PER_CHARSET); + SCM_RETURN_NEWSMOB (scm_tc16_charset, p); +} + + +SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a character set, @code{#f}\n" + "otherwise.") +#define FUNC_NAME s_scm_char_set_p +{ + return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_charset, obj)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, + (SCM char_sets), + "Return @code{#t} if all given character sets are equal.") +#define FUNC_NAME s_scm_char_set_eq +{ + int argnum = 1; + long *cs1_data = NULL; + + SCM_VALIDATE_REST_ARGUMENT (char_sets); + + while (!SCM_NULLP (char_sets)) + { + SCM csi = SCM_CAR (char_sets); + long *csi_data; + + SCM_VALIDATE_SMOB (argnum, csi, charset); + argnum++; + csi_data = (long *) SCM_SMOB_DATA (csi); + if (cs1_data == NULL) + cs1_data = csi_data; + else if (memcmp (cs1_data, csi_data, BYTES_PER_CHARSET) != 0) + return SCM_BOOL_F; + char_sets = SCM_CDR (char_sets); + } + return SCM_BOOL_T; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1, + (SCM char_sets), + "Return @code{#t} if every character set @var{cs}i is a subset\n" + "of character set @var{cs}i+1.") +#define FUNC_NAME s_scm_char_set_leq +{ + int argnum = 1; + long *prev_data = NULL; + + SCM_VALIDATE_REST_ARGUMENT (char_sets); + + while (!SCM_NULLP (char_sets)) + { + SCM csi = SCM_CAR (char_sets); + long *csi_data; + + SCM_VALIDATE_SMOB (argnum, csi, charset); + argnum++; + csi_data = (long *) SCM_SMOB_DATA (csi); + if (prev_data) + { + int k; + + for (k = 0; k < LONGS_PER_CHARSET; k++) + { + if ((prev_data[k] & csi_data[k]) != prev_data[k]) + return SCM_BOOL_F; + } + } + prev_data = csi_data; + char_sets = SCM_CDR (char_sets); + } + return SCM_BOOL_T; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, + (SCM cs, SCM bound), + "Compute a hash value for the character set @var{cs}. If\n" + "@var{bound} is given and non-zero, it restricts the\n" + "returned value to the range 0 @dots{} @var{bound - 1}.") +#define FUNC_NAME s_scm_char_set_hash +{ + const unsigned long default_bnd = 871; + unsigned long bnd; + long * p; + unsigned long val = 0; + int k; + + SCM_VALIDATE_SMOB (1, cs, charset); + + if (SCM_UNBNDP (bound)) + bnd = default_bnd; + else + { + bnd = scm_to_ulong (bound); + if (bnd == 0) + bnd = default_bnd; + } + + p = (long *) SCM_SMOB_DATA (cs); + for (k = 0; k < LONGS_PER_CHARSET; k++) + { + if (p[k] != 0) + val = p[k] + (val << 1); + } + return scm_from_ulong (val % bnd); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0, + (SCM cs), + "Return a cursor into the character set @var{cs}.") +#define FUNC_NAME s_scm_char_set_cursor +{ + int idx; + + SCM_VALIDATE_SMOB (1, cs, charset); + for (idx = 0; idx < SCM_CHARSET_SIZE; idx++) + { + if (SCM_CHARSET_GET (cs, idx)) + break; + } + return SCM_I_MAKINUM (idx); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0, + (SCM cs, SCM cursor), + "Return the character at the current cursor position\n" + "@var{cursor} in the character set @var{cs}. It is an error to\n" + "pass a cursor for which @code{end-of-char-set?} returns true.") +#define FUNC_NAME s_scm_char_set_ref +{ + size_t ccursor = scm_to_size_t (cursor); + SCM_VALIDATE_SMOB (1, cs, charset); + + if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) + SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); + return SCM_MAKE_CHAR (ccursor); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0, + (SCM cs, SCM cursor), + "Advance the character set cursor @var{cursor} to the next\n" + "character in the character set @var{cs}. It is an error if the\n" + "cursor given satisfies @code{end-of-char-set?}.") +#define FUNC_NAME s_scm_char_set_cursor_next +{ + size_t ccursor = scm_to_size_t (cursor); + SCM_VALIDATE_SMOB (1, cs, charset); + + if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) + SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); + for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++) + { + if (SCM_CHARSET_GET (cs, ccursor)) + break; + } + return SCM_I_MAKINUM (ccursor); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0, + (SCM cursor), + "Return @code{#t} if @var{cursor} has reached the end of a\n" + "character set, @code{#f} otherwise.") +#define FUNC_NAME s_scm_end_of_char_set_p +{ + size_t ccursor = scm_to_size_t (cursor); + return scm_from_bool (ccursor >= SCM_CHARSET_SIZE); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0, + (SCM kons, SCM knil, SCM cs), + "Fold the procedure @var{kons} over the character set @var{cs},\n" + "initializing it with @var{knil}.") +#define FUNC_NAME s_scm_char_set_fold +{ + int k; + + SCM_VALIDATE_PROC (1, kons); + SCM_VALIDATE_SMOB (3, cs, charset); + + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + { + knil = scm_call_2 (kons, SCM_MAKE_CHAR (k), knil); + } + return knil; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0, + (SCM p, SCM f, SCM g, SCM seed, SCM base_cs), + "This is a fundamental constructor for character sets.\n" + "@itemize @bullet\n" + "@item @var{g} is used to generate a series of ``seed'' values\n" + "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n" + "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n" + "@item @var{p} tells us when to stop -- when it returns true\n" + "when applied to one of the seed values.\n" + "@item @var{f} maps each seed value to a character. These\n" + "characters are added to the base character set @var{base_cs} to\n" + "form the result; @var{base_cs} defaults to the empty set.\n" + "@end itemize") +#define FUNC_NAME s_scm_char_set_unfold +{ + SCM result, tmp; + + SCM_VALIDATE_PROC (1, p); + SCM_VALIDATE_PROC (2, f); + SCM_VALIDATE_PROC (3, g); + if (!SCM_UNBNDP (base_cs)) + { + SCM_VALIDATE_SMOB (5, base_cs, charset); + result = scm_char_set_copy (base_cs); + } + else + result = make_char_set (FUNC_NAME); + + tmp = scm_call_1 (p, seed); + while (scm_is_false (tmp)) + { + SCM ch = scm_call_1 (f, seed); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); + SCM_CHARSET_SET (result, SCM_CHAR (ch)); + + seed = scm_call_1 (g, seed); + tmp = scm_call_1 (p, seed); + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0, + (SCM p, SCM f, SCM g, SCM seed, SCM base_cs), + "This is a fundamental constructor for character sets.\n" + "@itemize @bullet\n" + "@item @var{g} is used to generate a series of ``seed'' values\n" + "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n" + "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n" + "@item @var{p} tells us when to stop -- when it returns true\n" + "when applied to one of the seed values.\n" + "@item @var{f} maps each seed value to a character. These\n" + "characters are added to the base character set @var{base_cs} to\n" + "form the result; @var{base_cs} defaults to the empty set.\n" + "@end itemize") +#define FUNC_NAME s_scm_char_set_unfold_x +{ + SCM tmp; + + SCM_VALIDATE_PROC (1, p); + SCM_VALIDATE_PROC (2, f); + SCM_VALIDATE_PROC (3, g); + SCM_VALIDATE_SMOB (5, base_cs, charset); + + tmp = scm_call_1 (p, seed); + while (scm_is_false (tmp)) + { + SCM ch = scm_call_1 (f, seed); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); + SCM_CHARSET_SET (base_cs, SCM_CHAR (ch)); + + seed = scm_call_1 (g, seed); + tmp = scm_call_1 (p, seed); + } + return base_cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0, + (SCM proc, SCM cs), + "Apply @var{proc} to every character in the character set\n" + "@var{cs}. The return value is not specified.") +#define FUNC_NAME s_scm_char_set_for_each +{ + int k; + + SCM_VALIDATE_PROC (1, proc); + SCM_VALIDATE_SMOB (2, cs, charset); + + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + scm_call_1 (proc, SCM_MAKE_CHAR (k)); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0, + (SCM proc, SCM cs), + "Map the procedure @var{proc} over every character in @var{cs}.\n" + "@var{proc} must be a character -> character procedure.") +#define FUNC_NAME s_scm_char_set_map +{ + SCM result; + int k; + + SCM_VALIDATE_PROC (1, proc); + SCM_VALIDATE_SMOB (2, cs, charset); + + result = make_char_set (FUNC_NAME); + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + { + SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (k)); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); + SCM_CHARSET_SET (result, SCM_CHAR (ch)); + } + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0, + (SCM cs), + "Return a newly allocated character set containing all\n" + "characters in @var{cs}.") +#define FUNC_NAME s_scm_char_set_copy +{ + SCM ret; + long * p1, * p2; + int k; + + SCM_VALIDATE_SMOB (1, cs, charset); + ret = make_char_set (FUNC_NAME); + p1 = (long *) SCM_SMOB_DATA (cs); + p2 = (long *) SCM_SMOB_DATA (ret); + for (k = 0; k < LONGS_PER_CHARSET; k++) + p2[k] = p1[k]; + return ret; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1, + (SCM rest), + "Return a character set containing all given characters.") +#define FUNC_NAME s_scm_char_set +{ + SCM cs; + long * p; + int argnum = 1; + + SCM_VALIDATE_REST_ARGUMENT (rest); + cs = make_char_set (FUNC_NAME); + p = (long *) SCM_SMOB_DATA (cs); + while (!SCM_NULLP (rest)) + { + int c; + + SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c); + argnum++; + rest = SCM_CDR (rest); + p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + } + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0, + (SCM list, SCM base_cs), + "Convert the character list @var{list} to a character set. If\n" + "the character set @var{base_cs} is given, the character in this\n" + "set are also included in the result.") +#define FUNC_NAME s_scm_list_to_char_set +{ + SCM cs; + long * p; + + SCM_VALIDATE_LIST (1, list); + if (SCM_UNBNDP (base_cs)) + cs = make_char_set (FUNC_NAME); + else + { + SCM_VALIDATE_SMOB (2, base_cs, charset); + cs = scm_char_set_copy (base_cs); + } + p = (long *) SCM_SMOB_DATA (cs); + while (!SCM_NULLP (list)) + { + SCM chr = SCM_CAR (list); + int c; + + SCM_VALIDATE_CHAR_COPY (0, chr, c); + list = SCM_CDR (list); + + p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + } + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0, + (SCM list, SCM base_cs), + "Convert the character list @var{list} to a character set. The\n" + "characters are added to @var{base_cs} and @var{base_cs} is\n" + "returned.") +#define FUNC_NAME s_scm_list_to_char_set_x +{ + long * p; + + SCM_VALIDATE_LIST (1, list); + SCM_VALIDATE_SMOB (2, base_cs, charset); + p = (long *) SCM_SMOB_DATA (base_cs); + while (!SCM_NULLP (list)) + { + SCM chr = SCM_CAR (list); + int c; + + SCM_VALIDATE_CHAR_COPY (0, chr, c); + list = SCM_CDR (list); + + p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + } + return base_cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, + (SCM str, SCM base_cs), + "Convert the string @var{str} to a character set. If the\n" + "character set @var{base_cs} is given, the characters in this\n" + "set are also included in the result.") +#define FUNC_NAME s_scm_string_to_char_set +{ + SCM cs; + long * p; + const char * s; + size_t k = 0, len; + + SCM_VALIDATE_STRING (1, str); + if (SCM_UNBNDP (base_cs)) + cs = make_char_set (FUNC_NAME); + else + { + SCM_VALIDATE_SMOB (2, base_cs, charset); + cs = scm_char_set_copy (base_cs); + } + p = (long *) SCM_SMOB_DATA (cs); + s = scm_i_string_chars (str); + len = scm_i_string_length (str); + while (k < len) + { + int c = s[k++]; + p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + } + scm_remember_upto_here_1 (str); + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0, + (SCM str, SCM base_cs), + "Convert the string @var{str} to a character set. The\n" + "characters from the string are added to @var{base_cs}, and\n" + "@var{base_cs} is returned.") +#define FUNC_NAME s_scm_string_to_char_set_x +{ + long * p; + const char * s; + size_t k = 0, len; + + SCM_VALIDATE_STRING (1, str); + SCM_VALIDATE_SMOB (2, base_cs, charset); + p = (long *) SCM_SMOB_DATA (base_cs); + s = scm_i_string_chars (str); + len = scm_i_string_length (str); + while (k < len) + { + int c = s[k++]; + p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + } + scm_remember_upto_here_1 (str); + return base_cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0, + (SCM pred, SCM cs, SCM base_cs), + "Return a character set containing every character from @var{cs}\n" + "so that it satisfies @var{pred}. If provided, the characters\n" + "from @var{base_cs} are added to the result.") +#define FUNC_NAME s_scm_char_set_filter +{ + SCM ret; + int k; + long * p; + + SCM_VALIDATE_PROC (1, pred); + SCM_VALIDATE_SMOB (2, cs, charset); + if (!SCM_UNBNDP (base_cs)) + { + SCM_VALIDATE_SMOB (3, base_cs, charset); + ret = scm_char_set_copy (base_cs); + } + else + ret = make_char_set (FUNC_NAME); + p = (long *) SCM_SMOB_DATA (ret); + for (k = 0; k < SCM_CHARSET_SIZE; k++) + { + if (SCM_CHARSET_GET (cs, k)) + { + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); + + if (scm_is_true (res)) + p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG); + } + } + return ret; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0, + (SCM pred, SCM cs, SCM base_cs), + "Return a character set containing every character from @var{cs}\n" + "so that it satisfies @var{pred}. The characters are added to\n" + "@var{base_cs} and @var{base_cs} is returned.") +#define FUNC_NAME s_scm_char_set_filter_x +{ + int k; + long * p; + + SCM_VALIDATE_PROC (1, pred); + SCM_VALIDATE_SMOB (2, cs, charset); + SCM_VALIDATE_SMOB (3, base_cs, charset); + p = (long *) SCM_SMOB_DATA (base_cs); + for (k = 0; k < SCM_CHARSET_SIZE; k++) + { + if (SCM_CHARSET_GET (cs, k)) + { + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); + + if (scm_is_true (res)) + p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG); + } + } + return base_cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, + (SCM lower, SCM upper, SCM error, SCM base_cs), + "Return a character set containing all characters whose\n" + "character codes lie in the half-open range\n" + "[@var{lower},@var{upper}).\n" + "\n" + "If @var{error} is a true value, an error is signalled if the\n" + "specified range contains characters which are not contained in\n" + "the implemented character range. If @var{error} is @code{#f},\n" + "these characters are silently left out of the resultung\n" + "character set.\n" + "\n" + "The characters in @var{base_cs} are added to the result, if\n" + "given.") +#define FUNC_NAME s_scm_ucs_range_to_char_set +{ + SCM cs; + size_t clower, cupper; + long * p; + + clower = scm_to_size_t (lower); + cupper = scm_to_size_t (upper); + SCM_ASSERT_RANGE (2, upper, cupper >= clower); + if (!SCM_UNBNDP (error)) + { + if (scm_is_true (error)) + { + SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); + SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE); + } + } + if (clower > SCM_CHARSET_SIZE) + clower = SCM_CHARSET_SIZE; + if (cupper > SCM_CHARSET_SIZE) + cupper = SCM_CHARSET_SIZE; + if (SCM_UNBNDP (base_cs)) + cs = make_char_set (FUNC_NAME); + else + { + SCM_VALIDATE_SMOB (4, base_cs, charset); + cs = scm_char_set_copy (base_cs); + } + p = (long *) SCM_SMOB_DATA (cs); + while (clower < cupper) + { + p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG); + clower++; + } + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0, + (SCM lower, SCM upper, SCM error, SCM base_cs), + "Return a character set containing all characters whose\n" + "character codes lie in the half-open range\n" + "[@var{lower},@var{upper}).\n" + "\n" + "If @var{error} is a true value, an error is signalled if the\n" + "specified range contains characters which are not contained in\n" + "the implemented character range. If @var{error} is @code{#f},\n" + "these characters are silently left out of the resultung\n" + "character set.\n" + "\n" + "The characters are added to @var{base_cs} and @var{base_cs} is\n" + "returned.") +#define FUNC_NAME s_scm_ucs_range_to_char_set_x +{ + size_t clower, cupper; + long * p; + + clower = scm_to_size_t (lower); + cupper = scm_to_size_t (upper); + SCM_ASSERT_RANGE (2, upper, cupper >= clower); + if (scm_is_true (error)) + { + SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); + SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE); + } + if (clower > SCM_CHARSET_SIZE) + clower = SCM_CHARSET_SIZE; + if (cupper > SCM_CHARSET_SIZE) + cupper = SCM_CHARSET_SIZE; + p = (long *) SCM_SMOB_DATA (base_cs); + while (clower < cupper) + { + p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG); + clower++; + } + return base_cs; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_to_char_set, "->char-set", 1, 0, 0, + (SCM x), + "Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is.") +#define FUNC_NAME s_scm_to_char_set +{ + if (scm_is_string (x)) + return scm_string_to_char_set (x, SCM_UNDEFINED); + else if (SCM_CHARP (x)) + return scm_char_set (scm_list_1 (x)); + else if (SCM_SMOB_PREDICATE (scm_tc16_charset, x)) + return x; + else + scm_wrong_type_arg (NULL, 0, x); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0, + (SCM cs), + "Return the number of elements in character set @var{cs}.") +#define FUNC_NAME s_scm_char_set_size +{ + int k, count = 0; + + SCM_VALIDATE_SMOB (1, cs, charset); + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + count++; + return SCM_I_MAKINUM (count); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0, + (SCM pred, SCM cs), + "Return the number of the elements int the character set\n" + "@var{cs} which satisfy the predicate @var{pred}.") +#define FUNC_NAME s_scm_char_set_count +{ + int k, count = 0; + + SCM_VALIDATE_PROC (1, pred); + SCM_VALIDATE_SMOB (2, cs, charset); + + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + { + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); + if (scm_is_true (res)) + count++; + } + return SCM_I_MAKINUM (count); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0, + (SCM cs), + "Return a list containing the elements of the character set\n" + "@var{cs}.") +#define FUNC_NAME s_scm_char_set_to_list +{ + int k; + SCM result = SCM_EOL; + + SCM_VALIDATE_SMOB (1, cs, charset); + for (k = SCM_CHARSET_SIZE; k > 0; k--) + if (SCM_CHARSET_GET (cs, k - 1)) + result = scm_cons (SCM_MAKE_CHAR (k - 1), result); + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0, + (SCM cs), + "Return a string containing the elements of the character set\n" + "@var{cs}. The order in which the characters are placed in the\n" + "string is not defined.") +#define FUNC_NAME s_scm_char_set_to_string +{ + int k; + int count = 0; + int idx = 0; + SCM result; + char * p; + + SCM_VALIDATE_SMOB (1, cs, charset); + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + count++; + result = scm_i_make_string (count, &p); + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + p[idx++] = k; + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_contains_p, "char-set-contains?", 2, 0, 0, + (SCM cs, SCM ch), + "Return @code{#t} iff the character @var{ch} is contained in the\n" + "character set @var{cs}.") +#define FUNC_NAME s_scm_char_set_contains_p +{ + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_CHAR (2, ch); + return scm_from_bool (SCM_CHARSET_GET (cs, SCM_CHAR (ch))); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0, + (SCM pred, SCM cs), + "Return a true value if every character in the character set\n" + "@var{cs} satisfies the predicate @var{pred}.") +#define FUNC_NAME s_scm_char_set_every +{ + int k; + SCM res = SCM_BOOL_T; + + SCM_VALIDATE_PROC (1, pred); + SCM_VALIDATE_SMOB (2, cs, charset); + + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + { + res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); + if (scm_is_false (res)) + return res; + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0, + (SCM pred, SCM cs), + "Return a true value if any character in the character set\n" + "@var{cs} satisfies the predicate @var{pred}.") +#define FUNC_NAME s_scm_char_set_any +{ + int k; + + SCM_VALIDATE_PROC (1, pred); + SCM_VALIDATE_SMOB (2, cs, charset); + + for (k = 0; k < SCM_CHARSET_SIZE; k++) + if (SCM_CHARSET_GET (cs, k)) + { + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); + if (scm_is_true (res)) + return res; + } + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1, + (SCM cs, SCM rest), + "Add all character arguments to the first argument, which must\n" + "be a character set.") +#define FUNC_NAME s_scm_char_set_adjoin +{ + long * p; + + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + cs = scm_char_set_copy (cs); + + p = (long *) SCM_SMOB_DATA (cs); + while (!SCM_NULLP (rest)) + { + SCM chr = SCM_CAR (rest); + int c; + + SCM_VALIDATE_CHAR_COPY (1, chr, c); + rest = SCM_CDR (rest); + + p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + } + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1, + (SCM cs, SCM rest), + "Delete all character arguments from the first argument, which\n" + "must be a character set.") +#define FUNC_NAME s_scm_char_set_delete +{ + long * p; + + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + cs = scm_char_set_copy (cs); + + p = (long *) SCM_SMOB_DATA (cs); + while (!SCM_NULLP (rest)) + { + SCM chr = SCM_CAR (rest); + int c; + + SCM_VALIDATE_CHAR_COPY (1, chr, c); + rest = SCM_CDR (rest); + + p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG)); + } + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1, + (SCM cs, SCM rest), + "Add all character arguments to the first argument, which must\n" + "be a character set.") +#define FUNC_NAME s_scm_char_set_adjoin_x +{ + long * p; + + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs); + while (!SCM_NULLP (rest)) + { + SCM chr = SCM_CAR (rest); + int c; + + SCM_VALIDATE_CHAR_COPY (1, chr, c); + rest = SCM_CDR (rest); + + p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + } + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1, + (SCM cs, SCM rest), + "Delete all character arguments from the first argument, which\n" + "must be a character set.") +#define FUNC_NAME s_scm_char_set_delete_x +{ + long * p; + + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs); + while (!SCM_NULLP (rest)) + { + SCM chr = SCM_CAR (rest); + int c; + + SCM_VALIDATE_CHAR_COPY (1, chr, c); + rest = SCM_CDR (rest); + + p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG)); + } + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0, + (SCM cs), + "Return the complement of the character set @var{cs}.") +#define FUNC_NAME s_scm_char_set_complement +{ + int k; + SCM res; + long * p, * q; + + SCM_VALIDATE_SMOB (1, cs, charset); + + res = make_char_set (FUNC_NAME); + p = (long *) SCM_SMOB_DATA (res); + q = (long *) SCM_SMOB_DATA (cs); + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] = ~q[k]; + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1, + (SCM rest), + "Return the union of all argument character sets.") +#define FUNC_NAME s_scm_char_set_union +{ + int c = 1; + SCM res; + long * p; + + SCM_VALIDATE_REST_ARGUMENT (rest); + + res = make_char_set (FUNC_NAME); + p = (long *) SCM_SMOB_DATA (res); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1, + (SCM rest), + "Return the intersection of all argument character sets.") +#define FUNC_NAME s_scm_char_set_intersection +{ + SCM res; + + SCM_VALIDATE_REST_ARGUMENT (rest); + + if (SCM_NULLP (rest)) + res = make_char_set (FUNC_NAME); + else + { + long *p; + int argnum = 2; + + res = scm_char_set_copy (SCM_CAR (rest)); + p = (long *) SCM_SMOB_DATA (res); + rest = SCM_CDR (rest); + + while (SCM_CONSP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + long *cs_data; + + SCM_VALIDATE_SMOB (argnum, cs, charset); + argnum++; + cs_data = (long *) SCM_SMOB_DATA (cs); + rest = SCM_CDR (rest); + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] &= cs_data[k]; + } + } + + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the difference of all argument character sets.") +#define FUNC_NAME s_scm_char_set_difference +{ + int c = 2; + SCM res; + long * p; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + res = scm_char_set_copy (cs1); + p = (long *) SCM_SMOB_DATA (res); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1, + (SCM rest), + "Return the exclusive-or of all argument character sets.") +#define FUNC_NAME s_scm_char_set_xor +{ + SCM res; + + SCM_VALIDATE_REST_ARGUMENT (rest); + + if (SCM_NULLP (rest)) + res = make_char_set (FUNC_NAME); + else + { + int argnum = 2; + long * p; + + res = scm_char_set_copy (SCM_CAR (rest)); + p = (long *) SCM_SMOB_DATA (res); + rest = SCM_CDR (rest); + + while (SCM_CONSP (rest)) + { + SCM cs = SCM_CAR (rest); + long *cs_data; + int k; + + SCM_VALIDATE_SMOB (argnum, cs, charset); + argnum++; + cs_data = (long *) SCM_SMOB_DATA (cs); + rest = SCM_CDR (rest); + + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] ^= cs_data[k]; + } + } + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the difference and the intersection of all argument\n" + "character sets.") +#define FUNC_NAME s_scm_char_set_diff_plus_intersection +{ + int c = 2; + SCM res1, res2; + long * p, * q; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + res1 = scm_char_set_copy (cs1); + res2 = make_char_set (FUNC_NAME); + p = (long *) SCM_SMOB_DATA (res1); + q = (long *) SCM_SMOB_DATA (res2); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + long *r; + + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + r = (long *) SCM_SMOB_DATA (cs); + + for (k = 0; k < LONGS_PER_CHARSET; k++) + { + q[k] |= p[k] & r[k]; + p[k] &= ~r[k]; + } + rest = SCM_CDR (rest); + } + return scm_values (scm_list_2 (res1, res2)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0, + (SCM cs), + "Return the complement of the character set @var{cs}.") +#define FUNC_NAME s_scm_char_set_complement_x +{ + int k; + long * p; + + SCM_VALIDATE_SMOB (1, cs, charset); + p = (long *) SCM_SMOB_DATA (cs); + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] = ~p[k]; + return cs; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the union of all argument character sets.") +#define FUNC_NAME s_scm_char_set_union_x +{ + int c = 2; + long * p; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs1); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; + } + return cs1; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the intersection of all argument character sets.") +#define FUNC_NAME s_scm_char_set_intersection_x +{ + int c = 2; + long * p; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs1); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; + } + return cs1; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the difference of all argument character sets.") +#define FUNC_NAME s_scm_char_set_difference_x +{ + int c = 2; + long * p; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs1); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; + } + return cs1; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, + (SCM cs1, SCM rest), + "Return the exclusive-or of all argument character sets.") +#define FUNC_NAME s_scm_char_set_xor_x +{ + /* a side-effecting variant should presumably give consistent results: + (define a (char-set #\a)) + (char-set-xor a a a) -> char set #\a + (char-set-xor! a a a) -> char set #\a + */ + return scm_char_set_xor (scm_cons (cs1, rest)); + +#if 0 + /* this would give (char-set-xor! a a a) -> empty char set. */ + int c = 2; + long * p; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs1); + while (!SCM_NULLP (rest)) + { + int k; + SCM cs = SCM_CAR (rest); + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + rest = SCM_CDR (rest); + + for (k = 0; k < LONGS_PER_CHARSET; k++) + p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k]; + } + return cs1; +#endif +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 2, 0, 1, + (SCM cs1, SCM cs2, SCM rest), + "Return the difference and the intersection of all argument\n" + "character sets.") +#define FUNC_NAME s_scm_char_set_diff_plus_intersection_x +{ + int c = 3; + long * p, * q; + int k; + + SCM_VALIDATE_SMOB (1, cs1, charset); + SCM_VALIDATE_SMOB (2, cs2, charset); + SCM_VALIDATE_REST_ARGUMENT (rest); + + p = (long *) SCM_SMOB_DATA (cs1); + q = (long *) SCM_SMOB_DATA (cs2); + if (p == q) + { + /* (char-set-diff+intersection! a a ...): can't share storage, + but we know the answer without checking for further + arguments. */ + return scm_values (scm_list_2 (make_char_set (FUNC_NAME), cs1)); + } + for (k = 0; k < LONGS_PER_CHARSET; k++) + { + long t = p[k]; + + p[k] &= ~q[k]; + q[k] = t & q[k]; + } + while (!SCM_NULLP (rest)) + { + SCM cs = SCM_CAR (rest); + long *r; + + SCM_VALIDATE_SMOB (c, cs, charset); + c++; + r = (long *) SCM_SMOB_DATA (cs); + + for (k = 0; k < LONGS_PER_CHARSET; k++) + { + q[k] |= p[k] & r[k]; + p[k] &= ~r[k]; + } + rest = SCM_CDR (rest); + } + return scm_values (scm_list_2 (cs1, cs2)); +} +#undef FUNC_NAME + +SCM scm_char_set_lower_case; +SCM scm_char_set_upper_case; +SCM scm_char_set_title_case; +SCM scm_char_set_letter; +SCM scm_char_set_digit; +SCM scm_char_set_letter_and_digit; +SCM scm_char_set_graphic; +SCM scm_char_set_printing; +SCM scm_char_set_whitespace; +SCM scm_char_set_iso_control; +SCM scm_char_set_punctuation; +SCM scm_char_set_symbol; +SCM scm_char_set_hex_digit; +SCM scm_char_set_blank; +SCM scm_char_set_ascii; +SCM scm_char_set_empty; +SCM scm_char_set_full; + +static SCM +make_predset (int (*pred) (int)) +{ + int ch; + SCM cs = make_char_set (NULL); + for (ch = 0; ch < 256; ch++) + if (pred (ch)) + SCM_CHARSET_SET (cs, ch); + return cs; +} + +static SCM +define_predset (const char *name, int (*pred) (int)) +{ + SCM cs = make_predset (pred); + scm_c_define (name, cs); + return scm_permanent_object (cs); +} + +static SCM +make_strset (const char *str) +{ + SCM cs = make_char_set (NULL); + while (*str) + { + SCM_CHARSET_SET (cs, *str); + str++; + } + return cs; +} + +static SCM +define_strset (const char *name, const char *str) +{ + SCM cs = make_strset (str); + scm_c_define (name, cs); + return scm_permanent_object (cs); +} + +static int false (int ch) { return 0; } +static int true (int ch) { return 1; } + +void +scm_init_srfi_14 (void) +{ + scm_tc16_charset = scm_make_smob_type ("character-set", + BYTES_PER_CHARSET); + scm_set_smob_free (scm_tc16_charset, charset_free); + scm_set_smob_print (scm_tc16_charset, charset_print); + + scm_char_set_upper_case = define_predset ("char-set:upper-case", isupper); + scm_char_set_lower_case = define_predset ("char-set:lower-case", islower); + scm_char_set_title_case = define_predset ("char-set:title-case", false); + scm_char_set_letter = define_predset ("char-set:letter", isalpha); + scm_char_set_digit = define_predset ("char-set:digit", isdigit); + scm_char_set_letter_and_digit = define_predset ("char-set:letter+digit", + isalnum); + scm_char_set_graphic = define_predset ("char-set:graphic", isgraph); + scm_char_set_printing = define_predset ("char-set:printing", isprint); + scm_char_set_whitespace = define_predset ("char-set:whitespace", isspace); + scm_char_set_iso_control = define_predset ("char-set:iso-control", iscntrl); + scm_char_set_punctuation = define_predset ("char-set:punctuation", ispunct); + scm_char_set_symbol = define_strset ("char-set:symbol", "$+<=>^`|~"); + scm_char_set_hex_digit = define_predset ("char-set:hex-digit", isxdigit); + scm_char_set_blank = define_strset ("char-set:blank", " \t"); + scm_char_set_ascii = define_predset ("char-set:ascii", isascii); + scm_char_set_empty = define_predset ("char-set:empty", false); + scm_char_set_full = define_predset ("char-set:full", true); + +#include "libguile/srfi-14.x" +} + +/* End of srfi-14.c. */ diff --git a/libguile/srfi-14.h b/libguile/srfi-14.h new file mode 100644 index 000000000..c6d0f497a --- /dev/null +++ b/libguile/srfi-14.h @@ -0,0 +1,112 @@ +#ifndef SCM_SRFI_14_H +#define SCM_SRFI_14_H + +/* srfi-14.c --- SRFI-14 procedures for Guile + * + * Copyright (C) 2001, 2004 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + +#include "libguile/__scm.h" + +#define SCM_CHARSET_SIZE 256 + +/* We expect 8-bit bytes here. Should be no problem in the year + 2001. */ +#ifndef SCM_BITS_PER_LONG +# define SCM_BITS_PER_LONG (sizeof (long) * 8) +#endif + +#define SCM_CHARSET_GET(cs, idx) (((long *) SCM_SMOB_DATA (cs))\ + [((unsigned char) (idx)) / SCM_BITS_PER_LONG] &\ + (1L << (((unsigned char) (idx)) % SCM_BITS_PER_LONG))) + +#define SCM_CHARSETP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_charset)) + +/* Smob type code for character sets. */ +SCM_API int scm_tc16_charset; + +SCM_API SCM scm_char_set_p (SCM obj); +SCM_API SCM scm_char_set_eq (SCM char_sets); +SCM_API SCM scm_char_set_leq (SCM char_sets); +SCM_API SCM scm_char_set_hash (SCM cs, SCM bound); +SCM_API SCM scm_char_set_cursor (SCM cs); +SCM_API SCM scm_char_set_ref (SCM cs, SCM cursor); +SCM_API SCM scm_char_set_cursor_next (SCM cs, SCM cursor); +SCM_API SCM scm_end_of_char_set_p (SCM cursor); +SCM_API SCM scm_char_set_fold (SCM kons, SCM knil, SCM cs); +SCM_API SCM scm_char_set_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base_cs); +SCM_API SCM scm_char_set_unfold_x (SCM p, SCM f, SCM g, SCM seed, SCM base_cs); +SCM_API SCM scm_char_set_for_each (SCM proc, SCM cs); +SCM_API SCM scm_char_set_map (SCM proc, SCM cs); +SCM_API SCM scm_char_set_copy (SCM cs); +SCM_API SCM scm_char_set (SCM rest); +SCM_API SCM scm_list_to_char_set (SCM list, SCM base_cs); +SCM_API SCM scm_list_to_char_set_x (SCM list, SCM base_cs); +SCM_API SCM scm_string_to_char_set (SCM str, SCM base_cs); +SCM_API SCM scm_string_to_char_set_x (SCM str, SCM base_cs); +SCM_API SCM scm_char_set_filter (SCM pred, SCM cs, SCM base_cs); +SCM_API SCM scm_char_set_filter_x (SCM pred, SCM cs, SCM base_cs); +SCM_API SCM scm_ucs_range_to_char_set (SCM lower, SCM upper, SCM error, SCM base_cs); +SCM_API SCM scm_ucs_range_to_char_set_x (SCM lower, SCM upper, SCM error, SCM base_cs); +SCM_API SCM scm_to_char_set (SCM x); +SCM_API SCM scm_char_set_size (SCM cs); +SCM_API SCM scm_char_set_count (SCM pred, SCM cs); +SCM_API SCM scm_char_set_to_list (SCM cs); +SCM_API SCM scm_char_set_to_string (SCM cs); +SCM_API SCM scm_char_set_contains_p (SCM cs, SCM ch); +SCM_API SCM scm_char_set_every (SCM pred, SCM cs); +SCM_API SCM scm_char_set_any (SCM pred, SCM cs); +SCM_API SCM scm_char_set_adjoin (SCM cs, SCM rest); +SCM_API SCM scm_char_set_delete (SCM cs, SCM rest); +SCM_API SCM scm_char_set_adjoin_x (SCM cs, SCM rest); +SCM_API SCM scm_char_set_delete_x (SCM cs, SCM rest); +SCM_API SCM scm_char_set_complement (SCM cs); +SCM_API SCM scm_char_set_union (SCM rest); +SCM_API SCM scm_char_set_intersection (SCM rest); +SCM_API SCM scm_char_set_difference (SCM cs1, SCM rest); +SCM_API SCM scm_char_set_xor (SCM rest); +SCM_API SCM scm_char_set_diff_plus_intersection (SCM cs1, SCM rest); +SCM_API SCM scm_char_set_complement_x (SCM cs); +SCM_API SCM scm_char_set_union_x (SCM cs1, SCM rest); +SCM_API SCM scm_char_set_intersection_x (SCM cs1, SCM rest); +SCM_API SCM scm_char_set_difference_x (SCM cs1, SCM rest); +SCM_API SCM scm_char_set_xor_x (SCM cs1, SCM rest); +SCM_API SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM cs2, SCM rest); + +SCM_API SCM scm_char_set_lower_case; +SCM_API SCM scm_char_set_upper_case; +SCM_API SCM scm_char_set_title_case; +SCM_API SCM scm_char_set_letter; +SCM_API SCM scm_char_set_digit; +SCM_API SCM scm_char_set_letter_and_digit; +SCM_API SCM scm_char_set_graphic; +SCM_API SCM scm_char_set_printing; +SCM_API SCM scm_char_set_whitespace; +SCM_API SCM scm_char_set_iso_control; +SCM_API SCM scm_char_set_punctuation; +SCM_API SCM scm_char_set_symbol; +SCM_API SCM scm_char_set_hex_digit; +SCM_API SCM scm_char_set_blank; +SCM_API SCM scm_char_set_ascii; +SCM_API SCM scm_char_set_empty; +SCM_API SCM scm_char_set_full; + +SCM_API void scm_c_init_srfi_14 (void); +SCM_API void scm_init_srfi_14 (void); + +#endif /* SCM_SRFI_14_H */ diff --git a/libguile/strop.c b/libguile/strop.c deleted file mode 100644 index e69de29bb..000000000 diff --git a/libguile/strop.h b/libguile/strop.h deleted file mode 100644 index e69de29bb..000000000 From c44ca4fe75905a4e2c3ff7f2662192ef4c8d05bc Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 22:12:37 +0000 Subject: [PATCH 058/100] Include "srfi-13.h" instead of "strop.h". --- libguile/deprecated.c | 2 +- libguile/load.c | 2 +- libguile/posix.c | 2 +- libguile/unif.c | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 1fa9558a1..7b629b9be 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -25,7 +25,7 @@ #include "libguile/snarf.h" #include "libguile/validate.h" #include "libguile/strings.h" -#include "libguile/strop.h" +#include "libguile/srfi-13.h" #include "libguile/modules.h" #include "libguile/eval.h" #include "libguile/smob.h" diff --git a/libguile/load.c b/libguile/load.c index 345f309c8..337426921 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -38,7 +38,7 @@ #include "libguile/modules.h" #include "libguile/lang.h" #include "libguile/chars.h" -#include "libguile/strop.h" +#include "libguile/srfi-13.h" #include "libguile/validate.h" #include "libguile/load.h" diff --git a/libguile/posix.c b/libguile/posix.c index df743f355..e725e8452 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -33,9 +33,9 @@ #include "libguile/scmsigs.h" #include "libguile/feature.h" #include "libguile/strings.h" +#include "libguile/srfi-13.h" #include "libguile/vectors.h" #include "libguile/lang.h" -#include "libguile/strop.h" #include "libguile/validate.h" #include "libguile/posix.h" diff --git a/libguile/unif.c b/libguile/unif.c index cc9e6ee04..8c4d55089 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -38,10 +38,10 @@ #include "libguile/eval.h" #include "libguile/fports.h" #include "libguile/smob.h" -#include "libguile/strop.h" #include "libguile/feature.h" #include "libguile/root.h" #include "libguile/strings.h" +#include "libguile/srfi-13.h" #include "libguile/vectors.h" #include "libguile/validate.h" From 1fdbbd4cd614257b5aa4f329556938db57014756 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 22:12:59 +0000 Subject: [PATCH 059/100] (scm_char_alphabetic_p, scm_char_numeric_p, scm_char_whitespace_p, scm_upper_case_p, scm_lower_case_p, scm_char_is_both_p): Use scm_char_set_contains_p with the proper charset instead of libc functions. --- libguile/chars.c | 41 ++++++++++++++++------------------------- 1 file changed, 16 insertions(+), 25 deletions(-) diff --git a/libguile/chars.c b/libguile/chars.c index f42ba2b73..f234ddc55 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -24,6 +24,8 @@ #include "libguile/validate.h" #include "libguile/chars.h" +#include "libguile/srfi-14.h" + SCM_DEFINE (scm_char_p, "char?", 1, 0, 0, @@ -158,34 +160,28 @@ SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, SCM_DEFINE (scm_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, (SCM chr), - "Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}.\n" - "Alphabetic means the same thing as the isalpha C library function.") + "Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}.\n") #define FUNC_NAME s_scm_char_alphabetic_p { - SCM_VALIDATE_CHAR (1, chr); - return scm_from_bool (isalpha(SCM_CHAR(chr))); + return scm_char_set_contains_p (scm_char_set_letter, chr); } #undef FUNC_NAME SCM_DEFINE (scm_char_numeric_p, "char-numeric?", 1, 0, 0, (SCM chr), - "Return @code{#t} iff @var{chr} is numeric, else @code{#f}.\n" - "Numeric means the same thing as the isdigit C library function.") + "Return @code{#t} iff @var{chr} is numeric, else @code{#f}.\n") #define FUNC_NAME s_scm_char_numeric_p { - SCM_VALIDATE_CHAR (1, chr); - return scm_from_bool (isdigit(SCM_CHAR(chr))); + return scm_char_set_contains_p (scm_char_set_digit, chr); } #undef FUNC_NAME SCM_DEFINE (scm_char_whitespace_p, "char-whitespace?", 1, 0, 0, (SCM chr), - "Return @code{#t} iff @var{chr} is whitespace, else @code{#f}.\n" - "Whitespace means the same thing as the isspace C library function.") + "Return @code{#t} iff @var{chr} is whitespace, else @code{#f}.\n") #define FUNC_NAME s_scm_char_whitespace_p { - SCM_VALIDATE_CHAR (1, chr); - return scm_from_bool (isspace(SCM_CHAR(chr))); + return scm_char_set_contains_p (scm_char_set_whitespace, chr); } #undef FUNC_NAME @@ -193,24 +189,20 @@ SCM_DEFINE (scm_char_whitespace_p, "char-whitespace?", 1, 0, 0, SCM_DEFINE (scm_char_upper_case_p, "char-upper-case?", 1, 0, 0, (SCM chr), - "Return @code{#t} iff @var{chr} is uppercase, else @code{#f}.\n" - "Uppercase means the same thing as the isupper C library function.") + "Return @code{#t} iff @var{chr} is uppercase, else @code{#f}.\n") #define FUNC_NAME s_scm_char_upper_case_p { - SCM_VALIDATE_CHAR (1, chr); - return scm_from_bool (isupper(SCM_CHAR(chr))); + return scm_char_set_contains_p (scm_char_set_upper_case, chr); } #undef FUNC_NAME SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1, 0, 0, (SCM chr), - "Return @code{#t} iff @var{chr} is lowercase, else @code{#f}.\n" - "Lowercase means the same thing as the islower C library function.") + "Return @code{#t} iff @var{chr} is lowercase, else @code{#f}.\n") #define FUNC_NAME s_scm_char_lower_case_p { - SCM_VALIDATE_CHAR (1, chr); - return scm_from_bool (islower(SCM_CHAR(chr))); + return scm_char_set_contains_p (scm_char_set_lower_case, chr); } #undef FUNC_NAME @@ -218,13 +210,12 @@ SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1, 0, 0, SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0, (SCM chr), - "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}.\n" - "Uppercase and lowercase are as defined by the isupper and islower\n" - "C library functions.") + "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}.\n") #define FUNC_NAME s_scm_char_is_both_p { - SCM_VALIDATE_CHAR (1, chr); - return scm_from_bool ((isupper(SCM_CHAR(chr)) || islower(SCM_CHAR(chr)))); + if (scm_is_true (scm_char_set_contains_p (scm_char_set_lower_case, chr))) + return SCM_BOOL_T; + return scm_char_set_contains_p (scm_char_set_upper_case, chr); } #undef FUNC_NAME From ad45f6b325b7c1e9edb1c4fbe111575409b303e4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 22:13:07 +0000 Subject: [PATCH 060/100] (scm_init_guile_1): Call scm_init_srfi_13 and scm_init_srfi_14. Do not call scm_init_strop. --- libguile/init.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/init.c b/libguile/init.c index 313f3ff04..7e6f3fcd6 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -103,7 +103,8 @@ #include "libguile/stacks.h" #include "libguile/stime.h" #include "libguile/strings.h" -#include "libguile/strop.h" +#include "libguile/srfi-13.h" +#include "libguile/srfi-14.h" #include "libguile/strorder.h" #include "libguile/strports.h" #include "libguile/struct.h" @@ -513,7 +514,8 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_read (); scm_init_stime (); scm_init_strorder (); - scm_init_strop (); + scm_init_srfi_13 (); + scm_init_srfi_14 (); scm_init_throw (); scm_init_vectors (); scm_init_version (); From 2c0b7c1fa0dc4760418133b9eeebc0561a2dd4e0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 22:13:14 +0000 Subject: [PATCH 061/100] (scm_string_equal_p, scm_string_ci_equal_p, scm_string_less_p, scm_string_leq_p, scm_string_gr_p, scm_string_geq_p, scm_string_ci_less_p, scm_string_ci_leq_p, scm_string_ci_gr_p, scm_string_ci_geq_p): Use scm_string_eq, etc instead of explicit code. --- libguile/strorder.c | 171 ++++++-------------------------------------- 1 file changed, 23 insertions(+), 148 deletions(-) diff --git a/libguile/strorder.c b/libguile/strorder.c index 3601c90bc..439f47546 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1999, 2000, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -24,8 +24,20 @@ #include "libguile/validate.h" #include "libguile/strorder.h" +#include "libguile/srfi-13.h" +SCM_C_INLINE_KEYWORD static SCM +srfi13_cmp (SCM s1, SCM s2, SCM (*cmp) (SCM, SCM, SCM, SCM, SCM, SCM)) +{ + if (scm_is_true (cmp (s1, s2, + SCM_UNDEFINED, SCM_UNDEFINED, + SCM_UNDEFINED, SCM_UNDEFINED))) + return SCM_BOOL_T; + else + return SCM_BOOL_F; +} + SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Lexicographic equality predicate; return @code{#t} if the two\n" @@ -38,37 +50,10 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, "characters.") #define FUNC_NAME s_scm_string_equal_p { - size_t length; - - SCM_VALIDATE_STRING (1, s1); - SCM_VALIDATE_STRING (2, s2); - - length = scm_i_string_length (s2); - if (scm_i_string_length (s1) == length) - { - const unsigned char *c1 = scm_i_string_chars (s1) + length - 1; - const unsigned char *c2 = scm_i_string_chars (s2) + length - 1; - size_t i; - - /* comparing from back to front typically finds mismatches faster */ - for (i = 0; i != length; ++i, --c1, --c2) - if (*c1 != *c2) - { - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; - } - - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_T; - } - else - { - return SCM_BOOL_F; - } + return srfi13_cmp (s1, s2, scm_string_eq); } #undef FUNC_NAME - SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Case-insensitive string equality predicate; return @code{#t} if\n" @@ -77,145 +62,50 @@ SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, "return @code{#f}.") #define FUNC_NAME s_scm_string_ci_equal_p { - size_t length; - - SCM_VALIDATE_STRING (1, s1); - SCM_VALIDATE_STRING (2, s2); - - length = scm_i_string_length (s2); - if (scm_i_string_length (s1) == length) - { - const unsigned char *c1 = scm_i_string_chars (s1) + length - 1; - const unsigned char *c2 = scm_i_string_chars (s2) + length - 1; - size_t i; - - /* comparing from back to front typically finds mismatches faster */ - for (i = 0; i != length; ++i, --c1, --c2) - if (scm_c_upcase (*c1) != scm_c_upcase (*c2)) - { - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; - } - - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_T; - } - else - { - return SCM_BOOL_F; - } + return srfi13_cmp (s1, s2, scm_string_ci_eq); } #undef FUNC_NAME - -/* Helper function for the lexicographic ordering predicates. - * No argument checking is performed. */ -static SCM -string_less_p (SCM s1, SCM s2) -{ - size_t i, length1, length2, lengthm; - const unsigned char *c1, *c2; - - length1 = scm_i_string_length (s1); - length2 = scm_i_string_length (s2); - lengthm = min (length1, length2); - c1 = scm_i_string_chars (s1); - c2 = scm_i_string_chars (s2); - - for (i = 0; i != lengthm; ++i, ++c1, ++c2) { - int c = *c1 - *c2; - if (c == 0) - continue; - scm_remember_upto_here_2 (s1, s2); - return scm_from_bool (c < 0); - } - - return scm_from_bool (length1 < length2); -} - - SCM_DEFINE1 (scm_string_less_p, "string?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n" "is lexicographically greater than @var{s2}.") #define FUNC_NAME s_scm_string_gr_p { - SCM_VALIDATE_STRING (1, s1); - SCM_VALIDATE_STRING (2, s2); - - return string_less_p (s2, s1); + return srfi13_cmp (s1, s2, scm_string_gt); } #undef FUNC_NAME - SCM_DEFINE1 (scm_string_geq_p, "string>=?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n" "is lexicographically greater than or equal to @var{s2}.") #define FUNC_NAME s_scm_string_geq_p { - SCM_VALIDATE_STRING (1, s1); - SCM_VALIDATE_STRING (2, s2); - - return scm_not (string_less_p (s1, s2)); + return srfi13_cmp (s1, s2, scm_string_ge); } #undef FUNC_NAME - -/* Helper function for the case insensitive lexicographic ordering - * predicates. No argument checking is performed. */ -static SCM -string_ci_less_p (SCM s1, SCM s2) -{ - size_t i, length1, length2, lengthm; - const unsigned char *c1, *c2; - - length1 = scm_i_string_length (s1); - length2 = scm_i_string_length (s2); - lengthm = min (length1, length2); - c1 = scm_i_string_chars (s1); - c2 = scm_i_string_chars (s2); - - for (i = 0; i != lengthm; ++i, ++c1, ++c2) { - int c = scm_c_upcase (*c1) - scm_c_upcase (*c2); - if (c == 0) - continue; - scm_remember_upto_here_2 (s1, s2); - return scm_from_bool (c < 0); - } - - return scm_from_bool (length1 < length2); -} - - SCM_DEFINE1 (scm_string_ci_less_p, "string-ci?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Case insensitive lexicographic ordering predicate; return\n" @@ -253,14 +135,10 @@ SCM_DEFINE1 (scm_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr, "@var{s2} regardless of case.") #define FUNC_NAME s_scm_string_ci_gr_p { - SCM_VALIDATE_STRING (1, s1); - SCM_VALIDATE_STRING (2, s2); - - return string_ci_less_p (s2, s1); + return srfi13_cmp (s1, s2, scm_string_ci_gt); } #undef FUNC_NAME - SCM_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, (SCM s1, SCM s2), "Case insensitive lexicographic ordering predicate; return\n" @@ -268,10 +146,7 @@ SCM_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, "equal to @var{s2} regardless of case.") #define FUNC_NAME s_scm_string_ci_geq_p { - SCM_VALIDATE_STRING (1, s1); - SCM_VALIDATE_STRING (2, s2); - - return scm_not (string_ci_less_p (s1, s2)); + return srfi13_cmp (s1, s2, scm_string_ci_ge); } #undef FUNC_NAME From 1206efbe073b709bd61fa1cea90f058c45119efd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 22:13:27 +0000 Subject: [PATCH 062/100] * symbols.h, symbols.c (scm_string_ci_to_symbol): Moved here, next to scm_string_to_symbol. * deprecated.c, load.c, posix.c, unif.c, symbols.c: Include "srfi-13.h" instead of "strop.h". --- libguile/symbols.c | 15 +++++++++++++++ libguile/symbols.h | 1 + 2 files changed, 16 insertions(+) diff --git a/libguile/symbols.c b/libguile/symbols.c index 657723cc6..375ce8cf7 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -34,6 +34,8 @@ #include "libguile/hashtab.h" #include "libguile/weaks.h" #include "libguile/modules.h" +#include "libguile/read.h" +#include "libguile/srfi-13.h" #include "libguile/validate.h" #include "libguile/symbols.h" @@ -245,6 +247,19 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, + (SCM str), + "Return the symbol whose name is @var{str}. @var{str} is\n" + "converted to lowercase before the conversion is done, if Guile\n" + "is currently reading symbols case-insensitively.") +#define FUNC_NAME s_scm_string_ci_to_symbol +{ + return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P + ? scm_string_downcase(str) + : str); +} +#undef FUNC_NAME + #define MAX_PREFIX_LENGTH 30 SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, diff --git a/libguile/symbols.h b/libguile/symbols.h index a96d786e9..84a8df1f7 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -41,6 +41,7 @@ SCM_API SCM scm_symbol_interned_p (SCM sym); SCM_API SCM scm_make_symbol (SCM name); SCM_API SCM scm_symbol_to_string (SCM s); SCM_API SCM scm_string_to_symbol (SCM s); +SCM_API SCM scm_string_ci_to_symbol (SCM s); SCM_API SCM scm_symbol_fref (SCM s); SCM_API SCM scm_symbol_pref (SCM s); From 7aa29a87f98cfbbb59bd4ba4329f24fcc54353f7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 22:14:57 +0000 Subject: [PATCH 063/100] Two more tests for double indirect substring modification. --- test-suite/tests/strings.test | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index a21553224..544c8eb9c 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -100,4 +100,17 @@ (str2 (string-copy str1))) (string-upcase! (substring/shared str2 3 6)) (and (string=? str1 "foofoofoo") - (string=? str2 "fooFOOfoo"))))) \ No newline at end of file + (string=? str2 "fooFOOfoo")))) + + (pass-if "modify double indirectly" + (let* ((str1 "foofoofoo") + (str2 (substring/shared str1 2 7))) + (string-upcase! (substring/shared str2 1 4)) + (string=? str1 "fooFOOfoo"))) + + (pass-if "modify cow double indirectly" + (let* ((str1 "foofoofoo") + (str2 (substring str1 2 7))) + (string-upcase! (substring/shared str2 1 4)) + (and (string=? str1 "foofoofoo") + (string=? str2 "oFOOf"))))) From 0081b349c8de1f5c577e7135266b61b9d1f3584c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 22:19:21 +0000 Subject: [PATCH 064/100] * srfi-13.scm, srfi-14.scm: Simply re-export the relevant bindings. * srfi-13.h, srfi-13.c, srfi-14.h, srfi-14.c: Removed all real content except for the init functions. --- srfi/srfi-13.c | 3077 +--------------------------------------------- srfi/srfi-13.h | 94 +- srfi/srfi-13.scm | 89 +- srfi/srfi-14.c | 1404 +-------------------- srfi/srfi-14.h | 66 +- srfi/srfi-14.scm | 61 +- 6 files changed, 72 insertions(+), 4719 deletions(-) diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index e362b8fad..5814f8092 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -1,4 +1,4 @@ -/* srfi-13.c --- SRFI-13 procedures for Guile +/* srfi-13.c --- old place of SRFI-13 procedures for Guile * * Copyright (C) 2001, 2004 Free Software Foundation, Inc. * @@ -18,3078 +18,19 @@ */ -#include -#include - -#include - -#include "srfi-13.h" -#include "srfi-14.h" - -/* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages - messing with the internal representation of strings. We define our - own version since we use it so much and are messing with Guile - internals anyway. +/* This file is now empty since all its procedures are now in the + core. We keep the libguile-srfi-srfi-13.so library around anyway + since people might still be linking with it. */ -#define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \ - pos_start, start, c_start, \ - pos_end, end, c_end) \ - do { \ - SCM_VALIDATE_STRING (pos_str, str); \ - c_str = scm_i_string_chars (str); \ - scm_i_get_substring_spec (scm_i_string_length (str), \ - start, &c_start, end, &c_end); \ - } while (0) +#include "srfi/srfi-13.h" -#define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \ - pos_start, start, c_start, \ - pos_end, end, c_end) \ - do { \ - SCM_VALIDATE_STRING (pos_str, str); \ - scm_i_get_substring_spec (scm_i_string_length (str), \ - start, &c_start, end, &c_end); \ - } while (0) - -/* Likewise for SCM_VALIDATE_STRING_COPY. */ - -#define MY_VALIDATE_STRING_COPY(pos, str, cvar) \ - do { \ - scm_validate_string (pos, str); \ - cvar = scm_i_string_chars (str); \ - } while (0) - - -SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, - (SCM char_pred, SCM s, SCM start, SCM end), - "Check if the predicate @var{pred} is true for any character in\n" - "the string @var{s}.\n" - "\n" - "Calls to @var{pred} are made from left to right across @var{s}.\n" - "When it returns true (ie.@: non-@code{#f}), that return value\n" - "is the return from @code{string-any}.\n" - "\n" - "The SRFI-13 specification requires that the call to @var{pred}\n" - "on the last character of @var{s} (assuming that point is\n" - "reached) be a tail call, but currently in Guile this is not the\n" - "case.") -#define FUNC_NAME s_scm_string_any -{ - const char *cstr; - int cstart, cend; - SCM res; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); - - if (SCM_CHARP (char_pred)) - { - return (memchr (cstr+cstart, (int) SCM_CHAR (char_pred), - cend-cstart) == NULL - ? SCM_BOOL_F : SCM_BOOL_T); - } - else if (SCM_CHARSETP (char_pred)) - { - int i; - for (i = cstart; i < cend; i++) - if (SCM_CHARSET_GET (char_pred, cstr[i])) - return SCM_BOOL_T; - } - else - { - SCM_VALIDATE_PROC (1, char_pred); - - cstr += cstart; - while (cstart < cend) - { - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (*cstr)); - if (scm_is_true (res)) - return res; - cstr++; - cstart++; - } - } - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0, - (SCM char_pred, SCM s, SCM start, SCM end), - "Check if the predicate @var{pred} is true for every character\n" - "in the string @var{s}.\n" - "\n" - "Calls to @var{pred} are made from left to right across @var{s}.\n" - "If the predicate is true for every character then the return\n" - "value from the last @var{pred} call is the return from\n" - "@code{string-every}.\n" - "\n" - "If there are no characters in @var{s} (ie.@: @var{start} equals\n" - "@var{end}) then the return is @code{#t}.\n" - "\n" - "The SRFI-13 specification requires that the call to @var{pred}\n" - "on the last character of @var{s} (assuming that point is\n" - "reached) be a tail call, but currently in Guile this is not the\n" - "case.") -#define FUNC_NAME s_scm_string_every -{ - const char *cstr; - int cstart, cend; - SCM res; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); - if (SCM_CHARP (char_pred)) - { - char cchr = SCM_CHAR (char_pred); - int i; - for (i = cstart; i < cend; i++) - if (cstr[i] != cchr) - return SCM_BOOL_F; - return SCM_BOOL_T; - } - else if (SCM_CHARSETP (char_pred)) - { - int i; - for (i = cstart; i < cend; i++) - if (! SCM_CHARSET_GET (char_pred, cstr[i])) - return SCM_BOOL_F; - return SCM_BOOL_T; - } - else - { - SCM_VALIDATE_PROC (1, char_pred); - - res = SCM_BOOL_T; - cstr += cstart; - while (cstart < cend) - { - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (*cstr)); - if (scm_is_false (res)) - return res; - cstr++; - cstart++; - } - return res; - } -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0, - (SCM proc, SCM len), - "@var{proc} is an integer->char procedure. Construct a string\n" - "of size @var{len} by applying @var{proc} to each index to\n" - "produce the corresponding string element. The order in which\n" - "@var{proc} is applied to the indices is not specified.") -#define FUNC_NAME s_scm_string_tabulate -{ - size_t clen, i; - SCM res; - SCM ch; - char *p; - - SCM_VALIDATE_PROC (1, proc); - clen = scm_to_size_t (len); - SCM_ASSERT_RANGE (2, len, clen >= 0); - - res = scm_i_make_string (clen, &p); - i = 0; - while (i < clen) - { - /* The RES string remains untouched since nobody knows about it - yet. No need to refetch P. - */ - ch = scm_call_1 (proc, scm_from_int (i)); - if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); - *p++ = SCM_CHAR (ch); - i++; - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_to_listS, "string->list", 1, 2, 0, - (SCM str, SCM start, SCM end), - "Convert the string @var{str} into a list of characters.") -#define FUNC_NAME s_scm_string_to_listS -{ - const char *cstr; - int cstart, cend; - SCM result = SCM_EOL; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - while (cstart < cend) - { - cend--; - result = scm_cons (SCM_MAKE_CHAR (cstr[cend]), result); - } - return result; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0, - (SCM chrs), - "An efficient implementation of @code{(compose string->list\n" - "reverse)}:\n" - "\n" - "@smalllisp\n" - "(reverse-list->string '(#\a #\B #\c)) @result{} \"cBa\"\n" - "@end smalllisp") -#define FUNC_NAME s_scm_reverse_list_to_string -{ - SCM result; - long i = scm_ilength (chrs); - char *data; - - if (i < 0) - SCM_WRONG_TYPE_ARG (1, chrs); - result = scm_i_make_string (i, &data); - - { - - data += i; - while (!SCM_NULLP (chrs)) - { - SCM elt = SCM_CAR (chrs); - - SCM_VALIDATE_CHAR (SCM_ARGn, elt); - data--; - *data = SCM_CHAR (elt); - chrs = SCM_CDR (chrs); - } - } - return result; -} -#undef FUNC_NAME - - -SCM_SYMBOL (scm_sym_infix, "infix"); -SCM_SYMBOL (scm_sym_strict_infix, "strict-infix"); -SCM_SYMBOL (scm_sym_suffix, "suffix"); -SCM_SYMBOL (scm_sym_prefix, "prefix"); - -SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, - (SCM ls, SCM delimiter, SCM grammar), - "Append the string in the string list @var{ls}, using the string\n" - "@var{delim} as a delimiter between the elements of @var{ls}.\n" - "@var{grammar} is a symbol which specifies how the delimiter is\n" - "placed between the strings, and defaults to the symbol\n" - "@code{infix}.\n" - "\n" - "@table @code\n" - "@item infix\n" - "Insert the separator between list elements. An empty string\n" - "will produce an empty list.\n" - "@item string-infix\n" - "Like @code{infix}, but will raise an error if given the empty\n" - "list.\n" - "@item suffix\n" - "Insert the separator after every list element.\n" - "@item prefix\n" - "Insert the separator before each list element.\n" - "@end table") -#define FUNC_NAME s_scm_string_join -{ -#define GRAM_INFIX 0 -#define GRAM_STRICT_INFIX 1 -#define GRAM_SUFFIX 2 -#define GRAM_PREFIX 3 - SCM tmp; - SCM result; - int gram = GRAM_INFIX; - int del_len = 0, extra_len = 0; - int len = 0; - char * p; - long strings = scm_ilength (ls); - - /* Validate the string list. */ - if (strings < 0) - SCM_WRONG_TYPE_ARG (1, ls); - - /* Validate the delimiter and record its length. */ - if (SCM_UNBNDP (delimiter)) - { - delimiter = scm_from_locale_string (" "); - del_len = 1; - } - else - { - SCM_VALIDATE_STRING (2, delimiter); - del_len = scm_i_string_length (delimiter); - } - - /* Validate the grammar symbol and remember the grammar. */ - if (SCM_UNBNDP (grammar)) - gram = GRAM_INFIX; - else if (scm_is_eq (grammar, scm_sym_infix)) - gram = GRAM_INFIX; - else if (scm_is_eq (grammar, scm_sym_strict_infix)) - gram = GRAM_STRICT_INFIX; - else if (scm_is_eq (grammar, scm_sym_suffix)) - gram = GRAM_SUFFIX; - else if (scm_is_eq (grammar, scm_sym_prefix)) - gram = GRAM_PREFIX; - else - SCM_WRONG_TYPE_ARG (3, grammar); - - /* Check grammar constraints and calculate the space required for - the delimiter(s). */ - switch (gram) - { - case GRAM_INFIX: - if (!SCM_NULLP (ls)) - extra_len = (strings > 0) ? ((strings - 1) * del_len) : 0; - break; - case GRAM_STRICT_INFIX: - if (strings == 0) - SCM_MISC_ERROR ("strict-infix grammar requires non-empty list", - SCM_EOL); - extra_len = (strings - 1) * del_len; - break; - default: - extra_len = strings * del_len; - break; - } - - tmp = ls; - while (SCM_CONSP (tmp)) - { - SCM elt = SCM_CAR (tmp); - SCM_VALIDATE_STRING (1, elt); - len += scm_i_string_length (elt); - tmp = SCM_CDR (tmp); - } - - result = scm_i_make_string (len + extra_len, &p); - - tmp = ls; - switch (gram) - { - case GRAM_INFIX: - case GRAM_STRICT_INFIX: - while (!SCM_NULLP (tmp)) - { - SCM elt = SCM_CAR (tmp); - memmove (p, scm_i_string_chars (elt), - scm_i_string_length (elt)); - p += scm_i_string_length (elt); - if (!SCM_NULLP (SCM_CDR (tmp)) && del_len > 0) - { - memmove (p, scm_i_string_chars (delimiter), del_len); - p += del_len; - } - tmp = SCM_CDR (tmp); - } - break; - case GRAM_SUFFIX: - while (!SCM_NULLP (tmp)) - { - SCM elt = SCM_CAR (tmp); - memmove (p, scm_i_string_chars (elt), - scm_i_string_length (elt)); - p += scm_i_string_length (elt); - if (del_len > 0) - { - memmove (p, scm_i_string_chars (delimiter), del_len); - p += del_len; - } - tmp = SCM_CDR (tmp); - } - break; - case GRAM_PREFIX: - while (!SCM_NULLP (tmp)) - { - SCM elt = SCM_CAR (tmp); - if (del_len > 0) - { - memmove (p, scm_i_string_chars (delimiter), del_len); - p += del_len; - } - memmove (p, scm_i_string_chars (elt), - scm_i_string_length (elt)); - p += scm_i_string_length (elt); - tmp = SCM_CDR (tmp); - } - break; - } - return result; -#undef GRAM_INFIX -#undef GRAM_STRICT_INFIX -#undef GRAM_SUFFIX -#undef GRAM_PREFIX -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_copyS, "string-copy", 1, 2, 0, - (SCM str, SCM start, SCM end), - "Return a freshly allocated copy of the string @var{str}. If\n" - "given, @var{start} and @var{end} delimit the portion of\n" - "@var{str} which is copied.") -#define FUNC_NAME s_scm_string_copyS -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - return scm_c_substring_copy (str, cstart, cend); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_substring_sharedS, "substring/shared", 2, 1, 0, - (SCM str, SCM start, SCM end), - "Like @code{substring}, but the result may share memory with the\n" - "argument @var{str}.") -#define FUNC_NAME s_scm_substring_sharedS -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - return scm_c_substring_shared (str, cstart, cend); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0, - (SCM target, SCM tstart, SCM s, SCM start, SCM end), - "Copy the sequence of characters from index range [@var{start},\n" - "@var{end}) in string @var{s} to string @var{target}, beginning\n" - "at index @var{tstart}. The characters are copied left-to-right\n" - "or right-to-left as needed -- the copy is guaranteed to work,\n" - "even if @var{target} and @var{s} are the same string. It is an\n" - "error if the copy operation runs off the end of the target\n" - "string.") -#define FUNC_NAME s_scm_string_copy_x -{ - const char *cstr; - char *ctarget; - size_t cstart, cend, ctstart, dummy, len; - SCM sdummy = SCM_UNDEFINED; - - MY_VALIDATE_SUBSTRING_SPEC (1, target, - 2, tstart, ctstart, - 2, sdummy, dummy); - MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, - 4, start, cstart, - 5, end, cend); - len = cend - cstart; - SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart); - - ctarget = scm_i_string_writable_chars (target); - memmove (ctarget + ctstart, cstr + cstart, len); - scm_i_string_stop_writing (); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0, - (SCM s, SCM n), - "Return the @var{n} first characters of @var{s}.") -#define FUNC_NAME s_scm_string_take -{ - return scm_substring (s, SCM_INUM0, n); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0, - (SCM s, SCM n), - "Return all but the first @var{n} characters of @var{s}.") -#define FUNC_NAME s_scm_string_drop -{ - return scm_substring (s, n, SCM_UNDEFINED); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0, - (SCM s, SCM n), - "Return the @var{n} last characters of @var{s}.") -#define FUNC_NAME s_scm_string_take_right -{ - return scm_substring (s, - scm_difference (scm_string_length (s), n), - SCM_UNDEFINED); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0, - (SCM s, SCM n), - "Return all but the last @var{n} characters of @var{s}.") -#define FUNC_NAME s_scm_string_drop_right -{ - return scm_substring (s, - SCM_INUM0, - scm_difference (scm_string_length (s), n)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0, - (SCM s, SCM len, SCM chr, SCM start, SCM end), - "Take that characters from @var{start} to @var{end} from the\n" - "string @var{s} and return a new string, right-padded by the\n" - "character @var{chr} to length @var{len}. If the resulting\n" - "string is longer than @var{len}, it is truncated on the right.") -#define FUNC_NAME s_scm_string_pad -{ - char cchr; - const char *cstr; - size_t cstart, cend, clen; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 4, start, cstart, - 5, end, cend); - clen = scm_to_size_t (len); - - if (SCM_UNBNDP (chr)) - cchr = ' '; - else - { - SCM_VALIDATE_CHAR (3, chr); - cchr = SCM_CHAR (chr); - } - if (clen < (cend - cstart)) - return scm_c_substring (s, cend - clen, cend); - else - { - SCM result; - char *dst; - - result = scm_i_make_string (clen, &dst); - memset (dst, cchr, (clen - (cend - cstart))); - memmove (dst + clen - (cend - cstart), cstr + cstart, cend - cstart); - return result; - } -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0, - (SCM s, SCM len, SCM chr, SCM start, SCM end), - "Take that characters from @var{start} to @var{end} from the\n" - "string @var{s} and return a new string, left-padded by the\n" - "character @var{chr} to length @var{len}. If the resulting\n" - "string is longer than @var{len}, it is truncated on the left.") -#define FUNC_NAME s_scm_string_pad_right -{ - char cchr; - const char *cstr; - size_t cstart, cend, clen; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 4, start, cstart, - 5, end, cend); - clen = scm_to_size_t (len); - - if (SCM_UNBNDP (chr)) - cchr = ' '; - else - { - SCM_VALIDATE_CHAR (3, chr); - cchr = SCM_CHAR (chr); - } - if (clen < (cend - cstart)) - return scm_c_substring (s, cstart, cstart + clen); - else - { - SCM result; - char *dst; - - result = scm_i_make_string (clen, &dst); - memset (dst + (cend - cstart), cchr, clen - (cend - cstart)); - memmove (dst, cstr + cstart, cend - cstart); - return result; - } -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, - (SCM s, SCM char_pred, SCM start, SCM end), - "Trim @var{s} by skipping over all characters on the left\n" - "that satisfy the parameter @var{char_pred}:\n" - "\n" - "@itemize @bullet\n" - "@item\n" - "if it is the character @var{ch}, characters equal to\n" - "@var{ch} are trimmed,\n" - "\n" - "@item\n" - "if it is a procedure @var{pred} characters that\n" - "satisfy @var{pred} are trimmed,\n" - "\n" - "@item\n" - "if it is a character set, characters in that set are trimmed.\n" - "@end itemize\n" - "\n" - "If called without a @var{char_pred} argument, all whitespace is\n" - "trimmed.") -#define FUNC_NAME s_scm_string_trim -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); - if (SCM_UNBNDP (char_pred)) - { - while (cstart < cend) - { - if (!isspace((int) (unsigned char) cstr[cstart])) - break; - cstart++; - } - } - else if (SCM_CHARP (char_pred)) - { - char chr = SCM_CHAR (char_pred); - while (cstart < cend) - { - if (chr != cstr[cstart]) - break; - cstart++; - } - } - else if (SCM_CHARSETP (char_pred)) - { - while (cstart < cend) - { - if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) - break; - cstart++; - } - } - else - { - SCM_VALIDATE_PROC (2, char_pred); - while (cstart < cend) - { - SCM res; - - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); - if (scm_is_false (res)) - break; - cstr = scm_i_string_chars (s); - cstart++; - } - } - return scm_c_substring (s, cstart, cend); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, - (SCM s, SCM char_pred, SCM start, SCM end), - "Trim @var{s} by skipping over all characters on the rightt\n" - "that satisfy the parameter @var{char_pred}:\n" - "\n" - "@itemize @bullet\n" - "@item\n" - "if it is the character @var{ch}, characters equal to @var{ch}\n" - "are trimmed,\n" - "\n" - "@item\n" - "if it is a procedure @var{pred} characters that satisfy\n" - "@var{pred} are trimmed,\n" - "\n" - "@item\n" - "if it is a character sets, all characters in that set are\n" - "trimmed.\n" - "@end itemize\n" - "\n" - "If called without a @var{char_pred} argument, all whitespace is\n" - "trimmed.") -#define FUNC_NAME s_scm_string_trim_right -{ - const char *cstr; - int cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); - if (SCM_UNBNDP (char_pred)) - { - while (cstart < cend) - { - if (!isspace((int) (unsigned char) cstr[cend - 1])) - break; - cend--; - } - } - else if (SCM_CHARP (char_pred)) - { - char chr = SCM_CHAR (char_pred); - while (cstart < cend) - { - if (chr != cstr[cend - 1]) - break; - cend--; - } - } - else if (SCM_CHARSETP (char_pred)) - { - while (cstart < cend) - { - if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1])) - break; - cend--; - } - } - else - { - SCM_VALIDATE_PROC (2, char_pred); - while (cstart < cend) - { - SCM res; - - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1])); - if (scm_is_false (res)) - break; - cstr = scm_i_string_chars (s); - cend--; - } - } - return scm_c_substring (s, cstart, cend); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, - (SCM s, SCM char_pred, SCM start, SCM end), - "Trim @var{s} by skipping over all characters on both sides of\n" - "the string that satisfy the parameter @var{char_pred}:\n" - "\n" - "@itemize @bullet\n" - "@item\n" - "if it is the character @var{ch}, characters equal to @var{ch}\n" - "are trimmed,\n" - "\n" - "@item\n" - "if it is a procedure @var{pred} characters that satisfy\n" - "@var{pred} are trimmed,\n" - "\n" - "@item\n" - "if it is a character set, the characters in the set are\n" - "trimmed.\n" - "@end itemize\n" - "\n" - "If called without a @var{char_pred} argument, all whitespace is\n" - "trimmed.") -#define FUNC_NAME s_scm_string_trim_both -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); - if (SCM_UNBNDP (char_pred)) - { - while (cstart < cend) - { - if (!isspace((int) (unsigned char) cstr[cstart])) - break; - cstart++; - } - while (cstart < cend) - { - if (!isspace((int) (unsigned char) cstr[cend - 1])) - break; - cend--; - } - } - else if (SCM_CHARP (char_pred)) - { - char chr = SCM_CHAR (char_pred); - while (cstart < cend) - { - if (chr != cstr[cstart]) - break; - cstart++; - } - while (cstart < cend) - { - if (chr != cstr[cend - 1]) - break; - cend--; - } - } - else if (SCM_CHARSETP (char_pred)) - { - while (cstart < cend) - { - if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) - break; - cstart++; - } - while (cstart < cend) - { - if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1])) - break; - cend--; - } - } - else - { - SCM_VALIDATE_PROC (2, char_pred); - while (cstart < cend) - { - SCM res; - - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); - if (scm_is_false (res)) - break; - cstr = scm_i_string_chars (s); - cstart++; - } - while (cstart < cend) - { - SCM res; - - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1])); - if (scm_is_false (res)) - break; - cstr = scm_i_string_chars (s); - cend--; - } - } - return scm_c_substring (s, cstart, cend); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_fill_xS, "string-fill!", 2, 2, 0, - (SCM str, SCM chr, SCM start, SCM end), - "Stores @var{chr} in every element of the given @var{str} and\n" - "returns an unspecified value.") -#define FUNC_NAME s_scm_string_fill_xS -{ - char *cstr; - size_t cstart, cend; - int c; - size_t k; - - MY_VALIDATE_SUBSTRING_SPEC (1, str, - 3, start, cstart, - 4, end, cend); - SCM_VALIDATE_CHAR_COPY (2, chr, c); - - cstr = scm_i_string_writable_chars (str); - for (k = cstart; k < cend; k++) - cstr[k] = c; - scm_i_string_stop_writing (); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0, - (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2), - "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n" - "mismatch index, depending upon whether @var{s1} is less than,\n" - "equal to, or greater than @var{s2}. The mismatch index is the\n" - "largest index @var{i} such that for every 0 <= @var{j} <\n" - "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n" - "@var{i} is the first position that does not match.") -#define FUNC_NAME s_scm_string_compare -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 6, start1, cstart1, - 7, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 8, start2, cstart2, - 9, end2, cend2); - SCM_VALIDATE_PROC (3, proc_lt); - SCM_VALIDATE_PROC (4, proc_eq); - SCM_VALIDATE_PROC (5, proc_gt); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] < cstr2[cstart2]) - return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); - else if (cstr1[cstart1] > cstr2[cstart2]) - return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); - else if (cstart2 < cend2) - return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); - else - return scm_call_1 (proc_eq, scm_from_size_t (cstart1)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0, - (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2), - "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n" - "mismatch index, depending upon whether @var{s1} is less than,\n" - "equal to, or greater than @var{s2}. The mismatch index is the\n" - "largest index @var{i} such that for every 0 <= @var{j} <\n" - "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n" - "@var{i} is the first position that does not match. The\n" - "character comparison is done case-insensitively.") -#define FUNC_NAME s_scm_string_compare_ci -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 6, start1, cstart1, - 7, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 8, start2, cstart2, - 9, end2, cend2); - SCM_VALIDATE_PROC (3, proc_lt); - SCM_VALIDATE_PROC (4, proc_eq); - SCM_VALIDATE_PROC (5, proc_gt); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); - else if (cstart2 < cend2) - return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); - else - return scm_call_1 (proc_eq, scm_from_size_t (cstart1)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n" - "value otherwise.") -#define FUNC_NAME s_scm_string_eq -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] < cstr2[cstart2]) - return SCM_BOOL_F; - else if (cstr1[cstart1] > cstr2[cstart2]) - return SCM_BOOL_F; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return SCM_BOOL_F; - else if (cstart2 < cend2) - return SCM_BOOL_F; - else - return scm_from_size_t (cstart1); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n" - "value otherwise.") -#define FUNC_NAME s_scm_string_neq -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] < cstr2[cstart2]) - return scm_from_size_t (cstart1); - else if (cstr1[cstart1] > cstr2[cstart2]) - return scm_from_size_t (cstart1); - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return scm_from_size_t (cstart1); - else if (cstart2 < cend2) - return scm_from_size_t (cstart1); - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n" - "true value otherwise.") -#define FUNC_NAME s_scm_string_lt -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] < cstr2[cstart2]) - return scm_from_size_t (cstart1); - else if (cstr1[cstart1] > cstr2[cstart2]) - return SCM_BOOL_F; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return SCM_BOOL_F; - else if (cstart2 < cend2) - return scm_from_size_t (cstart1); - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n" - "true value otherwise.") -#define FUNC_NAME s_scm_string_gt -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] < cstr2[cstart2]) - return SCM_BOOL_F; - else if (cstr1[cstart1] > cstr2[cstart2]) - return scm_from_size_t (cstart1); - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return scm_from_size_t (cstart1); - else if (cstart2 < cend2) - return SCM_BOOL_F; - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n" - "value otherwise.") -#define FUNC_NAME s_scm_string_le -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] < cstr2[cstart2]) - return scm_from_size_t (cstart1); - else if (cstr1[cstart1] > cstr2[cstart2]) - return SCM_BOOL_F; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return SCM_BOOL_F; - else if (cstart2 < cend2) - return scm_from_size_t (cstart1); - else - return scm_from_size_t (cstart1); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n" - "otherwise.") -#define FUNC_NAME s_scm_string_ge -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] < cstr2[cstart2]) - return SCM_BOOL_F; - else if (cstr1[cstart1] > cstr2[cstart2]) - return scm_from_size_t (cstart1); - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return scm_from_size_t (cstart1); - else if (cstart2 < cend2) - return SCM_BOOL_F; - else - return scm_from_size_t (cstart1); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n" - "value otherwise. The character comparison is done\n" - "case-insensitively.") -#define FUNC_NAME s_scm_string_ci_eq -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - return SCM_BOOL_F; - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - return SCM_BOOL_F; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return SCM_BOOL_F; - else if (cstart2 < cend2) - return SCM_BOOL_F; - else - return scm_from_size_t (cstart1); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n" - "value otherwise. The character comparison is done\n" - "case-insensitively.") -#define FUNC_NAME s_scm_string_ci_neq -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - return scm_from_size_t (cstart1); - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - return scm_from_size_t (cstart1); - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return scm_from_size_t (cstart1); - else if (cstart2 < cend2) - return scm_from_size_t (cstart1); - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n" - "true value otherwise. The character comparison is done\n" - "case-insensitively.") -#define FUNC_NAME s_scm_string_ci_lt -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - return scm_from_size_t (cstart1); - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - return SCM_BOOL_F; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return SCM_BOOL_F; - else if (cstart2 < cend2) - return scm_from_size_t (cstart1); - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n" - "true value otherwise. The character comparison is done\n" - "case-insensitively.") -#define FUNC_NAME s_scm_string_ci_gt -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - return SCM_BOOL_F; - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - return scm_from_size_t (cstart1); - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return scm_from_size_t (cstart1); - else if (cstart2 < cend2) - return SCM_BOOL_F; - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n" - "value otherwise. The character comparison is done\n" - "case-insensitively.") -#define FUNC_NAME s_scm_string_ci_le -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - return scm_from_size_t (cstart1); - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - return SCM_BOOL_F; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return SCM_BOOL_F; - else if (cstart2 < cend2) - return scm_from_size_t (cstart1); - else - return scm_from_size_t (cstart1); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n" - "otherwise. The character comparison is done\n" - "case-insensitively.") -#define FUNC_NAME s_scm_string_ci_ge -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - return SCM_BOOL_F; - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - return scm_from_size_t (cstart1); - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - return scm_from_size_t (cstart1); - else if (cstart2 < cend2) - return SCM_BOOL_F; - else - return scm_from_size_t (cstart1); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return the length of the longest common prefix of the two\n" - "strings.") -#define FUNC_NAME s_scm_string_prefix_length -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - size_t len = 0; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] != cstr2[cstart2]) - return scm_from_size_t (len); - len++; - cstart1++; - cstart2++; - } - return scm_from_size_t (len); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return the length of the longest common prefix of the two\n" - "strings, ignoring character case.") -#define FUNC_NAME s_scm_string_prefix_length_ci -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - size_t len = 0; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2])) - return scm_from_size_t (len); - len++; - cstart1++; - cstart2++; - } - return scm_from_size_t (len); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return the length of the longest common suffix of the two\n" - "strings.") -#define FUNC_NAME s_scm_string_suffix_length -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - size_t len = 0; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - while (cstart1 < cend1 && cstart2 < cend2) - { - cend1--; - cend2--; - if (cstr1[cend1] != cstr2[cend2]) - return scm_from_size_t (len); - len++; - } - return scm_from_size_t (len); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return the length of the longest common suffix of the two\n" - "strings, ignoring character case.") -#define FUNC_NAME s_scm_string_suffix_length_ci -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - size_t len = 0; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - while (cstart1 < cend1 && cstart2 < cend2) - { - cend1--; - cend2--; - if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2])) - return scm_from_size_t (len); - len++; - } - return scm_from_size_t (len); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Is @var{s1} a prefix of @var{s2}?") -#define FUNC_NAME s_scm_string_prefix_p -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - size_t len = 0, len1; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - len1 = cend1 - cstart1; - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] != cstr2[cstart2]) - return scm_from_bool (len == len1); - len++; - cstart1++; - cstart2++; - } - return scm_from_bool (len == len1); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Is @var{s1} a prefix of @var{s2}, ignoring character case?") -#define FUNC_NAME s_scm_string_prefix_ci_p -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - size_t len = 0, len1; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - len1 = cend1 - cstart1; - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2])) - return scm_from_bool (len == len1); - len++; - cstart1++; - cstart2++; - } - return scm_from_bool (len == len1); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Is @var{s1} a suffix of @var{s2}?") -#define FUNC_NAME s_scm_string_suffix_p -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - size_t len = 0, len1; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - len1 = cend1 - cstart1; - while (cstart1 < cend1 && cstart2 < cend2) - { - cend1--; - cend2--; - if (cstr1[cend1] != cstr2[cend2]) - return scm_from_bool (len == len1); - len++; - } - return scm_from_bool (len == len1); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Is @var{s1} a suffix of @var{s2}, ignoring character case?") -#define FUNC_NAME s_scm_string_suffix_ci_p -{ - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - size_t len = 0, len1; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - len1 = cend1 - cstart1; - while (cstart1 < cend1 && cstart2 < cend2) - { - cend1--; - cend2--; - if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2])) - return scm_from_bool (len == len1); - len++; - } - return scm_from_bool (len == len1); -} -#undef FUNC_NAME - - -/* FIXME::martin: The `S' is to avoid a name clash with the procedure - in the core, which does not accept a predicate. */ -SCM_DEFINE (scm_string_indexS, "string-index", 2, 2, 0, - (SCM s, SCM char_pred, SCM start, SCM end), - "Search through the string @var{s} from left to right, returning\n" - "the index of the first occurence of a character which\n" - "\n" - "@itemize @bullet\n" - "@item\n" - "equals @var{char_pred}, if it is character,\n" - "\n" - "@item\n" - "satisifies the predicate @var{char_pred}, if it is a procedure,\n" - "\n" - "@item\n" - "is in the set @var{char_pred}, if it is a character set.\n" - "@end itemize") -#define FUNC_NAME s_scm_string_indexS -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); - if (SCM_CHARP (char_pred)) - { - char cchr = SCM_CHAR (char_pred); - while (cstart < cend) - { - if (cchr == cstr[cstart]) - return scm_from_size_t (cstart); - cstart++; - } - } - else if (SCM_CHARSETP (char_pred)) - { - while (cstart < cend) - { - if (SCM_CHARSET_GET (char_pred, cstr[cstart])) - return scm_from_size_t (cstart); - cstart++; - } - } - else - { - SCM_VALIDATE_PROC (2, char_pred); - while (cstart < cend) - { - SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); - if (scm_is_true (res)) - return scm_from_size_t (cstart); - cstr = scm_i_string_chars (s); - cstart++; - } - } - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, - (SCM s, SCM char_pred, SCM start, SCM end), - "Search through the string @var{s} from right to left, returning\n" - "the index of the last occurence of a character which\n" - "\n" - "@itemize @bullet\n" - "@item\n" - "equals @var{char_pred}, if it is character,\n" - "\n" - "@item\n" - "satisifies the predicate @var{char_pred}, if it is a procedure,\n" - "\n" - "@item\n" - "is in the set if @var{char_pred} is a character set.\n" - "@end itemize") -#define FUNC_NAME s_scm_string_index_right -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); - if (SCM_CHARP (char_pred)) - { - char cchr = SCM_CHAR (char_pred); - while (cstart < cend) - { - cend--; - if (cchr == cstr[cend]) - return scm_from_size_t (cend); - } - } - else if (SCM_CHARSETP (char_pred)) - { - while (cstart < cend) - { - cend--; - if (SCM_CHARSET_GET (char_pred, cstr[cend])) - return scm_from_size_t (cend); - } - } - else - { - SCM_VALIDATE_PROC (2, char_pred); - while (cstart < cend) - { - SCM res; - cend--; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend])); - if (scm_is_true (res)) - return scm_from_size_t (cend); - cstr = scm_i_string_chars (s); - } - } - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, - (SCM s, SCM char_pred, SCM start, SCM end), - "Search through the string @var{s} from left to right, returning\n" - "the index of the first occurence of a character which\n" - "\n" - "@itemize @bullet\n" - "@item\n" - "does not equal @var{char_pred}, if it is character,\n" - "\n" - "@item\n" - "does not satisify the predicate @var{char_pred}, if it is a\n" - "procedure,\n" - "\n" - "@item\n" - "is not in the set if @var{char_pred} is a character set.\n" - "@end itemize") -#define FUNC_NAME s_scm_string_skip -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); - if (SCM_CHARP (char_pred)) - { - char cchr = SCM_CHAR (char_pred); - while (cstart < cend) - { - if (cchr != cstr[cstart]) - return scm_from_size_t (cstart); - cstart++; - } - } - else if (SCM_CHARSETP (char_pred)) - { - while (cstart < cend) - { - if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) - return scm_from_size_t (cstart); - cstart++; - } - } - else - { - SCM_VALIDATE_PROC (2, char_pred); - while (cstart < cend) - { - SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); - if (scm_is_false (res)) - return scm_from_size_t (cstart); - cstr = scm_i_string_chars (s); - cstart++; - } - } - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, - (SCM s, SCM char_pred, SCM start, SCM end), - "Search through the string @var{s} from right to left, returning\n" - "the index of the last occurence of a character which\n" - "\n" - "@itemize @bullet\n" - "@item\n" - "does not equal @var{char_pred}, if it is character,\n" - "\n" - "@item\n" - "does not satisfy the predicate @var{char_pred}, if it is a\n" - "procedure,\n" - "\n" - "@item\n" - "is not in the set if @var{char_pred} is a character set.\n" - "@end itemize") -#define FUNC_NAME s_scm_string_skip_right -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); - if (SCM_CHARP (char_pred)) - { - char cchr = SCM_CHAR (char_pred); - while (cstart < cend) - { - cend--; - if (cchr != cstr[cend]) - return scm_from_size_t (cend); - } - } - else if (SCM_CHARSETP (char_pred)) - { - while (cstart < cend) - { - cend--; - if (!SCM_CHARSET_GET (char_pred, cstr[cend])) - return scm_from_size_t (cend); - } - } - else - { - SCM_VALIDATE_PROC (2, char_pred); - while (cstart < cend) - { - SCM res; - cend--; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend])); - if (scm_is_false (res)) - return scm_from_size_t (cend); - cstr = scm_i_string_chars (s); - } - } - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0, - (SCM s, SCM char_pred, SCM start, SCM end), - "Return the count of the number of characters in the string\n" - "@var{s} which\n" - "\n" - "@itemize @bullet\n" - "@item\n" - "equals @var{char_pred}, if it is character,\n" - "\n" - "@item\n" - "satisifies the predicate @var{char_pred}, if it is a procedure.\n" - "\n" - "@item\n" - "is in the set @var{char_pred}, if it is a character set.\n" - "@end itemize") -#define FUNC_NAME s_scm_string_count -{ - const char *cstr; - size_t cstart, cend; - size_t count = 0; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); - if (SCM_CHARP (char_pred)) - { - char cchr = SCM_CHAR (char_pred); - while (cstart < cend) - { - if (cchr == cstr[cstart]) - count++; - cstart++; - } - } - else if (SCM_CHARSETP (char_pred)) - { - while (cstart < cend) - { - if (SCM_CHARSET_GET (char_pred, cstr[cstart])) - count++; - cstart++; - } - } - else - { - SCM_VALIDATE_PROC (2, char_pred); - while (cstart < cend) - { - SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); - if (scm_is_true (res)) - count++; - cstr = scm_i_string_chars (s); - cstart++; - } - } - return scm_from_size_t (count); -} -#undef FUNC_NAME - - -/* FIXME::martin: This should definitely get implemented more - efficiently -- maybe with Knuth-Morris-Pratt, like in the reference - implementation. */ -SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Does string @var{s1} contain string @var{s2}? Return the index\n" - "in @var{s1} where @var{s2} occurs as a substring, or false.\n" - "The optional start/end indices restrict the operation to the\n" - "indicated substrings.") -#define FUNC_NAME s_scm_string_contains -{ - const char *cs1, * cs2; - size_t cstart1, cend1, cstart2, cend2; - size_t len2, i, j; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2, - 5, start2, cstart2, - 6, end2, cend2); - len2 = cend2 - cstart2; - while (cstart1 <= cend1 - len2) - { - i = cstart1; - j = cstart2; - while (i < cend1 && j < cend2 && cs1[i] == cs2[j]) - { - i++; - j++; - } - if (j == cend2) - return scm_from_size_t (cstart1); - cstart1++; - } - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -/* FIXME::martin: This should definitely get implemented more - efficiently -- maybe with Knuth-Morris-Pratt, like in the reference - implementation. */ -SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Does string @var{s1} contain string @var{s2}? Return the index\n" - "in @var{s1} where @var{s2} occurs as a substring, or false.\n" - "The optional start/end indices restrict the operation to the\n" - "indicated substrings. Character comparison is done\n" - "case-insensitively.") -#define FUNC_NAME s_scm_string_contains_ci -{ - const char *cs1, * cs2; - size_t cstart1, cend1, cstart2, cend2; - size_t len2, i, j; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2, - 5, start2, cstart2, - 6, end2, cend2); - len2 = cend2 - cstart2; - while (cstart1 <= cend1 - len2) - { - i = cstart1; - j = cstart2; - while (i < cend1 && j < cend2 && - scm_c_downcase (cs1[i]) == scm_c_downcase (cs2[j])) - { - i++; - j++; - } - if (j == cend2) - return scm_from_size_t (cstart1); - cstart1++; - } - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -/* Helper function for the string uppercase conversion functions. - * No argument checking is performed. */ -static SCM -string_upcase_x (SCM v, int start, int end) -{ - size_t k; - char *dst; - - dst = scm_i_string_writable_chars (v); - for (k = start; k < end; ++k) - dst[k] = scm_c_upcase (dst[k]); - scm_i_string_stop_writing (); - - return v; -} - - -/* FIXME::martin: The `S' is to avoid a name clash with the procedure - in the core, which does not accept start/end indices */ -SCM_DEFINE (scm_string_upcase_xS, "string-upcase!", 1, 2, 0, - (SCM str, SCM start, SCM end), - "Destructively upcase every character in @code{str}.\n" - "\n" - "@lisp\n" - "(string-upcase! y)\n" - "@result{} \"ARRDEFG\"\n" - "y\n" - "@result{} \"ARRDEFG\"\n" - "@end lisp") -#define FUNC_NAME s_scm_string_upcase_xS -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - return string_upcase_x (str, cstart, cend); -} -#undef FUNC_NAME - - -/* FIXME::martin: The `S' is to avoid a name clash with the procedure - in the core, which does not accept start/end indices */ -SCM_DEFINE (scm_string_upcaseS, "string-upcase", 1, 2, 0, - (SCM str, SCM start, SCM end), - "Upcase every character in @code{str}.") -#define FUNC_NAME s_scm_string_upcaseS -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - return string_upcase_x (scm_string_copy (str), cstart, cend); -} -#undef FUNC_NAME - - -/* Helper function for the string lowercase conversion functions. - * No argument checking is performed. */ -static SCM -string_downcase_x (SCM v, int start, int end) -{ - size_t k; - char *dst; - - dst = scm_i_string_writable_chars (v); - for (k = start; k < end; ++k) - dst[k] = scm_c_downcase (dst[k]); - scm_i_string_stop_writing (); - - return v; -} - - -/* FIXME::martin: The `S' is to avoid a name clash with the procedure - in the core, which does not accept start/end indices */ -SCM_DEFINE (scm_string_downcase_xS, "string-downcase!", 1, 2, 0, - (SCM str, SCM start, SCM end), - "Destructively downcase every character in @var{str}.\n" - "\n" - "@lisp\n" - "y\n" - "@result{} \"ARRDEFG\"\n" - "(string-downcase! y)\n" - "@result{} \"arrdefg\"\n" - "y\n" - "@result{} \"arrdefg\"\n" - "@end lisp") -#define FUNC_NAME s_scm_string_downcase_xS -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - return string_downcase_x (str, cstart, cend); -} -#undef FUNC_NAME - - -/* FIXME::martin: The `S' is to avoid a name clash with the procedure - in the core, which does not accept start/end indices */ -SCM_DEFINE (scm_string_downcaseS, "string-downcase", 1, 2, 0, - (SCM str, SCM start, SCM end), - "Downcase every character in @var{str}.") -#define FUNC_NAME s_scm_string_downcaseS -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - return string_downcase_x (scm_string_copy (str), cstart, cend); -} -#undef FUNC_NAME - - -/* Helper function for the string capitalization functions. - * No argument checking is performed. */ -static SCM -string_titlecase_x (SCM str, int start, int end) -{ - unsigned char *sz; - size_t i; - int in_word = 0; - - sz = scm_i_string_writable_chars (str); - for(i = start; i < end; i++) - { - if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i])))) - { - if (!in_word) - { - sz[i] = scm_c_upcase(sz[i]); - in_word = 1; - } - else - { - sz[i] = scm_c_downcase(sz[i]); - } - } - else - in_word = 0; - } - scm_i_string_stop_writing (); - - return str; -} - - -SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0, - (SCM str, SCM start, SCM end), - "Destructively titlecase every first character in a word in\n" - "@var{str}.") -#define FUNC_NAME s_scm_string_titlecase_x -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - return string_titlecase_x (str, cstart, cend); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0, - (SCM str, SCM start, SCM end), - "Titlecase every first character in a word in @var{str}.") -#define FUNC_NAME s_scm_string_titlecase -{ - const char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - return string_titlecase_x (scm_string_copy (str), cstart, cend); -} -#undef FUNC_NAME - - -/* Reverse the portion of @var{str} between str[cstart] (including) - and str[cend] excluding. */ -static void -string_reverse_x (char * str, int cstart, int cend) -{ - char tmp; - - cend--; - while (cstart < cend) - { - tmp = str[cstart]; - str[cstart] = str[cend]; - str[cend] = tmp; - cstart++; - cend--; - } -} - - -SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0, - (SCM str, SCM start, SCM end), - "Reverse the string @var{str}. The optional arguments\n" - "@var{start} and @var{end} delimit the region of @var{str} to\n" - "operate on.") -#define FUNC_NAME s_scm_string_reverse -{ - const char *cstr; - char *ctarget; - size_t cstart, cend; - SCM result; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - result = scm_string_copy (str); - ctarget = scm_i_string_writable_chars (result); - string_reverse_x (ctarget, cstart, cend); - scm_i_string_stop_writing (); - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0, - (SCM str, SCM start, SCM end), - "Reverse the string @var{str} in-place. The optional arguments\n" - "@var{start} and @var{end} delimit the region of @var{str} to\n" - "operate on. The return value is unspecified.") -#define FUNC_NAME s_scm_string_reverse_x -{ - char *cstr; - size_t cstart, cend; - - MY_VALIDATE_SUBSTRING_SPEC (1, str, - 2, start, cstart, - 3, end, cend); - - cstr = scm_i_string_writable_chars (str); - string_reverse_x (cstr, cstart, cend); - scm_i_string_stop_writing (); - - scm_remember_upto_here_1 (str); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1, - (SCM ls), - "Like @code{string-append}, but the result may share memory\n" - "with the argument strings.") -#define FUNC_NAME s_scm_string_append_shared -{ - long i; - - SCM_VALIDATE_REST_ARGUMENT (ls); - - /* Optimize the one-argument case. */ - i = scm_ilength (ls); - if (i == 1) - return SCM_CAR (ls); - else - return scm_string_append (ls); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0, - (SCM ls), - "Append the elements of @var{ls} (which must be strings)\n" - "together into a single string. Guaranteed to return a freshly\n" - "allocated string.") -#define FUNC_NAME s_scm_string_concatenate -{ - long strings = scm_ilength (ls); - SCM tmp, result; - size_t len = 0; - char *p; - - /* Validate the string list. */ - if (strings < 0) - SCM_WRONG_TYPE_ARG (1, ls); - - /* Calculate the size of the result string. */ - tmp = ls; - while (!SCM_NULLP (tmp)) - { - SCM elt = SCM_CAR (tmp); - SCM_VALIDATE_STRING (1, elt); - len += scm_i_string_length (elt); - tmp = SCM_CDR (tmp); - } - result = scm_i_make_string (len, &p); - - /* Copy the list elements into the result. */ - tmp = ls; - while (!SCM_NULLP (tmp)) - { - SCM elt = SCM_CAR (tmp); - memmove (p, scm_i_string_chars (elt), - scm_i_string_length (elt)); - p += scm_i_string_length (elt); - tmp = SCM_CDR (tmp); - } - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, 0, - (SCM ls, SCM final_string, SCM end), - "Without optional arguments, this procedure is equivalent to\n" - "\n" - "@smalllisp\n" - "(string-concatenate (reverse ls))\n" - "@end smalllisp\n" - "\n" - "If the optional argument @var{final_string} is specified, it is\n" - "consed onto the beginning to @var{ls} before performing the\n" - "list-reverse and string-concatenate operations. If @var{end}\n" - "is given, only the characters of @var{final_string} up to index\n" - "@var{end} are used.\n" - "\n" - "Guaranteed to return a freshly allocated string.") -#define FUNC_NAME s_scm_string_concatenate_reverse -{ - long strings; - SCM tmp, result; - size_t len = 0; - char * p; - size_t cend = 0; - - /* Check the optional arguments and calculate the additional length - of the result string. */ - if (!SCM_UNBNDP (final_string)) - { - SCM_VALIDATE_STRING (2, final_string); - if (!SCM_UNBNDP (end)) - { - cend = scm_to_unsigned_integer (end, - 0, - scm_i_string_length (final_string)); - } - else - { - cend = scm_i_string_length (final_string); - } - len += cend; - } - strings = scm_ilength (ls); - /* Validate the string list. */ - if (strings < 0) - SCM_WRONG_TYPE_ARG (1, ls); - - /* Calculate the length of the result string. */ - tmp = ls; - while (!SCM_NULLP (tmp)) - { - SCM elt = SCM_CAR (tmp); - SCM_VALIDATE_STRING (1, elt); - len += scm_i_string_length (elt); - tmp = SCM_CDR (tmp); - } - - result = scm_i_make_string (len, &p); - - p += len; - - /* Construct the result string, possibly by using the optional final - string. */ - if (!SCM_UNBNDP (final_string)) - { - p -= cend; - memmove (p, scm_i_string_chars (final_string), cend); - } - tmp = ls; - while (!SCM_NULLP (tmp)) - { - SCM elt = SCM_CAR (tmp); - p -= scm_i_string_length (elt); - memmove (p, scm_i_string_chars (elt), - scm_i_string_length (elt)); - tmp = SCM_CDR (tmp); - } - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_concatenate_shared, "string-concatenate/shared", 1, 0, 0, - (SCM ls), - "Like @code{string-concatenate}, but the result may share memory\n" - "with the strings in the list @var{ls}.") -#define FUNC_NAME s_scm_string_concatenate_shared -{ - /* Optimize the one-string case. */ - long i = scm_ilength (ls); - if (i == 1) - { - SCM_VALIDATE_STRING (1, SCM_CAR (ls)); - return SCM_CAR (ls); - } - return scm_string_concatenate (ls); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_concatenate_reverse_shared, "string-concatenate-reverse/shared", 1, 2, 0, - (SCM ls, SCM final_string, SCM end), - "Like @code{string-concatenate-reverse}, but the result may\n" - "share memory with the the strings in the @var{ls} arguments.") -#define FUNC_NAME s_scm_string_concatenate_reverse_shared -{ - /* Just call the non-sharing version. */ - return scm_string_concatenate_reverse (ls, final_string, end); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, - (SCM proc, SCM s, SCM start, SCM end), - "@var{proc} is a char->char procedure, it is mapped over\n" - "@var{s}. The order in which the procedure is applied to the\n" - "string elements is not specified.") -#define FUNC_NAME s_scm_string_map -{ - const char *cstr; - char *p; - size_t cstart, cend; - SCM result; - - SCM_VALIDATE_PROC (1, proc); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); - result = scm_i_make_string (cend - cstart, &p); - while (cstart < cend) - { - unsigned int c = (unsigned char) cstr[cstart]; - SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (c)); - if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); - cstr = scm_i_string_chars (s); - cstart++; - *p++ = SCM_CHAR (ch); - } - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0, - (SCM proc, SCM s, SCM start, SCM end), - "@var{proc} is a char->char procedure, it is mapped over\n" - "@var{s}. The order in which the procedure is applied to the\n" - "string elements is not specified. The string @var{s} is\n" - "modified in-place, the return value is not specified.") -#define FUNC_NAME s_scm_string_map_x -{ - size_t cstart, cend; - - SCM_VALIDATE_PROC (1, proc); - MY_VALIDATE_SUBSTRING_SPEC (2, s, - 3, start, cstart, - 4, end, cend); - while (cstart < cend) - { - SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart)); - if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); - scm_c_string_set_x (s, cstart, ch); - cstart++; - } - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0, - (SCM kons, SCM knil, SCM s, SCM start, SCM end), - "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n" - "as the terminating element, from left to right. @var{kons}\n" - "must expect two arguments: The actual character and the last\n" - "result of @var{kons}' application.") -#define FUNC_NAME s_scm_string_fold -{ - const char *cstr; - size_t cstart, cend; - SCM result; - - SCM_VALIDATE_PROC (1, kons); - MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, - 4, start, cstart, - 5, end, cend); - result = knil; - while (cstart < cend) - { - unsigned int c = (unsigned char) cstr[cstart]; - result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result); - cstr = scm_i_string_chars (s); - cstart++; - } - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0, - (SCM kons, SCM knil, SCM s, SCM start, SCM end), - "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n" - "as the terminating element, from right to left. @var{kons}\n" - "must expect two arguments: The actual character and the last\n" - "result of @var{kons}' application.") -#define FUNC_NAME s_scm_string_fold_right -{ - const char *cstr; - size_t cstart, cend; - SCM result; - - SCM_VALIDATE_PROC (1, kons); - MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, - 4, start, cstart, - 5, end, cend); - result = knil; - while (cstart < cend) - { - unsigned int c = (unsigned char) cstr[cend - 1]; - result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result); - cstr = scm_i_string_chars (s); - cend--; - } - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0, - (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final), - "@itemize @bullet\n" - "@item @var{g} is used to generate a series of @emph{seed}\n" - "values from the initial @var{seed}: @var{seed}, (@var{g}\n" - "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n" - "@dots{}\n" - "@item @var{p} tells us when to stop -- when it returns true\n" - "when applied to one of these seed values.\n" - "@item @var{f} maps each seed value to the corresponding\n" - "character in the result string. These chars are assembled\n" - "into the string in a left-to-right order.\n" - "@item @var{base} is the optional initial/leftmost portion\n" - "of the constructed string; it default to the empty\n" - "string.\n" - "@item @var{make_final} is applied to the terminal seed\n" - "value (on which @var{p} returns true) to produce\n" - "the final/rightmost portion of the constructed string.\n" - "It defaults to @code{(lambda (x) "")}.\n" - "@end itemize") -#define FUNC_NAME s_scm_string_unfold -{ - SCM res, ans; - - SCM_VALIDATE_PROC (1, p); - SCM_VALIDATE_PROC (2, f); - SCM_VALIDATE_PROC (3, g); - if (!SCM_UNBNDP (base)) - { - SCM_VALIDATE_STRING (5, base); - ans = base; - } - else - ans = scm_i_make_string (0, NULL); - if (!SCM_UNBNDP (make_final)) - SCM_VALIDATE_PROC (6, make_final); - - res = scm_call_1 (p, seed); - while (scm_is_false (res)) - { - SCM str; - char *ptr; - SCM ch = scm_call_1 (f, seed); - if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); - str = scm_i_make_string (1, &ptr); - *ptr = SCM_CHAR (ch); - - ans = scm_string_append (scm_list_2 (ans, str)); - seed = scm_call_1 (g, seed); - res = scm_call_1 (p, seed); - } - if (!SCM_UNBNDP (make_final)) - { - res = scm_call_1 (make_final, seed); - return scm_string_append (scm_list_2 (ans, res)); - } - else - return ans; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0, - (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final), - "@itemize @bullet\n" - "@item @var{g} is used to generate a series of @emph{seed}\n" - "values from the initial @var{seed}: @var{seed}, (@var{g}\n" - "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n" - "@dots{}\n" - "@item @var{p} tells us when to stop -- when it returns true\n" - "when applied to one of these seed values.\n" - "@item @var{f} maps each seed value to the corresponding\n" - "character in the result string. These chars are assembled\n" - "into the string in a right-to-left order.\n" - "@item @var{base} is the optional initial/rightmost portion\n" - "of the constructed string; it default to the empty\n" - "string.\n" - "@item @var{make_final} is applied to the terminal seed\n" - "value (on which @var{p} returns true) to produce\n" - "the final/leftmost portion of the constructed string.\n" - "It defaults to @code{(lambda (x) "")}.\n" - "@end itemize") -#define FUNC_NAME s_scm_string_unfold_right -{ - SCM res, ans; - - SCM_VALIDATE_PROC (1, p); - SCM_VALIDATE_PROC (2, f); - SCM_VALIDATE_PROC (3, g); - if (!SCM_UNBNDP (base)) - { - SCM_VALIDATE_STRING (5, base); - ans = base; - } - else - ans = scm_i_make_string (0, NULL); - if (!SCM_UNBNDP (make_final)) - SCM_VALIDATE_PROC (6, make_final); - - res = scm_call_1 (p, seed); - while (scm_is_false (res)) - { - SCM str; - char *ptr; - SCM ch = scm_call_1 (f, seed); - if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); - str = scm_i_make_string (1, &ptr); - *ptr = SCM_CHAR (ch); - - ans = scm_string_append (scm_list_2 (str, ans)); - seed = scm_call_1 (g, seed); - res = scm_call_1 (p, seed); - } - if (!SCM_UNBNDP (make_final)) - { - res = scm_call_1 (make_final, seed); - return scm_string_append (scm_list_2 (res, ans)); - } - else - return ans; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0, - (SCM proc, SCM s, SCM start, SCM end), - "@var{proc} is mapped over @var{s} in left-to-right order. The\n" - "return value is not specified.") -#define FUNC_NAME s_scm_string_for_each -{ - const char *cstr; - size_t cstart, cend; - - SCM_VALIDATE_PROC (1, proc); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); - while (cstart < cend) - { - unsigned int c = (unsigned char) cstr[cstart]; - scm_call_1 (proc, SCM_MAKE_CHAR (c)); - cstr = scm_i_string_chars (s); - cstart++; - } - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0, - (SCM proc, SCM s, SCM start, SCM end), - "@var{proc} is mapped over @var{s} in left-to-right order. The\n" - "return value is not specified.") -#define FUNC_NAME s_scm_string_for_each -{ - const char *cstr; - size_t cstart, cend; - - SCM_VALIDATE_PROC (1, proc); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); - while (cstart < cend) - { - scm_call_1 (proc, scm_from_size_t (cstart)); - cstart++; - } - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, - (SCM s, SCM from, SCM to, SCM start, SCM end), - "This is the @emph{extended substring} procedure that implements\n" - "replicated copying of a substring of some string.\n" - "\n" - "@var{s} is a string, @var{start} and @var{end} are optional\n" - "arguments that demarcate a substring of @var{s}, defaulting to\n" - "0 and the length of @var{s}. Replicate this substring up and\n" - "down index space, in both the positive and negative directions.\n" - "@code{xsubstring} returns the substring of this string\n" - "beginning at index @var{from}, and ending at @var{to}, which\n" - "defaults to @var{from} + (@var{end} - @var{start}).") -#define FUNC_NAME s_scm_xsubstring -{ - const char *cs; - char *p; - size_t cstart, cend, cfrom, cto; - SCM result; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cs, - 4, start, cstart, - 5, end, cend); - cfrom = scm_to_size_t (from); - if (SCM_UNBNDP (to)) - cto = cfrom + (cend - cstart); - else - cto = scm_to_size_t (to); - if (cstart == cend && cfrom != cto) - SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); - - result = scm_i_make_string (cto - cfrom, &p); - - while (cfrom < cto) - { - int t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart); - if (cfrom < 0) - *p = cs[(cend - cstart) - t]; - else - *p = cs[t]; - cfrom++; - p++; - } - scm_remember_upto_here_1 (s); - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, - (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end), - "Exactly the same as @code{xsubstring}, but the extracted text\n" - "is written into the string @var{target} starting at index\n" - "@var{tstart}. The operation is not defined if @code{(eq?\n" - "@var{target} @var{s})} or these arguments share storage -- you\n" - "cannot copy a string on top of itself.") -#define FUNC_NAME s_scm_string_xcopy_x -{ - char *p; - const char *cs; - size_t ctstart, csfrom, csto, cstart, cend; - SCM dummy = SCM_UNDEFINED; - int cdummy; - - MY_VALIDATE_SUBSTRING_SPEC (1, target, - 2, tstart, ctstart, - 2, dummy, cdummy); - MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cs, - 6, start, cstart, - 7, end, cend); - csfrom = scm_to_size_t (sfrom); - if (SCM_UNBNDP (sto)) - csto = csfrom + (cend - cstart); - else - csto = scm_to_size_t (sto); - if (cstart == cend && csfrom != csto) - SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); - SCM_ASSERT_RANGE (1, tstart, - ctstart + (csto - csfrom) <= scm_i_string_length (target)); - - p = scm_i_string_writable_chars (target) + ctstart; - while (csfrom < csto) - { - int t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart); - if (csfrom < 0) - *p = cs[(cend - cstart) - t]; - else - *p = cs[t]; - csfrom++; - p++; - } - scm_i_string_stop_writing (); - - scm_remember_upto_here_2 (target, s); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return the string @var{s1}, but with the characters\n" - "@var{start1} @dots{} @var{end1} replaced by the characters\n" - "@var{start2} @dots{} @var{end2} from @var{s2}.") -#define FUNC_NAME s_scm_string_replace -{ - const char *cstr1, *cstr2; - char *p; - size_t cstart1, cend1, cstart2, cend2; - SCM result; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - result = scm_i_make_string (cstart1 + (cend2 - cstart2) + - scm_i_string_length (s1) - cend1, &p); - memmove (p, cstr1, cstart1 * sizeof (char)); - memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2) * sizeof (char)); - memmove (p + cstart1 + (cend2 - cstart2), - cstr1 + cend1, - (scm_i_string_length (s1) - cend1) * sizeof (char)); - scm_remember_upto_here_2 (s1, s2); - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, - (SCM s, SCM token_set, SCM start, SCM end), - "Split the string @var{s} into a list of substrings, where each\n" - "substring is a maximal non-empty contiguous sequence of\n" - "characters from the character set @var{token_set}, which\n" - "defaults to @code{char-set:graphic} from module (srfi srfi-14).\n" - "If @var{start} or @var{end} indices are provided, they restrict\n" - "@code{string-tokenize} to operating on the indicated substring\n" - "of @var{s}.") -#define FUNC_NAME s_scm_string_tokenize -{ - const char *cstr; - size_t cstart, cend; - SCM result = SCM_EOL; - - static SCM charset_graphic = SCM_BOOL_F; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); - - if (SCM_UNBNDP (token_set)) - { - if (charset_graphic == SCM_BOOL_F) - { - SCM srfi_14_module = scm_c_resolve_module ("srfi srfi-14"); - SCM charset_graphic_var = scm_c_module_lookup (srfi_14_module, - "char-set:graphic"); - charset_graphic = - scm_permanent_object (SCM_VARIABLE_REF (charset_graphic_var)); - } - token_set = charset_graphic; - } - - if (SCM_CHARSETP (token_set)) - { - int idx; - - while (cstart < cend) - { - while (cstart < cend) - { - if (SCM_CHARSET_GET (token_set, cstr[cend - 1])) - break; - cend--; - } - if (cstart >= cend) - break; - idx = cend; - while (cstart < cend) - { - if (!SCM_CHARSET_GET (token_set, cstr[cend - 1])) - break; - cend--; - } - result = scm_cons (scm_c_substring (s, cend, idx), result); - cstr = scm_i_string_chars (s); - } - } - else SCM_WRONG_TYPE_ARG (2, token_set); - scm_remember_upto_here_1 (s); - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, - (SCM s, SCM char_pred, SCM start, SCM end), - "Filter the string @var{s}, retaining only those characters that\n" - "satisfy the @var{char_pred} argument. If the argument is a\n" - "procedure, it is applied to each character as a predicate, if\n" - "it is a character, it is tested for equality and if it is a\n" - "character set, it is tested for membership.") -#define FUNC_NAME s_scm_string_filter -{ - const char *cstr; - size_t cstart, cend; - SCM result; - size_t idx; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); - if (SCM_CHARP (char_pred)) - { - SCM ls = SCM_EOL; - char chr; - - chr = SCM_CHAR (char_pred); - idx = cstart; - while (idx < cend) - { - if (cstr[idx] == chr) - ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); - cstr = scm_i_string_chars (s); - idx++; - } - result = scm_reverse_list_to_string (ls); - } - else if (SCM_CHARSETP (char_pred)) - { - SCM ls = SCM_EOL; - - idx = cstart; - while (idx < cend) - { - if (SCM_CHARSET_GET (char_pred, cstr[idx])) - ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); - cstr = scm_i_string_chars (s); - idx++; - } - result = scm_reverse_list_to_string (ls); - } - else - { - SCM ls = SCM_EOL; - - SCM_VALIDATE_PROC (2, char_pred); - idx = cstart; - while (idx < cend) - { - SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx])); - if (scm_is_true (res)) - ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); - cstr = scm_i_string_chars (s); - idx++; - } - result = scm_reverse_list_to_string (ls); - } - scm_remember_upto_here_1 (s); - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, - (SCM s, SCM char_pred, SCM start, SCM end), - "Filter the string @var{s}, retaining only those characters that\n" - "do not satisfy the @var{char_pred} argument. If the argument\n" - "is a procedure, it is applied to each character as a predicate,\n" - "if it is a character, it is tested for equality and if it is a\n" - "character set, it is tested for membership.") -#define FUNC_NAME s_scm_string_delete -{ - const char *cstr; - size_t cstart, cend; - SCM result; - size_t idx; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); - if (SCM_CHARP (char_pred)) - { - SCM ls = SCM_EOL; - char chr; - - chr = SCM_CHAR (char_pred); - idx = cstart; - while (idx < cend) - { - if (cstr[idx] != chr) - ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); - cstr = scm_i_string_chars (s); - idx++; - } - result = scm_reverse_list_to_string (ls); - } - else if (SCM_CHARSETP (char_pred)) - { - SCM ls = SCM_EOL; - - idx = cstart; - while (idx < cend) - { - if (!SCM_CHARSET_GET (char_pred, cstr[idx])) - ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); - cstr = scm_i_string_chars (s); - idx++; - } - result = scm_reverse_list_to_string (ls); - } - else - { - SCM ls = SCM_EOL; - - SCM_VALIDATE_PROC (2, char_pred); - idx = cstart; - while (idx < cend) - { - SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx])); - if (scm_is_false (res)) - ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); - cstr = scm_i_string_chars (s); - idx++; - } - result = scm_reverse_list_to_string (ls); - } - return result; -} -#undef FUNC_NAME - - -/* Initialize the SRFI-13 module. This function will be called by the - loading Scheme module. */ void scm_init_srfi_13 (void) { - /* We initialize the SRFI-14 module here, because the string - primitives need the charset smob type created by that module. */ - scm_c_init_srfi_14 (); - - /* Install the string primitives. */ -#include "srfi/srfi-13.x" } -/* End of srfi-13.c. */ +void +scm_init_srfi_13_14 (void) +{ +} diff --git a/srfi/srfi-13.h b/srfi/srfi-13.h index 68def2842..c4cf0cb60 100644 --- a/srfi/srfi-13.h +++ b/srfi/srfi-13.h @@ -1,6 +1,7 @@ #ifndef SCM_SRFI_13_H #define SCM_SRFI_13_H -/* srfi-13.c --- SRFI-13 procedures for Guile + +/* SRFI-13 procedures for Guile * * Copyright (C) 2001, 2004 Free Software Foundation, Inc. * @@ -20,6 +21,10 @@ */ +/* All SRFI-13 procedures are in in the core now. */ + +#include + /* SCM_SRFI1314_API is a macro prepended to all function and data definitions which should be exported or imported in the resulting dynamic link library in the Win32 port. */ @@ -35,80 +40,17 @@ SCM_SRFI1314_API void scm_init_srfi_13 (void); SCM_SRFI1314_API void scm_init_srfi_13_14 (void); -SCM_SRFI1314_API SCM scm_string_any (SCM pred, SCM s, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_every (SCM pred, SCM s, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_tabulate (SCM proc, SCM len); -SCM_SRFI1314_API SCM scm_string_to_listS (SCM str, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_reverse_list_to_string (SCM chrs); -SCM_SRFI1314_API SCM scm_string_join (SCM ls, SCM delimiter, SCM grammar); -SCM_SRFI1314_API SCM scm_string_copyS (SCM str, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_substring_sharedS (SCM str, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_copy_x (SCM target, SCM tstart, SCM s, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_take (SCM s, SCM n); -SCM_SRFI1314_API SCM scm_string_drop (SCM s, SCM n); -SCM_SRFI1314_API SCM scm_string_take_right (SCM s, SCM n); -SCM_SRFI1314_API SCM scm_string_drop_right (SCM s, SCM n); -SCM_SRFI1314_API SCM scm_string_pad (SCM s, SCM len, SCM chr, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_pad_right (SCM s, SCM len, SCM chr, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_trim (SCM s, SCM char_pred, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_trim_right (SCM s, SCM char_pred, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_trim_both (SCM s, SCM char_pred, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_fill_xS (SCM str, SCM chr, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_compare (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_compare_ci (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_ci_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_ci_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_ci_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_ci_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_ci_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_ci_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_prefix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_prefix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_suffix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_suffix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_prefix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_prefix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_suffix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_suffix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_indexS (SCM s, SCM char_pred, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_index_right (SCM s, SCM char_pred, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_skip (SCM s, SCM char_pred, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_skip_right (SCM s, SCM char_pred, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_count (SCM s, SCM char_pred, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_contains (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_contains_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_upcase_xS (SCM str, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_upcaseS (SCM str, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_downcase_xS (SCM str, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_downcaseS (SCM str, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_titlecase_x (SCM str, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_titlecase (SCM str, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_reverse (SCM str, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_reverse_x (SCM str, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_append_shared (SCM ls); -SCM_SRFI1314_API SCM scm_string_concatenate (SCM ls); -SCM_SRFI1314_API SCM scm_string_concatenate_shared (SCM ls); -SCM_SRFI1314_API SCM scm_string_concatenate_reverse (SCM ls, SCM final_string, SCM end); -SCM_SRFI1314_API SCM scm_string_concatenate_reverse_shared (SCM ls, SCM final_string, SCM end); -SCM_SRFI1314_API SCM scm_string_map (SCM proc, SCM s, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_map_x (SCM proc, SCM s, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_fold (SCM kons, SCM knil, SCM s, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_fold_right (SCM kons, SCM knil, SCM s, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final); -SCM_SRFI1314_API SCM scm_string_unfold_right (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final); -SCM_SRFI1314_API SCM scm_string_for_each (SCM proc, SCM s, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_for_each_index (SCM proc, SCM s, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_xsubstring (SCM s, SCM from, SCM to, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_xcopy_x (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_replace (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); -SCM_SRFI1314_API SCM scm_string_tokenize (SCM s, SCM token_char, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_filter (SCM s, SCM char_pred, SCM start, SCM end); -SCM_SRFI1314_API SCM scm_string_delete (SCM s, SCM char_pred, SCM start, SCM end); +/* The following functions have new names in the core. + */ + +#define scm_string_to_listS scm_substring_to_list +#define scm_string_copyS scm_substring_copy +#define scm_substring_sharedS scm_substring_shared +#define scm_string_fill_xS scm_substring_fill_x +#define scm_string_indexS scm_string_index +#define scm_string_upcase_xS scm_substring_upcase_x +#define scm_string_upcaseS scm_substring_upcase +#define scm_string_downcase_xS scm_substring_downcase_x +#define scm_string_downcaseS scm_substring_downcase #endif /* SCM_SRFI_13_H */ diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm index b9b8d03ca..49420f70f 100644 --- a/srfi/srfi-13.scm +++ b/srfi/srfi-13.scm @@ -19,28 +19,35 @@ ;;; Commentary: ;; This module is fully documented in the Guile Reference Manual. +;; +;; All procedures are in the core and are simply reexported here. ;;; Code: -(define-module (srfi srfi-13) - :export ( +(define-module (srfi srfi-13)) + +(re-export ;;; Predicates - ;; string? string-null? <= in the core - string-any string-every + string? + string-null? + string-any + string-every ;;; Constructors - ;; make-string string <= in the core + make-string + string string-tabulate ;;; List/string conversion - ;; string->list extended - ;; list->string <= in the core + string->list + list->string reverse-list->string string-join ;;; Selection - ;; string-length string-ref <= in the core - ;; string-copy extended + string-length + string-ref + string-copy substring/shared string-copy! string-take string-take-right @@ -50,11 +57,12 @@ string-trim-both ;;; Modification - ;; string-set! <= in the core - ;; string-fill! extended + string-set! + string-fill! ;;; Comparison - string-compare string-compare-ci + string-compare + string-compare-ci string= string<> string< string> string<= string>= @@ -74,21 +82,24 @@ string-suffix-ci? ;;; Searching - ;; string-index extended + string-index string-index-right string-skip string-skip-right string-count string-contains string-contains-ci ;;; Alphabetic case mapping - - ;; string-upcase string-upcase! extended - ;; string-downcase string-downcase! extended - string-titlecase string-titlecase! + string-upcase + string-upcase! + string-downcase + string-downcase! + string-titlecase + string-titlecase! ;;; Reverse/Append - string-reverse string-reverse! - ;; string-append <= in the core + string-reverse + string-reverse! + string-append string-append/shared string-concatenate string-concatenate-reverse @@ -105,7 +116,8 @@ string-for-each-index ;;; Replicate/Rotate - xsubstring string-xcopy! + xsubstring + string-xcopy! ;;; Miscellaneous string-replace @@ -113,43 +125,8 @@ ;;; Filtering/Deleting string-filter - string-delete - ) - :replace (string->list string-copy string-fill! - string-upcase! string-upcase string-downcase! string-downcase - string-index substring/shared) - ) + string-delete) (cond-expand-provide (current-module) '(srfi-13)) -(load-extension "libguile-srfi-srfi-13-14" "scm_init_srfi_13") - -(define string-hash - (lambda (s . rest) - (let ((bound (if (pair? rest) - (or (car rest) - 871) - 871)) - (start (if (and (pair? rest) (pair? (cdr rest))) - (cadr rest) - 0)) - (end (if (and (pair? rest) (pair? (cdr rest)) (pair? (cddr rest))) - (caddr rest) - (string-length s)))) - (hash (substring/shared s start end) bound)))) - -(define string-hash-ci - (lambda (s . rest) - (let ((bound (if (pair? rest) - (or (car rest) - 871) - 871)) - (start (if (and (pair? rest) (pair? (cdr rest))) - (cadr rest) - 0)) - (end (if (and (pair? rest) (pair? (cdr rest)) (pair? (cddr rest))) - (caddr rest) - (string-length s)))) - (hash (string-upcase (substring/shared s start end)) bound)))) - ;;; srfi-13.scm ends here diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 4c7812512..c2fd02c29 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -1,4 +1,4 @@ -/* srfi-14.c --- SRFI-14 procedures for Guile +/* srfi-14.c --- Old place of SRFI-14 procedures for Guile * * Copyright (C) 2001, 2004 Free Software Foundation, Inc. * @@ -17,1406 +17,14 @@ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ +#include "srfi/srfi-14.h" -#include - -#include - -#include "srfi-14.h" - - -#define SCM_CHARSET_SET(cs, idx) \ - (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= \ - (1L << ((idx) % SCM_BITS_PER_LONG))) - -#define BYTES_PER_CHARSET (SCM_CHARSET_SIZE / 8) -#define LONGS_PER_CHARSET (SCM_CHARSET_SIZE / SCM_BITS_PER_LONG) - - -/* Smob type code for character sets. */ -int scm_tc16_charset = 0; - - -/* Smob print hook for character sets. */ -static int -charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED) -{ - int i; - int first = 1; - - scm_puts ("#", port); - return 1; -} - - -/* Smob free hook for character sets. */ -static size_t -charset_free (SCM charset) -{ - return scm_smob_free (charset); -} - - -/* Create a new, empty character set. */ -static SCM -make_char_set (const char * func_name) -{ - long * p; - - p = scm_gc_malloc (BYTES_PER_CHARSET, "character-set"); - memset (p, 0, BYTES_PER_CHARSET); - SCM_RETURN_NEWSMOB (scm_tc16_charset, p); -} - - -SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a character set, @code{#f}\n" - "otherwise.") -#define FUNC_NAME s_scm_char_set_p -{ - return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_charset, obj)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, - (SCM char_sets), - "Return @code{#t} if all given character sets are equal.") -#define FUNC_NAME s_scm_char_set_eq -{ - int argnum = 1; - long *cs1_data = NULL; - - SCM_VALIDATE_REST_ARGUMENT (char_sets); - - while (!SCM_NULLP (char_sets)) - { - SCM csi = SCM_CAR (char_sets); - long *csi_data; - - SCM_VALIDATE_SMOB (argnum, csi, charset); - argnum++; - csi_data = (long *) SCM_SMOB_DATA (csi); - if (cs1_data == NULL) - cs1_data = csi_data; - else if (memcmp (cs1_data, csi_data, BYTES_PER_CHARSET) != 0) - return SCM_BOOL_F; - char_sets = SCM_CDR (char_sets); - } - return SCM_BOOL_T; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1, - (SCM char_sets), - "Return @code{#t} if every character set @var{cs}i is a subset\n" - "of character set @var{cs}i+1.") -#define FUNC_NAME s_scm_char_set_leq -{ - int argnum = 1; - long *prev_data = NULL; - - SCM_VALIDATE_REST_ARGUMENT (char_sets); - - while (!SCM_NULLP (char_sets)) - { - SCM csi = SCM_CAR (char_sets); - long *csi_data; - - SCM_VALIDATE_SMOB (argnum, csi, charset); - argnum++; - csi_data = (long *) SCM_SMOB_DATA (csi); - if (prev_data) - { - int k; - - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - if ((prev_data[k] & csi_data[k]) != prev_data[k]) - return SCM_BOOL_F; - } - } - prev_data = csi_data; - char_sets = SCM_CDR (char_sets); - } - return SCM_BOOL_T; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, - (SCM cs, SCM bound), - "Compute a hash value for the character set @var{cs}. If\n" - "@var{bound} is given and non-zero, it restricts the\n" - "returned value to the range 0 @dots{} @var{bound - 1}.") -#define FUNC_NAME s_scm_char_set_hash -{ - const unsigned long default_bnd = 871; - unsigned long bnd; - long * p; - unsigned long val = 0; - int k; - - SCM_VALIDATE_SMOB (1, cs, charset); - - if (SCM_UNBNDP (bound)) - bnd = default_bnd; - else - { - bnd = scm_to_ulong (bound); - if (bnd == 0) - bnd = default_bnd; - } - - p = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - if (p[k] != 0) - val = p[k] + (val << 1); - } - return scm_from_ulong (val % bnd); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0, - (SCM cs), - "Return a cursor into the character set @var{cs}.") -#define FUNC_NAME s_scm_char_set_cursor -{ - int idx; - - SCM_VALIDATE_SMOB (1, cs, charset); - for (idx = 0; idx < SCM_CHARSET_SIZE; idx++) - { - if (SCM_CHARSET_GET (cs, idx)) - break; - } - return SCM_I_MAKINUM (idx); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0, - (SCM cs, SCM cursor), - "Return the character at the current cursor position\n" - "@var{cursor} in the character set @var{cs}. It is an error to\n" - "pass a cursor for which @code{end-of-char-set?} returns true.") -#define FUNC_NAME s_scm_char_set_ref -{ - size_t ccursor = scm_to_size_t (cursor); - SCM_VALIDATE_SMOB (1, cs, charset); - - if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) - SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); - return SCM_MAKE_CHAR (ccursor); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0, - (SCM cs, SCM cursor), - "Advance the character set cursor @var{cursor} to the next\n" - "character in the character set @var{cs}. It is an error if the\n" - "cursor given satisfies @code{end-of-char-set?}.") -#define FUNC_NAME s_scm_char_set_cursor_next -{ - size_t ccursor = scm_to_size_t (cursor); - SCM_VALIDATE_SMOB (1, cs, charset); - - if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) - SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); - for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++) - { - if (SCM_CHARSET_GET (cs, ccursor)) - break; - } - return SCM_I_MAKINUM (ccursor); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0, - (SCM cursor), - "Return @code{#t} if @var{cursor} has reached the end of a\n" - "character set, @code{#f} otherwise.") -#define FUNC_NAME s_scm_end_of_char_set_p -{ - size_t ccursor = scm_to_size_t (cursor); - return scm_from_bool (ccursor >= SCM_CHARSET_SIZE); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0, - (SCM kons, SCM knil, SCM cs), - "Fold the procedure @var{kons} over the character set @var{cs},\n" - "initializing it with @var{knil}.") -#define FUNC_NAME s_scm_char_set_fold -{ - int k; - - SCM_VALIDATE_PROC (1, kons); - SCM_VALIDATE_SMOB (3, cs, charset); - - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - { - knil = scm_call_2 (kons, SCM_MAKE_CHAR (k), knil); - } - return knil; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0, - (SCM p, SCM f, SCM g, SCM seed, SCM base_cs), - "This is a fundamental constructor for character sets.\n" - "@itemize @bullet\n" - "@item @var{g} is used to generate a series of ``seed'' values\n" - "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n" - "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n" - "@item @var{p} tells us when to stop -- when it returns true\n" - "when applied to one of the seed values.\n" - "@item @var{f} maps each seed value to a character. These\n" - "characters are added to the base character set @var{base_cs} to\n" - "form the result; @var{base_cs} defaults to the empty set.\n" - "@end itemize") -#define FUNC_NAME s_scm_char_set_unfold -{ - SCM result, tmp; - - SCM_VALIDATE_PROC (1, p); - SCM_VALIDATE_PROC (2, f); - SCM_VALIDATE_PROC (3, g); - if (!SCM_UNBNDP (base_cs)) - { - SCM_VALIDATE_SMOB (5, base_cs, charset); - result = scm_char_set_copy (base_cs); - } - else - result = make_char_set (FUNC_NAME); - - tmp = scm_call_1 (p, seed); - while (scm_is_false (tmp)) - { - SCM ch = scm_call_1 (f, seed); - if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); - SCM_CHARSET_SET (result, SCM_CHAR (ch)); - - seed = scm_call_1 (g, seed); - tmp = scm_call_1 (p, seed); - } - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0, - (SCM p, SCM f, SCM g, SCM seed, SCM base_cs), - "This is a fundamental constructor for character sets.\n" - "@itemize @bullet\n" - "@item @var{g} is used to generate a series of ``seed'' values\n" - "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n" - "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n" - "@item @var{p} tells us when to stop -- when it returns true\n" - "when applied to one of the seed values.\n" - "@item @var{f} maps each seed value to a character. These\n" - "characters are added to the base character set @var{base_cs} to\n" - "form the result; @var{base_cs} defaults to the empty set.\n" - "@end itemize") -#define FUNC_NAME s_scm_char_set_unfold_x -{ - SCM tmp; - - SCM_VALIDATE_PROC (1, p); - SCM_VALIDATE_PROC (2, f); - SCM_VALIDATE_PROC (3, g); - SCM_VALIDATE_SMOB (5, base_cs, charset); - - tmp = scm_call_1 (p, seed); - while (scm_is_false (tmp)) - { - SCM ch = scm_call_1 (f, seed); - if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); - SCM_CHARSET_SET (base_cs, SCM_CHAR (ch)); - - seed = scm_call_1 (g, seed); - tmp = scm_call_1 (p, seed); - } - return base_cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0, - (SCM proc, SCM cs), - "Apply @var{proc} to every character in the character set\n" - "@var{cs}. The return value is not specified.") -#define FUNC_NAME s_scm_char_set_for_each -{ - int k; - - SCM_VALIDATE_PROC (1, proc); - SCM_VALIDATE_SMOB (2, cs, charset); - - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - scm_call_1 (proc, SCM_MAKE_CHAR (k)); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0, - (SCM proc, SCM cs), - "Map the procedure @var{proc} over every character in @var{cs}.\n" - "@var{proc} must be a character -> character procedure.") -#define FUNC_NAME s_scm_char_set_map -{ - SCM result; - int k; - - SCM_VALIDATE_PROC (1, proc); - SCM_VALIDATE_SMOB (2, cs, charset); - - result = make_char_set (FUNC_NAME); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - { - SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (k)); - if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); - SCM_CHARSET_SET (result, SCM_CHAR (ch)); - } - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0, - (SCM cs), - "Return a newly allocated character set containing all\n" - "characters in @var{cs}.") -#define FUNC_NAME s_scm_char_set_copy -{ - SCM ret; - long * p1, * p2; - int k; - - SCM_VALIDATE_SMOB (1, cs, charset); - ret = make_char_set (FUNC_NAME); - p1 = (long *) SCM_SMOB_DATA (cs); - p2 = (long *) SCM_SMOB_DATA (ret); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p2[k] = p1[k]; - return ret; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1, - (SCM rest), - "Return a character set containing all given characters.") -#define FUNC_NAME s_scm_char_set -{ - SCM cs; - long * p; - int argnum = 1; - - SCM_VALIDATE_REST_ARGUMENT (rest); - cs = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (cs); - while (!SCM_NULLP (rest)) - { - int c; - - SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c); - argnum++; - rest = SCM_CDR (rest); - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); - } - return cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0, - (SCM list, SCM base_cs), - "Convert the character list @var{list} to a character set. If\n" - "the character set @var{base_cs} is given, the character in this\n" - "set are also included in the result.") -#define FUNC_NAME s_scm_list_to_char_set -{ - SCM cs; - long * p; - - SCM_VALIDATE_LIST (1, list); - if (SCM_UNBNDP (base_cs)) - cs = make_char_set (FUNC_NAME); - else - { - SCM_VALIDATE_SMOB (2, base_cs, charset); - cs = scm_char_set_copy (base_cs); - } - p = (long *) SCM_SMOB_DATA (cs); - while (!SCM_NULLP (list)) - { - SCM chr = SCM_CAR (list); - int c; - - SCM_VALIDATE_CHAR_COPY (0, chr, c); - list = SCM_CDR (list); - - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); - } - return cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0, - (SCM list, SCM base_cs), - "Convert the character list @var{list} to a character set. The\n" - "characters are added to @var{base_cs} and @var{base_cs} is\n" - "returned.") -#define FUNC_NAME s_scm_list_to_char_set_x -{ - long * p; - - SCM_VALIDATE_LIST (1, list); - SCM_VALIDATE_SMOB (2, base_cs, charset); - p = (long *) SCM_SMOB_DATA (base_cs); - while (!SCM_NULLP (list)) - { - SCM chr = SCM_CAR (list); - int c; - - SCM_VALIDATE_CHAR_COPY (0, chr, c); - list = SCM_CDR (list); - - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); - } - return base_cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, - (SCM str, SCM base_cs), - "Convert the string @var{str} to a character set. If the\n" - "character set @var{base_cs} is given, the characters in this\n" - "set are also included in the result.") -#define FUNC_NAME s_scm_string_to_char_set -{ - SCM cs; - long * p; - const char * s; - size_t k = 0, len; - - SCM_VALIDATE_STRING (1, str); - if (SCM_UNBNDP (base_cs)) - cs = make_char_set (FUNC_NAME); - else - { - SCM_VALIDATE_SMOB (2, base_cs, charset); - cs = scm_char_set_copy (base_cs); - } - p = (long *) SCM_SMOB_DATA (cs); - s = scm_i_string_chars (str); - len = scm_i_string_length (str); - while (k < len) - { - int c = s[k++]; - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); - } - scm_remember_upto_here_1 (str); - return cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0, - (SCM str, SCM base_cs), - "Convert the string @var{str} to a character set. The\n" - "characters from the string are added to @var{base_cs}, and\n" - "@var{base_cs} is returned.") -#define FUNC_NAME s_scm_string_to_char_set_x -{ - long * p; - const char * s; - size_t k = 0, len; - - SCM_VALIDATE_STRING (1, str); - SCM_VALIDATE_SMOB (2, base_cs, charset); - p = (long *) SCM_SMOB_DATA (base_cs); - s = scm_i_string_chars (str); - len = scm_i_string_length (str); - while (k < len) - { - int c = s[k++]; - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); - } - scm_remember_upto_here_1 (str); - return base_cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0, - (SCM pred, SCM cs, SCM base_cs), - "Return a character set containing every character from @var{cs}\n" - "so that it satisfies @var{pred}. If provided, the characters\n" - "from @var{base_cs} are added to the result.") -#define FUNC_NAME s_scm_char_set_filter -{ - SCM ret; - int k; - long * p; - - SCM_VALIDATE_PROC (1, pred); - SCM_VALIDATE_SMOB (2, cs, charset); - if (!SCM_UNBNDP (base_cs)) - { - SCM_VALIDATE_SMOB (3, base_cs, charset); - ret = scm_char_set_copy (base_cs); - } - else - ret = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (ret); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - { - if (SCM_CHARSET_GET (cs, k)) - { - SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - - if (scm_is_true (res)) - p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG); - } - } - return ret; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0, - (SCM pred, SCM cs, SCM base_cs), - "Return a character set containing every character from @var{cs}\n" - "so that it satisfies @var{pred}. The characters are added to\n" - "@var{base_cs} and @var{base_cs} is returned.") -#define FUNC_NAME s_scm_char_set_filter_x -{ - int k; - long * p; - - SCM_VALIDATE_PROC (1, pred); - SCM_VALIDATE_SMOB (2, cs, charset); - SCM_VALIDATE_SMOB (3, base_cs, charset); - p = (long *) SCM_SMOB_DATA (base_cs); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - { - if (SCM_CHARSET_GET (cs, k)) - { - SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - - if (scm_is_true (res)) - p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG); - } - } - return base_cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, - (SCM lower, SCM upper, SCM error, SCM base_cs), - "Return a character set containing all characters whose\n" - "character codes lie in the half-open range\n" - "[@var{lower},@var{upper}).\n" - "\n" - "If @var{error} is a true value, an error is signalled if the\n" - "specified range contains characters which are not contained in\n" - "the implemented character range. If @var{error} is @code{#f},\n" - "these characters are silently left out of the resultung\n" - "character set.\n" - "\n" - "The characters in @var{base_cs} are added to the result, if\n" - "given.") -#define FUNC_NAME s_scm_ucs_range_to_char_set -{ - SCM cs; - size_t clower, cupper; - long * p; - - clower = scm_to_size_t (lower); - cupper = scm_to_size_t (upper); - SCM_ASSERT_RANGE (2, upper, cupper >= clower); - if (!SCM_UNBNDP (error)) - { - if (scm_is_true (error)) - { - SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); - SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE); - } - } - if (clower > SCM_CHARSET_SIZE) - clower = SCM_CHARSET_SIZE; - if (cupper > SCM_CHARSET_SIZE) - cupper = SCM_CHARSET_SIZE; - if (SCM_UNBNDP (base_cs)) - cs = make_char_set (FUNC_NAME); - else - { - SCM_VALIDATE_SMOB (2, base_cs, charset); - cs = scm_char_set_copy (base_cs); - } - p = (long *) SCM_SMOB_DATA (cs); - while (clower < cupper) - { - p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG); - clower++; - } - return cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0, - (SCM lower, SCM upper, SCM error, SCM base_cs), - "Return a character set containing all characters whose\n" - "character codes lie in the half-open range\n" - "[@var{lower},@var{upper}).\n" - "\n" - "If @var{error} is a true value, an error is signalled if the\n" - "specified range contains characters which are not contained in\n" - "the implemented character range. If @var{error} is @code{#f},\n" - "these characters are silently left out of the resultung\n" - "character set.\n" - "\n" - "The characters are added to @var{base_cs} and @var{base_cs} is\n" - "returned.") -#define FUNC_NAME s_scm_ucs_range_to_char_set_x -{ - size_t clower, cupper; - long * p; - - clower = scm_to_size_t (lower); - cupper = scm_to_size_t (upper); - SCM_ASSERT_RANGE (2, upper, cupper >= clower); - if (scm_is_true (error)) - { - SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); - SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE); - } - if (clower > SCM_CHARSET_SIZE) - clower = SCM_CHARSET_SIZE; - if (cupper > SCM_CHARSET_SIZE) - cupper = SCM_CHARSET_SIZE; - p = (long *) SCM_SMOB_DATA (base_cs); - while (clower < cupper) - { - p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG); - clower++; - } - return base_cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0, - (SCM cs), - "Return the number of elements in character set @var{cs}.") -#define FUNC_NAME s_scm_char_set_size -{ - int k, count = 0; - - SCM_VALIDATE_SMOB (1, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - count++; - return SCM_I_MAKINUM (count); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0, - (SCM pred, SCM cs), - "Return the number of the elements int the character set\n" - "@var{cs} which satisfy the predicate @var{pred}.") -#define FUNC_NAME s_scm_char_set_count -{ - int k, count = 0; - - SCM_VALIDATE_PROC (1, pred); - SCM_VALIDATE_SMOB (2, cs, charset); - - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - { - SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - if (scm_is_true (res)) - count++; - } - return SCM_I_MAKINUM (count); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0, - (SCM cs), - "Return a list containing the elements of the character set\n" - "@var{cs}.") -#define FUNC_NAME s_scm_char_set_to_list -{ - int k; - SCM result = SCM_EOL; - - SCM_VALIDATE_SMOB (1, cs, charset); - for (k = SCM_CHARSET_SIZE; k > 0; k--) - if (SCM_CHARSET_GET (cs, k - 1)) - result = scm_cons (SCM_MAKE_CHAR (k - 1), result); - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0, - (SCM cs), - "Return a string containing the elements of the character set\n" - "@var{cs}. The order in which the characters are placed in the\n" - "string is not defined.") -#define FUNC_NAME s_scm_char_set_to_string -{ - int k; - int count = 0; - int idx = 0; - SCM result; - char * p; - - SCM_VALIDATE_SMOB (1, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - count++; - result = scm_i_make_string (count, &p); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - p[idx++] = k; - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_contains_p, "char-set-contains?", 2, 0, 0, - (SCM cs, SCM ch), - "Return @code{#t} iff the character @var{ch} is contained in the\n" - "character set @var{cs}.") -#define FUNC_NAME s_scm_char_set_contains_p -{ - SCM_VALIDATE_SMOB (1, cs, charset); - SCM_VALIDATE_CHAR (2, ch); - return scm_from_bool (SCM_CHARSET_GET (cs, SCM_CHAR (ch))); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0, - (SCM pred, SCM cs), - "Return a true value if every character in the character set\n" - "@var{cs} satisfies the predicate @var{pred}.") -#define FUNC_NAME s_scm_char_set_every -{ - int k; - SCM res = SCM_BOOL_T; - - SCM_VALIDATE_PROC (1, pred); - SCM_VALIDATE_SMOB (2, cs, charset); - - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - { - res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - if (scm_is_false (res)) - return res; - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0, - (SCM pred, SCM cs), - "Return a true value if any character in the character set\n" - "@var{cs} satisfies the predicate @var{pred}.") -#define FUNC_NAME s_scm_char_set_any -{ - int k; - - SCM_VALIDATE_PROC (1, pred); - SCM_VALIDATE_SMOB (2, cs, charset); - - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - { - SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - if (scm_is_true (res)) - return res; - } - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1, - (SCM cs, SCM rest), - "Add all character arguments to the first argument, which must\n" - "be a character set.") -#define FUNC_NAME s_scm_char_set_adjoin -{ - long * p; - - SCM_VALIDATE_SMOB (1, cs, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - cs = scm_char_set_copy (cs); - - p = (long *) SCM_SMOB_DATA (cs); - while (!SCM_NULLP (rest)) - { - SCM chr = SCM_CAR (rest); - int c; - - SCM_VALIDATE_CHAR_COPY (1, chr, c); - rest = SCM_CDR (rest); - - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); - } - return cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1, - (SCM cs, SCM rest), - "Delete all character arguments from the first argument, which\n" - "must be a character set.") -#define FUNC_NAME s_scm_char_set_delete -{ - long * p; - - SCM_VALIDATE_SMOB (1, cs, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - cs = scm_char_set_copy (cs); - - p = (long *) SCM_SMOB_DATA (cs); - while (!SCM_NULLP (rest)) - { - SCM chr = SCM_CAR (rest); - int c; - - SCM_VALIDATE_CHAR_COPY (1, chr, c); - rest = SCM_CDR (rest); - - p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG)); - } - return cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1, - (SCM cs, SCM rest), - "Add all character arguments to the first argument, which must\n" - "be a character set.") -#define FUNC_NAME s_scm_char_set_adjoin_x -{ - long * p; - - SCM_VALIDATE_SMOB (1, cs, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - p = (long *) SCM_SMOB_DATA (cs); - while (!SCM_NULLP (rest)) - { - SCM chr = SCM_CAR (rest); - int c; - - SCM_VALIDATE_CHAR_COPY (1, chr, c); - rest = SCM_CDR (rest); - - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); - } - return cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1, - (SCM cs, SCM rest), - "Delete all character arguments from the first argument, which\n" - "must be a character set.") -#define FUNC_NAME s_scm_char_set_delete_x -{ - long * p; - - SCM_VALIDATE_SMOB (1, cs, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - p = (long *) SCM_SMOB_DATA (cs); - while (!SCM_NULLP (rest)) - { - SCM chr = SCM_CAR (rest); - int c; - - SCM_VALIDATE_CHAR_COPY (1, chr, c); - rest = SCM_CDR (rest); - - p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG)); - } - return cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0, - (SCM cs), - "Return the complement of the character set @var{cs}.") -#define FUNC_NAME s_scm_char_set_complement -{ - int k; - SCM res; - long * p, * q; - - SCM_VALIDATE_SMOB (1, cs, charset); - - res = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (res); - q = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] = ~q[k]; - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1, - (SCM rest), - "Return the union of all argument character sets.") -#define FUNC_NAME s_scm_char_set_union -{ - int c = 1; - SCM res; - long * p; - - SCM_VALIDATE_REST_ARGUMENT (rest); - - res = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (res); - while (!SCM_NULLP (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1, - (SCM rest), - "Return the intersection of all argument character sets.") -#define FUNC_NAME s_scm_char_set_intersection -{ - SCM res; - - SCM_VALIDATE_REST_ARGUMENT (rest); - - if (SCM_NULLP (rest)) - res = make_char_set (FUNC_NAME); - else - { - long *p; - int argnum = 2; - - res = scm_char_set_copy (SCM_CAR (rest)); - p = (long *) SCM_SMOB_DATA (res); - rest = SCM_CDR (rest); - - while (SCM_CONSP (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - long *cs_data; - - SCM_VALIDATE_SMOB (argnum, cs, charset); - argnum++; - cs_data = (long *) SCM_SMOB_DATA (cs); - rest = SCM_CDR (rest); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= cs_data[k]; - } - } - - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1, - (SCM cs1, SCM rest), - "Return the difference of all argument character sets.") -#define FUNC_NAME s_scm_char_set_difference -{ - int c = 2; - SCM res; - long * p; - - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - res = scm_char_set_copy (cs1); - p = (long *) SCM_SMOB_DATA (res); - while (!SCM_NULLP (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1, - (SCM rest), - "Return the exclusive-or of all argument character sets.") -#define FUNC_NAME s_scm_char_set_xor -{ - SCM res; - - SCM_VALIDATE_REST_ARGUMENT (rest); - - if (SCM_NULLP (rest)) - res = make_char_set (FUNC_NAME); - else - { - int argnum = 2; - long * p; - - res = scm_char_set_copy (SCM_CAR (rest)); - p = (long *) SCM_SMOB_DATA (res); - rest = SCM_CDR (rest); - - while (SCM_CONSP (rest)) - { - SCM cs = SCM_CAR (rest); - long *cs_data; - int k; - - SCM_VALIDATE_SMOB (argnum, cs, charset); - argnum++; - cs_data = (long *) SCM_SMOB_DATA (cs); - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] ^= cs_data[k]; - } - } - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1, 0, 1, - (SCM cs1, SCM rest), - "Return the difference and the intersection of all argument\n" - "character sets.") -#define FUNC_NAME s_scm_char_set_diff_plus_intersection -{ - int c = 2; - SCM res1, res2; - long * p, * q; - - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - res1 = scm_char_set_copy (cs1); - res2 = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (res1); - q = (long *) SCM_SMOB_DATA (res2); - while (!SCM_NULLP (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - long *r; - - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - r = (long *) SCM_SMOB_DATA (cs); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - q[k] |= p[k] & r[k]; - p[k] &= ~r[k]; - } - rest = SCM_CDR (rest); - } - return scm_values (scm_list_2 (res1, res2)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0, - (SCM cs), - "Return the complement of the character set @var{cs}.") -#define FUNC_NAME s_scm_char_set_complement_x -{ - int k; - long * p; - - SCM_VALIDATE_SMOB (1, cs, charset); - p = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] = ~p[k]; - return cs; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1, - (SCM cs1, SCM rest), - "Return the union of all argument character sets.") -#define FUNC_NAME s_scm_char_set_union_x -{ - int c = 2; - long * p; - - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - p = (long *) SCM_SMOB_DATA (cs1); - while (!SCM_NULLP (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; - } - return cs1; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1, - (SCM cs1, SCM rest), - "Return the intersection of all argument character sets.") -#define FUNC_NAME s_scm_char_set_intersection_x -{ - int c = 2; - long * p; - - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - p = (long *) SCM_SMOB_DATA (cs1); - while (!SCM_NULLP (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; - } - return cs1; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1, - (SCM cs1, SCM rest), - "Return the difference of all argument character sets.") -#define FUNC_NAME s_scm_char_set_difference_x -{ - int c = 2; - long * p; - - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - p = (long *) SCM_SMOB_DATA (cs1); - while (!SCM_NULLP (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; - } - return cs1; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, - (SCM cs1, SCM rest), - "Return the exclusive-or of all argument character sets.") -#define FUNC_NAME s_scm_char_set_xor_x -{ - /* a side-effecting variant should presumably give consistent results: - (define a (char-set #\a)) - (char-set-xor a a a) -> char set #\a - (char-set-xor! a a a) -> char set #\a - */ - return scm_char_set_xor (scm_cons (cs1, rest)); - -#if 0 - /* this would give (char-set-xor! a a a) -> empty char set. */ - int c = 2; - long * p; - - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - p = (long *) SCM_SMOB_DATA (cs1); - while (!SCM_NULLP (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k]; - } - return cs1; -#endif -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 2, 0, 1, - (SCM cs1, SCM cs2, SCM rest), - "Return the difference and the intersection of all argument\n" - "character sets.") -#define FUNC_NAME s_scm_char_set_diff_plus_intersection_x -{ - int c = 3; - long * p, * q; - int k; - - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_SMOB (2, cs2, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - p = (long *) SCM_SMOB_DATA (cs1); - q = (long *) SCM_SMOB_DATA (cs2); - if (p == q) - { - /* (char-set-diff+intersection! a a ...): can't share storage, - but we know the answer without checking for further - arguments. */ - return scm_values (scm_list_2 (make_char_set (FUNC_NAME), cs1)); - } - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - long t = p[k]; - - p[k] &= ~q[k]; - q[k] = t & q[k]; - } - while (!SCM_NULLP (rest)) - { - SCM cs = SCM_CAR (rest); - long *r; - - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - r = (long *) SCM_SMOB_DATA (cs); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - q[k] |= p[k] & r[k]; - p[k] &= ~r[k]; - } - rest = SCM_CDR (rest); - } - return scm_values (scm_list_2 (cs1, cs2)); -} -#undef FUNC_NAME - - -/* Create the charset smob type. */ -void -scm_c_init_srfi_14 (void) -{ - /* Charset smob creation is protected by this variable because this - function can be both called from the SRFI-13 and SRFI-14 - initialization functions. This is because the SRFI-13 procedures - access the charset smob type code. */ - static int initialized = 0; - - if (!initialized) - { - scm_tc16_charset = scm_make_smob_type ("character-set", - BYTES_PER_CHARSET); - scm_set_smob_free (scm_tc16_charset, charset_free); - scm_set_smob_print (scm_tc16_charset, charset_print); - initialized = 1; - } -} - - -/* Initialize the SRFI-14 module. This function will be called by the - loading Scheme module. */ void scm_init_srfi_14 (void) { -#if 0 - fprintf(stderr, "bytes-per-charset: %d\n", BYTES_PER_CHARSET); - fprintf(stderr, "bits-per-long: %d\n", SCM_BITS_PER_LONG); - fprintf(stderr, "longs-per-charset: %d\n", LONGS_PER_CHARSET); - fflush (stderr); -#endif /* 0 */ - - /* Do the smob type initialization. */ - scm_c_init_srfi_14 (); - - /* Install the charset primitives. */ -#include "srfi/srfi-14.x" } -/* End of srfi-14.c. */ +void +scm_c_init_srfi_14 (void) +{ +} diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h index 4ce0a1fd9..544e1580b 100644 --- a/srfi/srfi-14.h +++ b/srfi/srfi-14.h @@ -2,7 +2,7 @@ #define SCM_SRFI_14_H /* srfi-14.c --- SRFI-14 procedures for Guile * - * Copyright (C) 2001 Free Software Foundation, Inc. + * Copyright (C) 2001, 2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -32,71 +32,7 @@ # define SCM_SRFI1314_API extern #endif -#define SCM_CHARSET_SIZE 256 - -/* We expect 8-bit bytes here. Should be no problem in the year - 2001. */ -#ifndef SCM_BITS_PER_LONG -# define SCM_BITS_PER_LONG (sizeof (long) * 8) -#endif - -#define SCM_CHARSET_GET(cs, idx) (((long *) SCM_SMOB_DATA (cs))\ - [((unsigned char) (idx)) / SCM_BITS_PER_LONG] &\ - (1L << (((unsigned char) (idx)) % SCM_BITS_PER_LONG))) - -#define SCM_CHARSETP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_charset)) - -/* Smob type code for character sets. */ -SCM_SRFI1314_API int scm_tc16_charset; - SCM_SRFI1314_API void scm_c_init_srfi_14 (void); SCM_SRFI1314_API void scm_init_srfi_14 (void); -SCM_SRFI1314_API SCM scm_char_set_p (SCM obj); -SCM_SRFI1314_API SCM scm_char_set_eq (SCM char_sets); -SCM_SRFI1314_API SCM scm_char_set_leq (SCM char_sets); -SCM_SRFI1314_API SCM scm_char_set_hash (SCM cs, SCM bound); -SCM_SRFI1314_API SCM scm_char_set_cursor (SCM cs); -SCM_SRFI1314_API SCM scm_char_set_ref (SCM cs, SCM cursor); -SCM_SRFI1314_API SCM scm_char_set_cursor_next (SCM cs, SCM cursor); -SCM_SRFI1314_API SCM scm_end_of_char_set_p (SCM cursor); -SCM_SRFI1314_API SCM scm_char_set_fold (SCM kons, SCM knil, SCM cs); -SCM_SRFI1314_API SCM scm_char_set_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base_cs); -SCM_SRFI1314_API SCM scm_char_set_unfold_x (SCM p, SCM f, SCM g, SCM seed, SCM base_cs); -SCM_SRFI1314_API SCM scm_char_set_for_each (SCM proc, SCM cs); -SCM_SRFI1314_API SCM scm_char_set_map (SCM proc, SCM cs); -SCM_SRFI1314_API SCM scm_char_set_copy (SCM cs); -SCM_SRFI1314_API SCM scm_char_set (SCM rest); -SCM_SRFI1314_API SCM scm_list_to_char_set (SCM list, SCM base_cs); -SCM_SRFI1314_API SCM scm_list_to_char_set_x (SCM list, SCM base_cs); -SCM_SRFI1314_API SCM scm_string_to_char_set (SCM str, SCM base_cs); -SCM_SRFI1314_API SCM scm_string_to_char_set_x (SCM str, SCM base_cs); -SCM_SRFI1314_API SCM scm_char_set_filter (SCM pred, SCM cs, SCM base_cs); -SCM_SRFI1314_API SCM scm_char_set_filter_x (SCM pred, SCM cs, SCM base_cs); -SCM_SRFI1314_API SCM scm_ucs_range_to_char_set (SCM lower, SCM upper, SCM error, SCM base_cs); -SCM_SRFI1314_API SCM scm_ucs_range_to_char_set_x (SCM lower, SCM upper, SCM error, SCM base_cs); -SCM_SRFI1314_API SCM scm_char_set_size (SCM cs); -SCM_SRFI1314_API SCM scm_char_set_count (SCM pred, SCM cs); -SCM_SRFI1314_API SCM scm_char_set_to_list (SCM cs); -SCM_SRFI1314_API SCM scm_char_set_to_string (SCM cs); -SCM_SRFI1314_API SCM scm_char_set_contains_p (SCM cs, SCM ch); -SCM_SRFI1314_API SCM scm_char_set_every (SCM pred, SCM cs); -SCM_SRFI1314_API SCM scm_char_set_any (SCM pred, SCM cs); -SCM_SRFI1314_API SCM scm_char_set_adjoin (SCM cs, SCM rest); -SCM_SRFI1314_API SCM scm_char_set_delete (SCM cs, SCM rest); -SCM_SRFI1314_API SCM scm_char_set_adjoin_x (SCM cs, SCM rest); -SCM_SRFI1314_API SCM scm_char_set_delete_x (SCM cs, SCM rest); -SCM_SRFI1314_API SCM scm_char_set_complement (SCM cs); -SCM_SRFI1314_API SCM scm_char_set_union (SCM rest); -SCM_SRFI1314_API SCM scm_char_set_intersection (SCM rest); -SCM_SRFI1314_API SCM scm_char_set_difference (SCM cs1, SCM rest); -SCM_SRFI1314_API SCM scm_char_set_xor (SCM rest); -SCM_SRFI1314_API SCM scm_char_set_diff_plus_intersection (SCM cs1, SCM rest); -SCM_SRFI1314_API SCM scm_char_set_complement_x (SCM cs); -SCM_SRFI1314_API SCM scm_char_set_union_x (SCM cs1, SCM rest); -SCM_SRFI1314_API SCM scm_char_set_intersection_x (SCM cs1, SCM rest); -SCM_SRFI1314_API SCM scm_char_set_difference_x (SCM cs1, SCM rest); -SCM_SRFI1314_API SCM scm_char_set_xor_x (SCM cs1, SCM rest); -SCM_SRFI1314_API SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM cs2, SCM rest); - #endif /* SCM_SRFI_14_H */ diff --git a/srfi/srfi-14.scm b/srfi/srfi-14.scm index 9f4772df5..d8cbe628f 100644 --- a/srfi/srfi-14.scm +++ b/srfi/srfi-14.scm @@ -1,6 +1,6 @@ ;;; srfi-14.scm --- Character-set Library -;; Copyright (C) 2001, 2002 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2004 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -22,8 +22,9 @@ ;;; Code: -(define-module (srfi srfi-14) - :export ( +(define-module (srfi srfi-14)) + +(re-export ;;; General procedures char-set? char-set= @@ -91,60 +92,8 @@ char-set:blank char-set:ascii char-set:empty - char-set:full - )) + char-set:full) (cond-expand-provide (current-module) '(srfi-14)) -(load-extension "libguile-srfi-srfi-13-14" "scm_init_srfi_14") - -(define (->char-set x) - (cond - ((string? x) (string->char-set x)) - ((char? x) (char-set x)) - ((char-set? x) x) - (else (error "invalid argument to `->char-set'")))) - -(define char-set:full (ucs-range->char-set 0 256)) - -(define char-set:lower-case (char-set-filter char-lower-case? char-set:full)) - -(define char-set:upper-case (char-set-filter char-upper-case? char-set:full)) - -(define char-set:title-case (char-set)) - -(define char-set:letter (char-set-union char-set:lower-case - char-set:upper-case)) - -(define char-set:digit (string->char-set "0123456789")) - -(define char-set:letter+digit - (char-set-union char-set:letter char-set:digit)) - -(define char-set:punctuation (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")) - -(define char-set:symbol (string->char-set "$+<=>^`|~")) - -(define char-set:whitespace (char-set #\space #\newline #\tab #\cr #\vt #\np)) - -(define char-set:blank (char-set #\space #\tab)) - -(define char-set:graphic - (char-set-union char-set:letter+digit char-set:punctuation char-set:symbol)) - -(define char-set:printing - (char-set-union char-set:graphic char-set:whitespace)) - -(define char-set:iso-control - (char-set-adjoin - (char-set-filter (lambda (ch) (< (char->integer ch) 31)) char-set:full) - (integer->char 127))) - -(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF")) - -(define char-set:ascii - (char-set-filter (lambda (ch) (< (char->integer ch) 128)) char-set:full)) - -(define char-set:empty (char-set)) - ;;; srfi-14.scm ends here From 4a276c08e33bcd88e0910e2bdd02abd0da757d53 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 22:20:47 +0000 Subject: [PATCH 065/100] (%cond-expand-features): Addef srfi-13 and srfi-14. --- ice-9/boot-9.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 4df582807..e854f6db7 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -3183,7 +3183,7 @@ ;;; ;;; Currently, the following feature identifiers are supported: ;;; -;;; guile r5rs srfi-0 srfi-6 +;;; guile r5rs srfi-0 srfi-6 srfi-13 srfi-14 ;;; ;;; Remember to update the features list when adding more SRFIs. ;;; @@ -3194,6 +3194,8 @@ r5rs srfi-0 ;; cond-expand itself srfi-6 ;; open-input-string etc, in the guile core + srfi-13 ;; string library + srfi-14 ;; character sets )) ;; This table maps module public interfaces to the list of features. From c5080b51894afc75c06242780ded2e134760a5ac Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 22:25:02 +0000 Subject: [PATCH 066/100] *** empty log message *** --- NEWS | 5 +++++ ice-9/ChangeLog | 4 ++++ libguile/ChangeLog | 29 +++++++++++++++++++++++++++++ srfi/ChangeLog | 10 ++++++++++ test-suite/ChangeLog | 5 +++++ 5 files changed, 53 insertions(+) diff --git a/NEWS b/NEWS index f846beb84..81f08a67c 100644 --- a/NEWS +++ b/NEWS @@ -123,6 +123,11 @@ This is an implementation of SRFI-26. This is an implementation of SRFI-31 which provides a special form `rec' for recursive evaluation. +** The modules (srfi srfi-13) and (srfi srfi-14) have been merged with + the core, making their functionality always available. + +The are still available, tho. + ** Guile now includes its own version of libltdl. We now use a modified version of libltdl that allows us to make diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 3c382df90..615c88e84 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2004-08-25 Marius Vollmer + + * boot-9.scm (%cond-expand-features): Addef srfi-13 and srfi-14. + 2004-08-20 Marius Vollmer * debugger/utils.scm (display-source): Use unmemoize-expr instead diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 26346676d..1fd9ceb66 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,32 @@ +2004-08-25 Marius Vollmer + + Moved SRFI-13 and SRFI-14 into the core, taking over the role of + strop.c. + + * srfi-13.c, srfi-13.h, srfi-14.c, srfi-14.h: New files. + * strop.h, strop.c: Removed, they are now empty. + * Makefile.am: Updated for new and removed files. + + * symbols.h, symbols.c (scm_string_ci_to_symbol): Moved here, next + to scm_string_to_symbol. + + * chars.c (scm_char_alphabetic_p, scm_char_numeric_p, + scm_char_whitespace_p, scm_upper_case_p, scm_lower_case_p, + scm_char_is_both_p): Use scm_char_set_contains_p with the proper + charset instead of libc functions. + + * strorder.c (scm_string_equal_p, scm_string_ci_equal_p, + scm_string_less_p, scm_string_leq_p, scm_string_gr_p, + scm_string_geq_p, scm_string_ci_less_p, scm_string_ci_leq_p, + scm_string_ci_gr_p, scm_string_ci_geq_p): Use scm_string_eq, etc + instead of explicit code. + + * deprecated.c, load.c, posix.c, unif.c, symbols.c: Include + "srfi-13.h" instead of "strop.h". + + * init.c (scm_init_guile_1): Call scm_init_srfi_13 and + scm_init_srfi_14. Do not call scm_init_strop. + 2004-08-24 Marius Vollmer * numbers.c (scm_inf_p): Synced docstring back from manual. diff --git a/srfi/ChangeLog b/srfi/ChangeLog index b91814d77..a35dfdfd7 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,13 @@ +2004-08-25 Marius Vollmer + + SRFI-13 and SRFI-14 have been moved into the core. + + * srfi-13.scm, srfi-14.scm: Simply re-export the relevant + bindings. + + * srfi-13.h, srfi-13.c, srfi-14.h, srfi-14.c: Removed all real + content except for the init functions. + 2004-08-19 Marius Vollmer * srfi-13.h, srfi-13.c: (scm_substring_shared): Renamed to diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 3e19c2cca..e7ed55585 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-08-25 Marius Vollmer + + * tests/strings.test: Two more tests for double indirect substring + modification. + 2004-08-23 Marius Vollmer * lib.scm (exception:used-before-define): New. From 5499bd7f55e491d6cec1ac369f2f4a4f245f2a83 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 23:32:10 +0000 Subject: [PATCH 067/100] Removed scm_inf_p. --- doc/ref/new-docstrings.texi | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/doc/ref/new-docstrings.texi b/doc/ref/new-docstrings.texi index 91e9e9651..f97d181ee 100644 --- a/doc/ref/new-docstrings.texi +++ b/doc/ref/new-docstrings.texi @@ -1,8 +1,5 @@ @c module-for-docstring (guile) -@deffn {Scheme Procedure} inf? n -@deffnx {C Function} scm_inf_p (n) -Return @code{#t} if @var{n} is infinite, @code{#f} -otherwise. -@end deffn + + From 8fc71812fc121bd4a577ee58c897b45fef03489f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 23:32:28 +0000 Subject: [PATCH 068/100] More deprecated entries. --- doc/ref/api-undocumented.texi | 149 +++++++++++++++++++++++++++++++++- 1 file changed, 147 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-undocumented.texi b/doc/ref/api-undocumented.texi index c9f99d148..d7507faa5 100644 --- a/doc/ref/api-undocumented.texi +++ b/doc/ref/api-undocumented.texi @@ -1,13 +1,158 @@ This file gathers entries that have been automatically generated from docstrings in libguile. They are not included in the manual, however, -for various reasons. They are here in this file to give docstring.el a -chance to update them automatically. +for various reasons, mostly because they have been deprecated. They +are here in this file to give docstring.el a chance to update them +automatically. - The 'environments' are only in Guile by accident and are not used at all and we don't want to advertise them. - GOOPS is documented in its own manual. + + +@deffn {Scheme Procedure} substring-move-right! +implemented by the C function "scm_substring_move_x" +@end deffn + +@deffn {Scheme Procedure} substring-move-left! +implemented by the C function "scm_substring_move_x" +@end deffn + +@deffn {Scheme Procedure} gentemp [prefix [obarray]] +@deffnx {C Function} scm_gentemp (prefix, obarray) +Create a new symbol with a name unique in an obarray. +The name is constructed from an optional string @var{prefix} +and a counter value. The default prefix is @code{t}. The +@var{obarray} is specified as a second optional argument. +Default is the system obarray where all normal symbols are +interned. The counter is increased by 1 at each +call. There is no provision for resetting the counter. +@end deffn + +@deffn {Scheme Procedure} symbol-set! o s v +@deffnx {C Function} scm_symbol_set_x (o, s, v) +Find the symbol in @var{obarray} whose name is @var{string}, and rebind +it to @var{value}. An error is signalled if @var{string} is not present +in @var{obarray}. +@end deffn + +@deffn {Scheme Procedure} symbol-bound? o s +@deffnx {C Function} scm_symbol_bound_p (o, s) +Return @code{#t} if @var{obarray} contains a symbol with name +@var{string} bound to a defined value. This differs from +@var{symbol-interned?} in that the mere mention of a symbol +usually causes it to be interned; @code{symbol-bound?} +determines whether a symbol has been given any meaningful +value. +@end deffn + +@deffn {Scheme Procedure} symbol-binding o s +@deffnx {C Function} scm_symbol_binding (o, s) +Look up in @var{obarray} the symbol whose name is @var{string}, and +return the value to which it is bound. If @var{obarray} is @code{#f}, +use the global symbol table. If @var{string} is not interned in +@var{obarray}, an error is signalled. +@end deffn + +@deffn {Scheme Procedure} unintern-symbol o s +@deffnx {C Function} scm_unintern_symbol (o, s) +Remove the symbol with name @var{string} from @var{obarray}. This +function returns @code{#t} if the symbol was present and @code{#f} +otherwise. +@end deffn + +@deffn {Scheme Procedure} intern-symbol o s +@deffnx {C Function} scm_intern_symbol (o, s) +Add a new symbol to @var{obarray} with name @var{string}, bound to an +unspecified initial value. The symbol table is not modified if a symbol +with this name is already present. +@end deffn + +@deffn {Scheme Procedure} string->obarray-symbol o s [softp] +@deffnx {C Function} scm_string_to_obarray_symbol (o, s, softp) +Intern a new symbol in @var{obarray}, a symbol table, with name +@var{string}. + +If @var{obarray} is @code{#f}, use the default system symbol table. If +@var{obarray} is @code{#t}, the symbol should not be interned in any +symbol table; merely return the pair (@var{symbol} +. @var{#}). + +The @var{soft?} argument determines whether new symbol table entries +should be created when the specified symbol is not already present in +@var{obarray}. If @var{soft?} is specified and is a true value, then +new entries should not be added for symbols not already present in the +table; instead, simply return @code{#f}. +@end deffn + +@deffn {Scheme Procedure} read-and-eval! [port] +@deffnx {C Function} scm_read_and_eval_x (port) +Read a form from @var{port} (standard input by default), and evaluate it +(memoizing it in the process) in the top-level environment. If no data +is left to be read from @var{port}, an @code{end-of-file} error is +signalled. +@end deffn + +@deffn {Scheme Procedure} sloppy-member x lst +@deffnx {C Function} scm_sloppy_member (x, lst) +This procedure behaves like @code{member}, but does no type or error checking. +Its use is recommended only in writing Guile internals, +not for high-level Scheme programs. +@end deffn + +@deffn {Scheme Procedure} sloppy-memv x lst +@deffnx {C Function} scm_sloppy_memv (x, lst) +This procedure behaves like @code{memv}, but does no type or error checking. +Its use is recommended only in writing Guile internals, +not for high-level Scheme programs. +@end deffn + +@deffn {Scheme Procedure} sloppy-memq x lst +@deffnx {C Function} scm_sloppy_memq (x, lst) +This procedure behaves like @code{memq}, but does no type or error checking. +Its use is recommended only in writing Guile internals, +not for high-level Scheme programs. +@end deffn + +@deffn {Scheme Procedure} builtin-variable name +@deffnx {C Function} scm_builtin_variable (name) +Do not use this function. +@end deffn + +@deffn {Scheme Procedure} variable-set-name-hint! var hint +@deffnx {C Function} scm_variable_set_name_hint (var, hint) +Do not use this function. +@end deffn + +@deffn {Scheme Procedure} close-all-ports-except . ports +@deffnx {C Function} scm_close_all_ports_except (ports) +[DEPRECATED] Close all open file ports used by the interpreter +except for those supplied as arguments. This procedure +was intended to be used before an exec call to close file descriptors +which are not needed in the new process. However it has the +undesirable side effect of flushing buffers, so it's deprecated. +Use port-for-each instead. +@end deffn + +@deffn {Scheme Procedure} c-clear-registered-modules +@deffnx {C Function} scm_clear_registered_modules () +Destroy the list of modules registered with the current Guile process. +The return value is unspecified. @strong{Warning:} this function does +not actually unlink or deallocate these modules, but only destroys the +records of which modules have been loaded. It should therefore be used +only by module bookkeeping operations. +@end deffn + +@deffn {Scheme Procedure} c-registered-modules +@deffnx {C Function} scm_registered_modules () +Return a list of the object code modules that have been imported into +the current Guile process. Each element of the list is a pair whose +car is the name of the module, and whose cdr is the function handle +for that module's initializer function. The name is the string that +has been passed to scm_register_module_xxx. +@end deffn + @deffn {Scheme Procedure} module-import-interface module sym @deffnx {C Function} scm_module_import_interface (module, sym) From 050ab45f5664bcbb8d2cfc013f2ae30781d9f051 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 23:33:39 +0000 Subject: [PATCH 069/100] Moved docs for SRFI-14 into main API chapter. Updated docstrings from libguile/. --- doc/ref/api-data.texi | 487 +++++++++++++++++++++++++++++++++++++- doc/ref/srfi-modules.texi | 404 +------------------------------ 2 files changed, 485 insertions(+), 406 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 3cb6a0612..117abd23d 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -42,8 +42,9 @@ For the documentation of such @dfn{compound} data types, see @menu * Booleans:: True/false values. * Numbers:: Numerical data types. -* Characters:: New character names. -* Strings:: Special things about strings. +* Characters:: Single characters. +* Character Sets:: Sets of characters. +* Strings:: Sequences of characters. * Regular Expressions:: Pattern matching and substitution. * Symbols:: Symbols. * Keywords:: Self-quoting, customizable display keywords. @@ -1667,14 +1668,16 @@ The global random state used by the above functions when the @subsection Characters @tpindex Characters -@noindent -[@strong{FIXME}: how do you specify regular (non-control) characters?] +In Scheme, a character literal is written as @code{#\@var{name}} where +@var{name} is the name of the character that you want. Printable +characters have their usual single character name; for example, +@code{#\a} is a lower case @code{a}. Most of the ``control characters'' (those below codepoint 32) in the @acronym{ASCII} character set, as well as the space, may be referred -to by name: for example, @code{#\tab}, @code{#\esc}, @code{#\stx}, and -so on. The following table describes the @acronym{ASCII} names for -each character. +to by longer names: for example, @code{#\tab}, @code{#\esc}, +@code{#\stx}, and so on. The following table describes the +@acronym{ASCII} names for each character. @multitable @columnfractions .25 .25 .25 .25 @item 0 = @code{#\nul} @@ -1860,10 +1863,474 @@ Return the uppercase character version of @var{chr}. Return the lowercase character version of @var{chr}. @end deffn -@xref{Classification of Characters,,,libc,GNU C Library Reference -Manual}, for information about the @code{is*} Standard C functions -mentioned above. +@node Character Sets +@subsection Character Sets +The features described in this section correspond directly to SRFI-14. + +The data type @dfn{charset} implements sets of characters +(@pxref{Characters}). Because the internal representation of +character sets is not visible to the user, a lot of procedures for +handling them are provided. + +Character sets can be created, extended, tested for the membership of a +characters and be compared to other character sets. + +The Guile implementation of character sets currently deals only with +8-bit characters. In the future, when Guile gets support for +international character sets, this will change, but the functions +provided here will always then be able to efficiently cope with very +large character sets. + +@menu +* Character Set Predicates/Comparison:: +* Iterating Over Character Sets:: Enumerate charset elements. +* Creating Character Sets:: Making new charsets. +* Querying Character Sets:: Test charsets for membership etc. +* Character-Set Algebra:: Calculating new charsets. +* Standard Character Sets:: Variables containing predefined charsets. +@end menu + +@node Character Set Predicates/Comparison +@subsubsection Character Set Predicates/Comparison + +Use these procedures for testing whether an object is a character set, +or whether several character sets are equal or subsets of each other. +@code{char-set-hash} can be used for calculating a hash value, maybe for +usage in fast lookup procedures. + +@deffn {Scheme Procedure} char-set? obj +@deffnx {C Function} scm_char_set_p (obj) +Return @code{#t} if @var{obj} is a character set, @code{#f} +otherwise. +@end deffn + +@deffn {Scheme Procedure} char-set= . char_sets +@deffnx {C Function} scm_char_set_eq (char_sets) +Return @code{#t} if all given character sets are equal. +@end deffn + +@deffn {Scheme Procedure} char-set<= . char_sets +@deffnx {C Function} scm_char_set_leq (char_sets) +Return @code{#t} if every character set @var{cs}i is a subset +of character set @var{cs}i+1. +@end deffn + +@deffn {Scheme Procedure} char-set-hash cs [bound] +@deffnx {C Function} scm_char_set_hash (cs, bound) +Compute a hash value for the character set @var{cs}. If +@var{bound} is given and non-zero, it restricts the +returned value to the range 0 @dots{} @var{bound - 1}. +@end deffn + +@c =================================================================== + +@node Iterating Over Character Sets +@subsubsection Iterating Over Character Sets + +Character set cursors are a means for iterating over the members of a +character sets. After creating a character set cursor with +@code{char-set-cursor}, a cursor can be dereferenced with +@code{char-set-ref}, advanced to the next member with +@code{char-set-cursor-next}. Whether a cursor has passed past the last +element of the set can be checked with @code{end-of-char-set?}. + +Additionally, mapping and (un-)folding procedures for character sets are +provided. + +@deffn {Scheme Procedure} char-set-cursor cs +@deffnx {C Function} scm_char_set_cursor (cs) +Return a cursor into the character set @var{cs}. +@end deffn + +@deffn {Scheme Procedure} char-set-ref cs cursor +@deffnx {C Function} scm_char_set_ref (cs, cursor) +Return the character at the current cursor position +@var{cursor} in the character set @var{cs}. It is an error to +pass a cursor for which @code{end-of-char-set?} returns true. +@end deffn + +@deffn {Scheme Procedure} char-set-cursor-next cs cursor +@deffnx {C Function} scm_char_set_cursor_next (cs, cursor) +Advance the character set cursor @var{cursor} to the next +character in the character set @var{cs}. It is an error if the +cursor given satisfies @code{end-of-char-set?}. +@end deffn + +@deffn {Scheme Procedure} end-of-char-set? cursor +@deffnx {C Function} scm_end_of_char_set_p (cursor) +Return @code{#t} if @var{cursor} has reached the end of a +character set, @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} char-set-fold kons knil cs +@deffnx {C Function} scm_char_set_fold (kons, knil, cs) +Fold the procedure @var{kons} over the character set @var{cs}, +initializing it with @var{knil}. +@end deffn + +@deffn {Scheme Procedure} char-set-unfold p f g seed [base_cs] +@deffnx {C Function} scm_char_set_unfold (p, f, g, seed, base_cs) +This is a fundamental constructor for character sets. +@itemize @bullet +@item @var{g} is used to generate a series of ``seed'' values +from the initial seed: @var{seed}, (@var{g} @var{seed}), +(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{} +@item @var{p} tells us when to stop -- when it returns true +when applied to one of the seed values. +@item @var{f} maps each seed value to a character. These +characters are added to the base character set @var{base_cs} to +form the result; @var{base_cs} defaults to the empty set. +@end itemize +@end deffn + +@deffn {Scheme Procedure} char-set-unfold! p f g seed base_cs +@deffnx {C Function} scm_char_set_unfold_x (p, f, g, seed, base_cs) +This is a fundamental constructor for character sets. +@itemize @bullet +@item @var{g} is used to generate a series of ``seed'' values +from the initial seed: @var{seed}, (@var{g} @var{seed}), +(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{} +@item @var{p} tells us when to stop -- when it returns true +when applied to one of the seed values. +@item @var{f} maps each seed value to a character. These +characters are added to the base character set @var{base_cs} to +form the result; @var{base_cs} defaults to the empty set. +@end itemize +@end deffn + +@deffn {Scheme Procedure} char-set-for-each proc cs +@deffnx {C Function} scm_char_set_for_each (proc, cs) +Apply @var{proc} to every character in the character set +@var{cs}. The return value is not specified. +@end deffn + +@deffn {Scheme Procedure} char-set-map proc cs +@deffnx {C Function} scm_char_set_map (proc, cs) +Map the procedure @var{proc} over every character in @var{cs}. +@var{proc} must be a character -> character procedure. +@end deffn + +@c =================================================================== + +@node Creating Character Sets +@subsubsection Creating Character Sets + +New character sets are produced with these procedures. + +@deffn {Scheme Procedure} char-set-copy cs +@deffnx {C Function} scm_char_set_copy (cs) +Return a newly allocated character set containing all +characters in @var{cs}. +@end deffn + +@deffn {Scheme Procedure} char-set . rest +@deffnx {C Function} scm_char_set (rest) +Return a character set containing all given characters. +@end deffn + +@deffn {Scheme Procedure} list->char-set list [base_cs] +@deffnx {C Function} scm_list_to_char_set (list, base_cs) +Convert the character list @var{list} to a character set. If +the character set @var{base_cs} is given, the character in this +set are also included in the result. +@end deffn + +@deffn {Scheme Procedure} list->char-set! list base_cs +@deffnx {C Function} scm_list_to_char_set_x (list, base_cs) +Convert the character list @var{list} to a character set. The +characters are added to @var{base_cs} and @var{base_cs} is +returned. +@end deffn + +@deffn {Scheme Procedure} string->char-set str [base_cs] +@deffnx {C Function} scm_string_to_char_set (str, base_cs) +Convert the string @var{str} to a character set. If the +character set @var{base_cs} is given, the characters in this +set are also included in the result. +@end deffn + +@deffn {Scheme Procedure} string->char-set! str base_cs +@deffnx {C Function} scm_string_to_char_set_x (str, base_cs) +Convert the string @var{str} to a character set. The +characters from the string are added to @var{base_cs}, and +@var{base_cs} is returned. +@end deffn + +@deffn {Scheme Procedure} char-set-filter pred cs [base_cs] +@deffnx {C Function} scm_char_set_filter (pred, cs, base_cs) +Return a character set containing every character from @var{cs} +so that it satisfies @var{pred}. If provided, the characters +from @var{base_cs} are added to the result. +@end deffn + +@deffn {Scheme Procedure} char-set-filter! pred cs base_cs +@deffnx {C Function} scm_char_set_filter_x (pred, cs, base_cs) +Return a character set containing every character from @var{cs} +so that it satisfies @var{pred}. The characters are added to +@var{base_cs} and @var{base_cs} is returned. +@end deffn + +@deffn {Scheme Procedure} ucs-range->char-set lower upper [error [base_cs]] +@deffnx {C Function} scm_ucs_range_to_char_set (lower, upper, error, base_cs) +Return a character set containing all characters whose +character codes lie in the half-open range +[@var{lower},@var{upper}). + +If @var{error} is a true value, an error is signalled if the +specified range contains characters which are not contained in +the implemented character range. If @var{error} is @code{#f}, +these characters are silently left out of the resultung +character set. + +The characters in @var{base_cs} are added to the result, if +given. +@end deffn + +@deffn {Scheme Procedure} ucs-range->char-set! lower upper error base_cs +@deffnx {C Function} scm_ucs_range_to_char_set_x (lower, upper, error, base_cs) +Return a character set containing all characters whose +character codes lie in the half-open range +[@var{lower},@var{upper}). + +If @var{error} is a true value, an error is signalled if the +specified range contains characters which are not contained in +the implemented character range. If @var{error} is @code{#f}, +these characters are silently left out of the resultung +character set. + +The characters are added to @var{base_cs} and @var{base_cs} is +returned. +@end deffn + +@deffn {Scheme Procedure} ->char-set x +@deffnx {C Function} scm_to_char_set (x) +Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is. +@end deffn + +@c =================================================================== + +@node Querying Character Sets +@subsubsection Querying Character Sets + +Access the elements and other information of a character set with these +procedures. + +@deffn {Scheme Procedure} char-set-size cs +@deffnx {C Function} scm_char_set_size (cs) +Return the number of elements in character set @var{cs}. +@end deffn + +@deffn {Scheme Procedure} char-set-count pred cs +@deffnx {C Function} scm_char_set_count (pred, cs) +Return the number of the elements int the character set +@var{cs} which satisfy the predicate @var{pred}. +@end deffn + +@deffn {Scheme Procedure} char-set->list cs +@deffnx {C Function} scm_char_set_to_list (cs) +Return a list containing the elements of the character set +@var{cs}. +@end deffn + +@deffn {Scheme Procedure} char-set->string cs +@deffnx {C Function} scm_char_set_to_string (cs) +Return a string containing the elements of the character set +@var{cs}. The order in which the characters are placed in the +string is not defined. +@end deffn + +@deffn {Scheme Procedure} char-set-contains? cs ch +@deffnx {C Function} scm_char_set_contains_p (cs, ch) +Return @code{#t} iff the character @var{ch} is contained in the +character set @var{cs}. +@end deffn + +@deffn {Scheme Procedure} char-set-every pred cs +@deffnx {C Function} scm_char_set_every (pred, cs) +Return a true value if every character in the character set +@var{cs} satisfies the predicate @var{pred}. +@end deffn + +@deffn {Scheme Procedure} char-set-any pred cs +@deffnx {C Function} scm_char_set_any (pred, cs) +Return a true value if any character in the character set +@var{cs} satisfies the predicate @var{pred}. +@end deffn + +@c =================================================================== + +@node Character-Set Algebra +@subsubsection Character-Set Algebra + +Character sets can be manipulated with the common set algebra operation, +such as union, complement, intersection etc. All of these procedures +provide side-effecting variants, which modify their character set +argument(s). + +@deffn {Scheme Procedure} char-set-adjoin cs . rest +@deffnx {C Function} scm_char_set_adjoin (cs, rest) +Add all character arguments to the first argument, which must +be a character set. +@end deffn + +@deffn {Scheme Procedure} char-set-delete cs . rest +@deffnx {C Function} scm_char_set_delete (cs, rest) +Delete all character arguments from the first argument, which +must be a character set. +@end deffn + +@deffn {Scheme Procedure} char-set-adjoin! cs . rest +@deffnx {C Function} scm_char_set_adjoin_x (cs, rest) +Add all character arguments to the first argument, which must +be a character set. +@end deffn + +@deffn {Scheme Procedure} char-set-delete! cs . rest +@deffnx {C Function} scm_char_set_delete_x (cs, rest) +Delete all character arguments from the first argument, which +must be a character set. +@end deffn + +@deffn {Scheme Procedure} char-set-complement cs +@deffnx {C Function} scm_char_set_complement (cs) +Return the complement of the character set @var{cs}. +@end deffn + +@deffn {Scheme Procedure} char-set-union . rest +@deffnx {C Function} scm_char_set_union (rest) +Return the union of all argument character sets. +@end deffn + +@deffn {Scheme Procedure} char-set-intersection . rest +@deffnx {C Function} scm_char_set_intersection (rest) +Return the intersection of all argument character sets. +@end deffn + +@deffn {Scheme Procedure} char-set-difference cs1 . rest +@deffnx {C Function} scm_char_set_difference (cs1, rest) +Return the difference of all argument character sets. +@end deffn + +@deffn {Scheme Procedure} char-set-xor . rest +@deffnx {C Function} scm_char_set_xor (rest) +Return the exclusive-or of all argument character sets. +@end deffn + +@deffn {Scheme Procedure} char-set-diff+intersection cs1 . rest +@deffnx {C Function} scm_char_set_diff_plus_intersection (cs1, rest) +Return the difference and the intersection of all argument +character sets. +@end deffn + +@deffn {Scheme Procedure} char-set-complement! cs +@deffnx {C Function} scm_char_set_complement_x (cs) +Return the complement of the character set @var{cs}. +@end deffn + +@deffn {Scheme Procedure} char-set-union! cs1 . rest +@deffnx {C Function} scm_char_set_union_x (cs1, rest) +Return the union of all argument character sets. +@end deffn + +@deffn {Scheme Procedure} char-set-intersection! cs1 . rest +@deffnx {C Function} scm_char_set_intersection_x (cs1, rest) +Return the intersection of all argument character sets. +@end deffn + +@deffn {Scheme Procedure} char-set-difference! cs1 . rest +@deffnx {C Function} scm_char_set_difference_x (cs1, rest) +Return the difference of all argument character sets. +@end deffn + +@deffn {Scheme Procedure} char-set-xor! cs1 . rest +@deffnx {C Function} scm_char_set_xor_x (cs1, rest) +Return the exclusive-or of all argument character sets. +@end deffn + +@deffn {Scheme Procedure} char-set-diff+intersection! cs1 cs2 . rest +@deffnx {C Function} scm_char_set_diff_plus_intersection_x (cs1, cs2, rest) +Return the difference and the intersection of all argument +character sets. +@end deffn + +@c =================================================================== + +@node Standard Character Sets +@subsubsection Standard Character Sets + +In order to make the use of the character set data type and procedures +useful, several predefined character set variables exist. + +@defvar char-set:lower-case +All lower-case characters. +@end defvar + +@defvar char-set:upper-case +All upper-case characters. +@end defvar + +@defvar char-set:title-case +This is empty, because ASCII has no titlecase characters. +@end defvar + +@defvar char-set:letter +All letters, e.g. the union of @code{char-set:lower-case} and +@code{char-set:upper-case}. +@end defvar + +@defvar char-set:digit +All digits. +@end defvar + +@defvar char-set:letter+digit +The union of @code{char-set:letter} and @code{char-set:digit}. +@end defvar + +@defvar char-set:graphic +All characters which would put ink on the paper. +@end defvar + +@defvar char-set:printing +The union of @code{char-set:graphic} and @code{char-set:whitespace}. +@end defvar + +@defvar char-set:whitespace +All whitespace characters. +@end defvar + +@defvar char-set:blank +All horizontal whitespace characters, that is @code{#\space} and +@code{#\tab}. +@end defvar + +@defvar char-set:iso-control +The ISO control characters with the codes 0--31 and 127. +@end defvar + +@defvar char-set:punctuation +The characters @code{!"#%&'()*,-./:;?@@[\\]_@{@}} +@end defvar + +@defvar char-set:symbol +The characters @code{$+<=>^`|~}. +@end defvar + +@defvar char-set:hex-digit +The hexadecimal digits @code{0123456789abcdefABCDEF}. +@end defvar + +@defvar char-set:ascii +All ASCII characters. +@end defvar + +@defvar char-set:empty +The empty character set. +@end defvar + +@defvar char-set:full +This character set contains all possible characters. +@end defvar @node Strings @subsection Strings diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 13a2ed198..9a6659a05 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1864,6 +1864,12 @@ value (on which @var{p} returns true) to produce the final/rightmost return value is not specified. @end deffn +@deffn {Scheme Procedure} string-for-each-index proc s [start [end]] +@deffnx {C Function} scm_string_for_each_index (proc, s, start, end) +@var{proc} is mapped over @var{s} in left-to-right order. The +return value is not specified. +@end deffn + @c =================================================================== @@ -1960,402 +1966,8 @@ character set, it is tested for membership. @subsection SRFI-14 - Character-set Library @cindex SRFI-14 -SRFI-14 defines the data type @dfn{character set}, and also defines a -lot of procedures for handling this character type, and a few standard -character sets like whitespace, alphabetic characters and others. - -All procedures from SRFI-14 (character-set library) are implemented in -the module @code{(srfi srfi-14)}, as well as the standard variables -@code{char-set:letter}, @code{char-set:digit} etc. - -@menu -* Loading SRFI-14:: How to make charsets available. -* SRFI-14 Character Set Data Type:: Underlying data type for charsets. -* SRFI-14 Predicates/Comparison:: Charset predicates. -* SRFI-14 Iterating Over Character Sets:: Enumerate charset elements. -* SRFI-14 Creating Character Sets:: Making new charsets. -* SRFI-14 Querying Character Sets:: Test charsets for membership etc. -* SRFI-14 Character-Set Algebra:: Calculating new charsets. -* SRFI-14 Standard Character Sets:: Variables containing predefined charsets. -@end menu - - -@node Loading SRFI-14 -@subsubsection Loading SRFI-14 - -When Guile is properly installed, SRFI-14 support can be loaded into a -running Guile by using the @code{(srfi srfi-14)} module. - -@example -$ guile -guile> (use-modules (srfi srfi-14)) -guile> (char-set-union (char-set #\f #\o #\o) (string->char-set "bar")) -# -guile> -@end example - - -@node SRFI-14 Character Set Data Type -@subsubsection Character Set Data Type - -The data type @dfn{charset} implements sets of characters -(@pxref{Characters}). Because the internal representation of character -sets is not visible to the user, a lot of procedures for handling them -are provided. - -Character sets can be created, extended, tested for the membership of a -characters and be compared to other character sets. - -The Guile implementation of character sets deals with 8-bit characters. -In the standard variables, only the ASCII part of the character range is -really used, so that for example @dfn{Umlaute} and other accented -characters are not considered to be letters. In the future, as Guile -may get support for international character sets, this will change, so -don't rely on these ``features''. - - -@c =================================================================== - -@node SRFI-14 Predicates/Comparison -@subsubsection Predicates/Comparison - -Use these procedures for testing whether an object is a character set, -or whether several character sets are equal or subsets of each other. -@code{char-set-hash} can be used for calculating a hash value, maybe for -usage in fast lookup procedures. - -@deffn {Scheme Procedure} char-set? obj -Return @code{#t} if @var{obj} is a character set, @code{#f} -otherwise. -@end deffn - -@deffn {Scheme Procedure} char-set= cs1 @dots{} -Return @code{#t} if all given character sets are equal. -@end deffn - -@deffn {Scheme Procedure} char-set<= cs1 @dots{} -Return @code{#t} if every character set @var{cs}i is a subset -of character set @var{cs}i+1. -@end deffn - -@deffn {Scheme Procedure} char-set-hash cs [bound] -Compute a hash value for the character set @var{cs}. If -@var{bound} is given and not @code{#f}, it restricts the -returned value to the range 0 @dots{} @var{bound - 1}. -@end deffn - - -@c =================================================================== - -@node SRFI-14 Iterating Over Character Sets -@subsubsection Iterating Over Character Sets - -Character set cursors are a means for iterating over the members of a -character sets. After creating a character set cursor with -@code{char-set-cursor}, a cursor can be dereferenced with -@code{char-set-ref}, advanced to the next member with -@code{char-set-cursor-next}. Whether a cursor has passed past the last -element of the set can be checked with @code{end-of-char-set?}. - -Additionally, mapping and (un-)folding procedures for character sets are -provided. - -@deffn {Scheme Procedure} char-set-cursor cs -Return a cursor into the character set @var{cs}. -@end deffn - -@deffn {Scheme Procedure} char-set-ref cs cursor -Return the character at the current cursor position -@var{cursor} in the character set @var{cs}. It is an error to -pass a cursor for which @code{end-of-char-set?} returns true. -@end deffn - -@deffn {Scheme Procedure} char-set-cursor-next cs cursor -Advance the character set cursor @var{cursor} to the next -character in the character set @var{cs}. It is an error if the -cursor given satisfies @code{end-of-char-set?}. -@end deffn - -@deffn {Scheme Procedure} end-of-char-set? cursor -Return @code{#t} if @var{cursor} has reached the end of a -character set, @code{#f} otherwise. -@end deffn - -@deffn {Scheme Procedure} char-set-fold kons knil cs -Fold the procedure @var{kons} over the character set @var{cs}, -initializing it with @var{knil}. -@end deffn - -@deffn {Scheme Procedure} char-set-unfold p f g seed [base_cs] -@deffnx {Scheme Procedure} char-set-unfold! p f g seed base_cs -This is a fundamental constructor for character sets. -@itemize @bullet -@item @var{g} is used to generate a series of ``seed'' values -from the initial seed: @var{seed}, (@var{g} @var{seed}), -(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{} -@item @var{p} tells us when to stop -- when it returns true -when applied to one of the seed values. -@item @var{f} maps each seed value to a character. These -characters are added to the base character set @var{base_cs} to -form the result; @var{base_cs} defaults to the empty set. -@end itemize - -@code{char-set-unfold!} is the side-effecting variant. -@end deffn - -@deffn {Scheme Procedure} char-set-for-each proc cs -Apply @var{proc} to every character in the character set -@var{cs}. The return value is not specified. -@end deffn - -@deffn {Scheme Procedure} char-set-map proc cs -Map the procedure @var{proc} over every character in @var{cs}. -@var{proc} must be a character -> character procedure. -@end deffn - - -@c =================================================================== - -@node SRFI-14 Creating Character Sets -@subsubsection Creating Character Sets - -New character sets are produced with these procedures. - -@deffn {Scheme Procedure} char-set-copy cs -Return a newly allocated character set containing all -characters in @var{cs}. -@end deffn - -@deffn {Scheme Procedure} char-set char1 @dots{} -Return a character set containing all given characters. -@end deffn - -@deffn {Scheme Procedure} list->char-set char_list [base_cs] -@deffnx {Scheme Procedure} list->char-set! char_list base_cs -Convert the character list @var{list} to a character set. If -the character set @var{base_cs} is given, the character in this -set are also included in the result. - -@code{list->char-set!} is the side-effecting variant. -@end deffn - -@deffn {Scheme Procedure} string->char-set s [base_cs] -@deffnx {Scheme Procedure} string->char-set! s base_cs -Convert the string @var{str} to a character set. If the -character set @var{base_cs} is given, the characters in this -set are also included in the result. - -@code{string->char-set!} is the side-effecting variant. -@end deffn - -@deffn {Scheme Procedure} char-set-filter pred cs [base_cs] -@deffnx {Scheme Procedure} char-set-filter! pred cs base_cs -Return a character set containing every character from @var{cs} -so that it satisfies @var{pred}. If provided, the characters -from @var{base_cs} are added to the result. - -@code{char-set-filter!} is the side-effecting variant. -@end deffn - -@deffn {Scheme Procedure} ucs-range->char-set lower upper [error? base_cs] -@deffnx {Scheme Procedure} uce-range->char-set! lower upper error? base_cs -Return a character set containing all characters whose -character codes lie in the half-open range -[@var{lower},@var{upper}). - -If @var{error} is a true value, an error is signalled if the -specified range contains characters which are not contained in -the implemented character range. If @var{error} is @code{#f}, -these characters are silently left out of the resulting -character set. - -The characters in @var{base_cs} are added to the result, if -given. - -@code{ucs-range->char-set!} is the side-effecting variant. -@end deffn - -@deffn {Scheme Procedure} ->char-set x -Coerce @var{x} into a character set. @var{x} may be a string, a -character or a character set. -@end deffn - - -@c =================================================================== - -@node SRFI-14 Querying Character Sets -@subsubsection Querying Character Sets - -Access the elements and other information of a character set with these -procedures. - -@deffn {Scheme Procedure} char-set-size cs -Return the number of elements in character set @var{cs}. -@end deffn - -@deffn {Scheme Procedure} char-set-count pred cs -Return the number of the elements int the character set -@var{cs} which satisfy the predicate @var{pred}. -@end deffn - -@deffn {Scheme Procedure} char-set->list cs -Return a list containing the elements of the character set -@var{cs}. -@end deffn - -@deffn {Scheme Procedure} char-set->string cs -Return a string containing the elements of the character set -@var{cs}. The order in which the characters are placed in the -string is not defined. -@end deffn - -@deffn {Scheme Procedure} char-set-contains? cs char -Return @code{#t} iff the character @var{ch} is contained in the -character set @var{cs}. -@end deffn - -@deffn {Scheme Procedure} char-set-every pred cs -Return a true value if every character in the character set -@var{cs} satisfies the predicate @var{pred}. -@end deffn - -@deffn {Scheme Procedure} char-set-any pred cs -Return a true value if any character in the character set -@var{cs} satisfies the predicate @var{pred}. -@end deffn - - -@c =================================================================== - -@node SRFI-14 Character-Set Algebra -@subsubsection Character-Set Algebra - -Character sets can be manipulated with the common set algebra operation, -such as union, complement, intersection etc. All of these procedures -provide side-effecting variants, which modify their character set -argument(s). - -@deffn {Scheme Procedure} char-set-adjoin cs char1 @dots{} -@deffnx {Scheme Procedure} char-set-adjoin! cs char1 @dots{} -Add all character arguments to the first argument, which must -be a character set. -@end deffn - -@deffn {Scheme Procedure} char-set-delete cs char1 @dots{} -@deffnx {Scheme Procedure} char-set-delete! cs char1 @dots{} -Delete all character arguments from the first argument, which -must be a character set. -@end deffn - -@deffn {Scheme Procedure} char-set-complement cs -@deffnx {Scheme Procedure} char-set-complement! cs -Return the complement of the character set @var{cs}. -@end deffn - -@deffn {Scheme Procedure} char-set-union cs1 @dots{} -@deffnx {Scheme Procedure} char-set-union! cs1 @dots{} -Return the union of all argument character sets. -@end deffn - -@deffn {Scheme Procedure} char-set-intersection cs1 @dots{} -@deffnx {Scheme Procedure} char-set-intersection! cs1 @dots{} -Return the intersection of all argument character sets. -@end deffn - -@deffn {Scheme Procedure} char-set-difference cs1 @dots{} -@deffnx {Scheme Procedure} char-set-difference! cs1 @dots{} -Return the difference of all argument character sets. -@end deffn - -@deffn {Scheme Procedure} char-set-xor cs1 @dots{} -@deffnx {Scheme Procedure} char-set-xor! cs1 @dots{} -Return the exclusive-or of all argument character sets. -@end deffn - -@deffn {Scheme Procedure} char-set-diff+intersection cs1 @dots{} -@deffnx {Scheme Procedure} char-set-diff+intersection! cs1 @dots{} -Return the difference and the intersection of all argument -character sets. -@end deffn - - -@c =================================================================== - -@node SRFI-14 Standard Character Sets -@subsubsection Standard Character Sets - -In order to make the use of the character set data type and procedures -useful, several predefined character set variables exist. - -@defvar char-set:lower-case -All lower-case characters. -@end defvar - -@defvar char-set:upper-case -All upper-case characters. -@end defvar - -@defvar char-set:title-case -This is empty, because ASCII has no titlecase characters. -@end defvar - -@defvar char-set:letter -All letters, e.g. the union of @code{char-set:lower-case} and -@code{char-set:upper-case}. -@end defvar - -@defvar char-set:digit -All digits. -@end defvar - -@defvar char-set:letter+digit -The union of @code{char-set:letter} and @code{char-set:digit}. -@end defvar - -@defvar char-set:graphic -All characters which would put ink on the paper. -@end defvar - -@defvar char-set:printing -The union of @code{char-set:graphic} and @code{char-set:whitespace}. -@end defvar - -@defvar char-set:whitespace -All whitespace characters. -@end defvar - -@defvar char-set:blank -All horizontal whitespace characters, that is @code{#\space} and -@code{#\tab}. -@end defvar - -@defvar char-set:iso-control -The ISO control characters with the codes 0--31 and 127. -@end defvar - -@defvar char-set:punctuation -The characters @code{!"#%&'()*,-./:;?@@[\\]_@{@}} -@end defvar - -@defvar char-set:symbol -The characters @code{$+<=>^`|~}. -@end defvar - -@defvar char-set:hex-digit -The hexadecimal digits @code{0123456789abcdefABCDEF}. -@end defvar - -@defvar char-set:ascii -All ASCII characters. -@end defvar - -@defvar char-set:empty -The empty character set. -@end defvar - -@defvar char-set:full -This character set contains all possible characters. -@end defvar +The SRFI-14 data type and procedures are always available, +@xref{Character Sets}. @node SRFI-16 @subsection SRFI-16 - case-lambda From 5354f4abfd791c64350d0f0c6868eddec3a66762 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 23:34:24 +0000 Subject: [PATCH 070/100] Corrected reference to srfi-14, which is now elsewhere. --- doc/ref/api-compound.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 9d9eec3b7..990a7c9c0 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -2361,8 +2361,8 @@ values are arbitrary as long as they're in the range 0 to @math{@var{size}-1}. Helpful functions for forming a hash value, in addition to @code{hashq} etc below, include @code{symbol-hash} (@pxref{Symbol Keys}), @code{string-hash} and @code{string-hash-ci} -(@pxref{SRFI-13 Comparison}), and @code{char-set-hash} (@pxref{SRFI-14 -Predicates/Comparison}). +(@pxref{SRFI-13 Comparison}), and @code{char-set-hash} +(@pxref{Character Set Predicates/Comparison}). Note that currently, unfortunately, there's no @code{hashx-remove!} function, which rather limits the usefulness of the @code{hashx-} From f3f16cf64b1e75870d4db41890fb77a81b795bc1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 23:36:56 +0000 Subject: [PATCH 071/100] (docstring-process-alist): Consider entries in reverse order. That puts them in new-docstrings.texi in the same order as in the C source. --- doc/maint/docstring.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/maint/docstring.el b/doc/maint/docstring.el index 02eb4bd5f..75f4d45ab 100644 --- a/doc/maint/docstring.el +++ b/doc/maint/docstring.el @@ -1,6 +1,6 @@ ;;; docstring.el --- utilities for Guile docstring maintenance ;;; -;;; Copyright (C) 2001 Neil Jerram +;;; Copyright (C) 2001, 2004 Neil Jerram ;;; ;;; This file is not part of GNU Emacs, but the same permissions apply. ;;; @@ -372,7 +372,7 @@ to which new docstrings should be added.") (setq consider-removal-list (cons (cons module description) consider-removal-list))))))) - (cdr module-list))))) + (reverse (cdr module-list)))))) alist) ;; Prepare a buffer describing the results. From 479357a63dddab6bdb71342406df15860c182a84 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 24 Aug 2004 23:37:07 +0000 Subject: [PATCH 072/100] *** empty log message *** --- doc/maint/ChangeLog | 6 ++++++ doc/ref/ChangeLog | 5 +++++ 2 files changed, 11 insertions(+) diff --git a/doc/maint/ChangeLog b/doc/maint/ChangeLog index f50217f0c..0c6e618d6 100644 --- a/doc/maint/ChangeLog +++ b/doc/maint/ChangeLog @@ -1,3 +1,9 @@ +2004-08-25 Marius Vollmer + + * docstring.el (docstring-process-alist): Consider entries in + reverse order. That puts them in new-docstrings.texi in the same + order as in the C source. + 2004-08-23 Marius Vollmer * docstring.el: Replaced all "@c module" markers with "@c diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 4032a567e..732524a43 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2004-08-25 Marius Vollmer + + * api-data.texi, srfi-modules.texi: Moved docs for SRFI-14 into + main API chapter. Updated docstrings from libguile/. + 2004-08-24 Marius Vollmer Ran a (docstring-process-module "(guile)") and moved entries from From 3fe213f8f13159c99a26c1aff6316ec8400ea0d5 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 25 Aug 2004 00:46:59 +0000 Subject: [PATCH 073/100] (and-let*): Give #t for an empty body, per srfi-2 spec, previously came out as an empty (begin). --- ice-9/and-let-star.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ice-9/and-let-star.scm b/ice-9/and-let-star.scm index 9bd01d138..6604df163 100644 --- a/ice-9/and-let-star.scm +++ b/ice-9/and-let-star.scm @@ -25,7 +25,9 @@ (define (expand vars body) (cond ((null? vars) - `(begin ,@body)) + (if (null? body) + #t + `(begin ,@body))) ((pair? vars) (let ((exp (car vars))) (cond From 93827cbd870445ac988b32f26fd5e4af585c2ee9 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 25 Aug 2004 01:04:40 +0000 Subject: [PATCH 074/100] More tests, in particular exercise #t result on empty body. --- test-suite/tests/and-let-star.test | 48 +++++++++++++++++++++++++++++- 1 file changed, 47 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/and-let-star.test b/test-suite/tests/and-let-star.test index 16439463f..e1f40e062 100644 --- a/test-suite/tests/and-let-star.test +++ b/test-suite/tests/and-let-star.test @@ -29,4 +29,50 @@ (pass-if "cond-expand srfi-2" (cond-expand (srfi-2 #t) - (else #f)))) + (else #f))) + + (with-test-prefix "no bindings" + + (pass-if "no result expression (gives #t)" + (and-let* ())) + + (pass-if "result expression" + (and-let* () + #t)) + + (pass-if "two result expressions" + (and-let* () + #f + #t))) + + (with-test-prefix "one binding" + + (pass-if "no result expression (gives #t)" + (and-let* ((x 123)))) + + (pass-if "result expression" + (and-let* ((x 123)) + #t)) + + (pass-if "result variable" + (and-let* ((x #t)) + x)) + + (pass-if "two result expressions" + (and-let* ((x 123)) + #f + #t))) + + (with-test-prefix "one test" + + (pass-if "no result expression (gives #t)" + (and-let* (( 123)))) + + (pass-if "result expression" + (and-let* (( 123)) + #t)) + + (pass-if "two result expressions" + (and-let* (( 123)) + #f + #t)))) From 4b0ad1f43f38b2e3d03f4040d71e425193222260 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 25 Aug 2004 01:07:35 +0000 Subject: [PATCH 075/100] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ test-suite/ChangeLog | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 615c88e84..02e6b2d91 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2004-08-25 Kevin Ryde + + * and-let-star.scm (and-let*): Give #t for an empty body, per srfi-2 + spec, previously came out as an empty (begin). + 2004-08-25 Marius Vollmer * boot-9.scm (%cond-expand-features): Addef srfi-13 and srfi-14. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e7ed55585..6e8650e7c 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2004-08-25 Kevin Ryde + + * tests/and-let-star.test: More tests, in particular exercise #t + result on empty body. + 2004-08-25 Marius Vollmer * tests/strings.test: Two more tests for double indirect substring From c4c3360b284f3349ccd76cb40b94c2f428e3397b Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 25 Aug 2004 01:08:14 +0000 Subject: [PATCH 076/100] *** empty log message *** --- ice-9/ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 02e6b2d91..deba37692 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -5,7 +5,7 @@ 2004-08-25 Marius Vollmer - * boot-9.scm (%cond-expand-features): Addef srfi-13 and srfi-14. + * boot-9.scm (%cond-expand-features): Added srfi-13 and srfi-14. 2004-08-20 Marius Vollmer From 3d1f24d1f8a80f6b20a43a7beccba95620b62152 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 13:38:37 +0000 Subject: [PATCH 077/100] Synced from libguile/ --- doc/maint/guile.texi | 1553 ++++++++++++++++++++++++++++++++++++------ 1 file changed, 1360 insertions(+), 193 deletions(-) diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi index 3e7c68edb..953b4f910 100644 --- a/doc/maint/guile.texi +++ b/doc/maint/guile.texi @@ -298,132 +298,131 @@ Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}. @end deffn char? -@c snarfed from chars.c:31 +@c snarfed from chars.c:33 @deffn {Scheme Procedure} char? x @deffnx {C Function} scm_char_p (x) Return @code{#t} iff @var{x} is a character, else @code{#f}. @end deffn char=? -@c snarfed from chars.c:40 +@c snarfed from chars.c:42 @deffn {Scheme Procedure} char=? x y Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}. @end deffn char? -@c snarfed from chars.c:77 +@c snarfed from chars.c:79 @deffn {Scheme Procedure} char>? x y Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII sequence, else @code{#f}. @end deffn char>=? -@c snarfed from chars.c:89 +@c snarfed from chars.c:91 @deffn {Scheme Procedure} char>=? x y Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the ASCII sequence, else @code{#f}. @end deffn char-ci=? -@c snarfed from chars.c:101 +@c snarfed from chars.c:103 @deffn {Scheme Procedure} char-ci=? x y Return @code{#t} iff @var{x} is the same character as @var{y} ignoring case, else @code{#f}. @end deffn char-ci? -@c snarfed from chars.c:137 +@c snarfed from chars.c:139 @deffn {Scheme Procedure} char-ci>? x y Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII sequence ignoring case, else @code{#f}. @end deffn char-ci>=? -@c snarfed from chars.c:149 +@c snarfed from chars.c:151 @deffn {Scheme Procedure} char-ci>=? x y Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the ASCII sequence ignoring case, else @code{#f}. @end deffn char-alphabetic? -@c snarfed from chars.c:162 +@c snarfed from chars.c:163 @deffn {Scheme Procedure} char-alphabetic? chr @deffnx {C Function} scm_char_alphabetic_p (chr) Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}. -Alphabetic means the same thing as the isalpha C library function. + @end deffn char-numeric? -@c snarfed from chars.c:173 +@c snarfed from chars.c:172 @deffn {Scheme Procedure} char-numeric? chr @deffnx {C Function} scm_char_numeric_p (chr) Return @code{#t} iff @var{chr} is numeric, else @code{#f}. -Numeric means the same thing as the isdigit C library function. + @end deffn char-whitespace? -@c snarfed from chars.c:184 +@c snarfed from chars.c:181 @deffn {Scheme Procedure} char-whitespace? chr @deffnx {C Function} scm_char_whitespace_p (chr) Return @code{#t} iff @var{chr} is whitespace, else @code{#f}. -Whitespace means the same thing as the isspace C library function. + @end deffn char-upper-case? -@c snarfed from chars.c:197 +@c snarfed from chars.c:192 @deffn {Scheme Procedure} char-upper-case? chr @deffnx {C Function} scm_char_upper_case_p (chr) Return @code{#t} iff @var{chr} is uppercase, else @code{#f}. -Uppercase means the same thing as the isupper C library function. + @end deffn char-lower-case? -@c snarfed from chars.c:209 +@c snarfed from chars.c:202 @deffn {Scheme Procedure} char-lower-case? chr @deffnx {C Function} scm_char_lower_case_p (chr) Return @code{#t} iff @var{chr} is lowercase, else @code{#f}. -Lowercase means the same thing as the islower C library function. + @end deffn char-is-both? -@c snarfed from chars.c:223 +@c snarfed from chars.c:213 @deffn {Scheme Procedure} char-is-both? chr @deffnx {C Function} scm_char_is_both_p (chr) Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}. -Uppercase and lowercase are as defined by the isupper and islower -C library functions. + @end deffn char->integer -@c snarfed from chars.c:237 +@c snarfed from chars.c:228 @deffn {Scheme Procedure} char->integer chr @deffnx {C Function} scm_char_to_integer (chr) Return the number corresponding to ordinal position of @var{chr} in the @@ -431,21 +430,21 @@ ASCII sequence. @end deffn integer->char -@c snarfed from chars.c:249 +@c snarfed from chars.c:240 @deffn {Scheme Procedure} integer->char n @deffnx {C Function} scm_integer_to_char (n) Return the character at position @var{n} in the ASCII sequence. @end deffn char-upcase -@c snarfed from chars.c:259 +@c snarfed from chars.c:250 @deffn {Scheme Procedure} char-upcase chr @deffnx {C Function} scm_char_upcase (chr) Return the uppercase character version of @var{chr}. @end deffn char-downcase -@c snarfed from chars.c:270 +@c snarfed from chars.c:261 @deffn {Scheme Procedure} char-downcase chr @deffnx {C Function} scm_char_downcase (chr) Return the lowercase character version of @var{chr}. @@ -1113,7 +1112,7 @@ must be an integer value. @end deffn apply:nconc2last -@c snarfed from eval.c:4697 +@c snarfed from eval.c:4700 @deffn {Scheme Procedure} apply:nconc2last lst @deffnx {C Function} scm_nconc2last (lst) Given a list (@var{arg1} @dots{} @var{args}), this function @@ -1126,7 +1125,7 @@ destroys its argument, so use with care. @end deffn force -@c snarfed from eval.c:5625 +@c snarfed from eval.c:5628 @deffn {Scheme Procedure} force promise @deffnx {C Function} scm_force (promise) If the promise @var{x} has not been computed yet, compute and @@ -1135,7 +1134,7 @@ value. @end deffn promise? -@c snarfed from eval.c:5648 +@c snarfed from eval.c:5651 @deffn {Scheme Procedure} promise? obj @deffnx {C Function} scm_promise_p (obj) Return true if @var{obj} is a promise, i.e. a delayed computation @@ -1143,7 +1142,7 @@ Return true if @var{obj} is a promise, i.e. a delayed computation @end deffn cons-source -@c snarfed from eval.c:5660 +@c snarfed from eval.c:5663 @deffn {Scheme Procedure} cons-source xorig x y @deffnx {C Function} scm_cons_source (xorig, x, y) Create and return a new pair whose car and cdr are @var{x} and @var{y}. @@ -1152,7 +1151,7 @@ with the new pair. @end deffn copy-tree -@c snarfed from eval.c:5817 +@c snarfed from eval.c:5820 @deffn {Scheme Procedure} copy-tree obj @deffnx {C Function} scm_copy_tree (obj) Recursively copy the data tree that is bound to @var{obj}, and return a @@ -1163,7 +1162,7 @@ any other object. @end deffn primitive-eval -@c snarfed from eval.c:5903 +@c snarfed from eval.c:5906 @deffn {Scheme Procedure} primitive-eval exp @deffnx {C Function} scm_primitive_eval (exp) Evaluate @var{exp} in the top-level environment specified by @@ -1171,7 +1170,7 @@ the current module. @end deffn eval -@c snarfed from eval.c:5972 +@c snarfed from eval.c:5975 @deffn {Scheme Procedure} eval exp module @deffnx {C Function} scm_eval (exp, module) Evaluate @var{exp}, a list representing a Scheme expression, @@ -1182,7 +1181,7 @@ is reset to its previous value when @var{eval} returns. @end deffn eval-options-interface -@c snarfed from eval.c:3087 +@c snarfed from eval.c:3090 @deffn {Scheme Procedure} eval-options-interface [setting] @deffnx {C Function} scm_eval_options_interface (setting) Option interface for the evaluation options. Instead of using @@ -1191,7 +1190,7 @@ this procedure directly, use the procedures @code{eval-enable}, @end deffn evaluator-traps-interface -@c snarfed from eval.c:3105 +@c snarfed from eval.c:3108 @deffn {Scheme Procedure} evaluator-traps-interface [setting] @deffnx {C Function} scm_evaluator_traps (setting) Option interface for the evaluator trap options. @@ -2912,10 +2911,10 @@ otherwise. inf? @c snarfed from numbers.c:549 -@deffn {Scheme Procedure} inf? n -@deffnx {C Function} scm_inf_p (n) -Return @code{#t} if @var{n} is infinite, @code{#f} -otherwise. +@deffn {Scheme Procedure} inf? x +@deffnx {C Function} scm_inf_p (x) +Return @code{#t} if @var{x} is either @samp{+inf.0} +or @samp{-inf.0}, @code{#f} otherwise. @end deffn nan? @@ -4898,20 +4897,20 @@ which were used for the conversion. @end deffn string? -@c snarfed from strings.c:481 +@c snarfed from strings.c:494 @deffn {Scheme Procedure} string? obj @deffnx {C Function} scm_string_p (obj) Return @code{#t} if @var{obj} is a string, else @code{#f}. @end deffn list->string -@c snarfed from strings.c:489 +@c snarfed from strings.c:502 @deffn {Scheme Procedure} list->string implemented by the C function "scm_string" @end deffn string -@c snarfed from strings.c:495 +@c snarfed from strings.c:508 @deffn {Scheme Procedure} string . chrs @deffnx {Scheme Procedure} list->string chrs @deffnx {C Function} scm_string (chrs) @@ -4920,7 +4919,7 @@ Return a newly allocated string composed of the arguments, @end deffn make-string -@c snarfed from strings.c:533 +@c snarfed from strings.c:546 @deffn {Scheme Procedure} make-string k [chr] @deffnx {C Function} scm_make_string (k, chr) Return a newly allocated string of @@ -4930,14 +4929,14 @@ of the @var{string} are unspecified. @end deffn string-length -@c snarfed from strings.c:559 +@c snarfed from strings.c:572 @deffn {Scheme Procedure} string-length string @deffnx {C Function} scm_string_length (string) Return the number of characters in @var{string}. @end deffn string-ref -@c snarfed from strings.c:578 +@c snarfed from strings.c:591 @deffn {Scheme Procedure} string-ref str k @deffnx {C Function} scm_string_ref (str, k) Return character @var{k} of @var{str} using zero-origin @@ -4945,7 +4944,7 @@ indexing. @var{k} must be a valid index of @var{str}. @end deffn string-set! -@c snarfed from strings.c:601 +@c snarfed from strings.c:614 @deffn {Scheme Procedure} string-set! str k chr @deffnx {C Function} scm_string_set_x (str, k, chr) Store @var{chr} in element @var{k} of @var{str} and return @@ -4954,7 +4953,7 @@ an unspecified value. @var{k} must be a valid index of @end deffn substring -@c snarfed from strings.c:637 +@c snarfed from strings.c:650 @deffn {Scheme Procedure} substring str start [end] @deffnx {C Function} scm_substring (str, start, end) Return a newly allocated string formed from the characters @@ -4967,7 +4966,7 @@ exact integers satisfying: @end deffn substring/copy -@c snarfed from strings.c:660 +@c snarfed from strings.c:673 @deffn {Scheme Procedure} substring/copy str start [end] @deffnx {C Function} scm_substring_copy (str, start, end) Return a newly allocated string formed from the characters @@ -4980,7 +4979,7 @@ exact integers satisfying: @end deffn substring/shared -@c snarfed from strings.c:683 +@c snarfed from strings.c:697 @deffn {Scheme Procedure} substring/shared str start [end] @deffnx {C Function} scm_substring_shared (str, start, end) Return string that indirectly refers to the characters @@ -4993,82 +4992,15 @@ exact integers satisfying: @end deffn string-append -@c snarfed from strings.c:702 +@c snarfed from strings.c:716 @deffn {Scheme Procedure} string-append . args @deffnx {C Function} scm_string_append (args) Return a newly allocated string whose characters form the concatenation of the given strings, @var{args}. @end deffn - string-index -@c snarfed from strop.c:113 -@deffn {Scheme Procedure} string-index str chr [frm [to]] -@deffnx {C Function} scm_string_index (str, chr, frm, to) -Return the index of the first occurrence of @var{chr} in -@var{str}. The optional integer arguments @var{frm} and -@var{to} limit the search to a portion of the string. This -procedure essentially implements the @code{index} or -@code{strchr} functions from the C library. - -@lisp -(string-index "weiner" #\e) -@result{} 1 - -(string-index "weiner" #\e 2) -@result{} 4 - -(string-index "weiner" #\e 2 4) -@result{} #f -@end lisp -@end deffn - - string-rindex -@c snarfed from strop.c:143 -@deffn {Scheme Procedure} string-rindex str chr [frm [to]] -@deffnx {C Function} scm_string_rindex (str, chr, frm, to) -Like @code{string-index}, but search from the right of the -string rather than from the left. This procedure essentially -implements the @code{rindex} or @code{strrchr} functions from -the C library. - -@lisp -(string-rindex "weiner" #\e) -@result{} 4 - -(string-rindex "weiner" #\e 2 4) -@result{} #f - -(string-rindex "weiner" #\e 2 5) -@result{} 4 -@end lisp -@end deffn - - substring-move! -@c snarfed from strop.c:163 -@deffn {Scheme Procedure} substring-move! str1 start1 end1 str2 start2 -@deffnx {C Function} scm_substring_move_x (str1, start1, end1, str2, start2) -Copy the substring of @var{str1} bounded by @var{start1} and @var{end1} -into @var{str2} beginning at position @var{start2}. -@var{str1} and @var{str2} can be the same string. -@end deffn - - substring-fill! -@c snarfed from strop.c:198 -@deffn {Scheme Procedure} substring-fill! str start end fill -@deffnx {C Function} scm_substring_fill_x (str, start, end, fill) -Change every character in @var{str} between @var{start} and -@var{end} to @var{fill}. - -@lisp -(define y "abcdefg") -(substring-fill! y 1 3 #\r) -y -@result{} "arrdefg" -@end lisp -@end deffn - string-null? -@c snarfed from strop.c:227 +@c snarfed from srfi-13.c:71 @deffn {Scheme Procedure} string-null? str @deffnx {C Function} scm_string_null_p (str) Return @code{#t} if @var{str}'s length is zero, and @@ -5080,75 +5012,657 @@ y @result{} "foo" @end lisp @end deffn + string-any +@c snarfed from srfi-13.c:91 +@deffn {Scheme Procedure} string-any char_pred s [start [end]] +@deffnx {C Function} scm_string_any (char_pred, s, start, end) +Check if the predicate @var{pred} is true for any character in +the string @var{s}. + +Calls to @var{pred} are made from left to right across @var{s}. +When it returns true (ie.@: non-@code{#f}), that return value +is the return from @code{string-any}. + +The SRFI-13 specification requires that the call to @var{pred} +on the last character of @var{s} (assuming that point is +reached) be a tail call, but currently in Guile this is not the +case. +@end deffn + + string-every +@c snarfed from srfi-13.c:150 +@deffn {Scheme Procedure} string-every char_pred s [start [end]] +@deffnx {C Function} scm_string_every (char_pred, s, start, end) +Check if the predicate @var{pred} is true for every character +in the string @var{s}. + +Calls to @var{pred} are made from left to right across @var{s}. +If the predicate is true for every character then the return +value from the last @var{pred} call is the return from +@code{string-every}. + +If there are no characters in @var{s} (ie.@: @var{start} equals +@var{end}) then the return is @code{#t}. + +The SRFI-13 specification requires that the call to @var{pred} +on the last character of @var{s} (assuming that point is +reached) be a tail call, but currently in Guile this is not the +case. +@end deffn + + string-tabulate +@c snarfed from srfi-13.c:202 +@deffn {Scheme Procedure} string-tabulate proc len +@deffnx {C Function} scm_string_tabulate (proc, len) +@var{proc} is an integer->char procedure. Construct a string +of size @var{len} by applying @var{proc} to each index to +produce the corresponding string element. The order in which +@var{proc} is applied to the indices is not specified. +@end deffn + string->list -@c snarfed from strop.c:241 -@deffn {Scheme Procedure} string->list str -@deffnx {C Function} scm_string_to_list (str) -Return a newly allocated list of the characters that make up -the given string @var{str}. @code{string->list} and -@code{list->string} are inverses as far as @samp{equal?} is -concerned. +@c snarfed from srfi-13.c:234 +@deffn {Scheme Procedure} string->list str [start [end]] +@deffnx {C Function} scm_substring_to_list (str, start, end) +Convert the string @var{str} into a list of characters. +@end deffn + + reverse-list->string +@c snarfed from srfi-13.c:271 +@deffn {Scheme Procedure} reverse-list->string chrs +@deffnx {C Function} scm_reverse_list_to_string (chrs) +An efficient implementation of @code{(compose string->list +reverse)}: + +@smalllisp +(reverse-list->string '(#\a #\B #\c)) @result{} "cBa" +@end smalllisp +@end deffn + + string-join +@c snarfed from srfi-13.c:324 +@deffn {Scheme Procedure} string-join ls [delimiter [grammar]] +@deffnx {C Function} scm_string_join (ls, delimiter, grammar) +Append the string in the string list @var{ls}, using the string +@var{delim} as a delimiter between the elements of @var{ls}. +@var{grammar} is a symbol which specifies how the delimiter is +placed between the strings, and defaults to the symbol +@code{infix}. + +@table @code +@item infix +Insert the separator between list elements. An empty string +will produce an empty list. +@item string-infix +Like @code{infix}, but will raise an error if given the empty +list. +@item suffix +Insert the separator after every list element. +@item prefix +Insert the separator before each list element. +@end table @end deffn string-copy -@c snarfed from strop.c:274 -@deffn {Scheme Procedure} string-copy str -@deffnx {C Function} scm_string_copy (str) -Return a newly allocated copy of the given @var{string}. +@c snarfed from srfi-13.c:480 +@deffn {Scheme Procedure} string-copy str [start [end]] +@deffnx {C Function} scm_srfi13_substring_copy (str, start, end) +Return a freshly allocated copy of the string @var{str}. If +given, @var{start} and @var{end} delimit the portion of +@var{str} which is copied. +@end deffn + + string-copy! +@c snarfed from srfi-13.c:507 +@deffn {Scheme Procedure} string-copy! target tstart s [start [end]] +@deffnx {C Function} scm_string_copy_x (target, tstart, s, start, end) +Copy the sequence of characters from index range [@var{start}, +@var{end}) in string @var{s} to string @var{target}, beginning +at index @var{tstart}. The characters are copied left-to-right +or right-to-left as needed -- the copy is guaranteed to work, +even if @var{target} and @var{s} are the same string. It is an +error if the copy operation runs off the end of the target +string. +@end deffn + + substring-move! +@c snarfed from srfi-13.c:536 +@deffn {Scheme Procedure} substring-move! str1 start1 end1 str2 start2 +@deffnx {C Function} scm_substring_move_x (str1, start1, end1, str2, start2) +Copy the substring of @var{str1} bounded by @var{start1} and @var{end1} +into @var{str2} beginning at position @var{start2}. +@var{str1} and @var{str2} can be the same string. +@end deffn + + string-take +@c snarfed from srfi-13.c:545 +@deffn {Scheme Procedure} string-take s n +@deffnx {C Function} scm_string_take (s, n) +Return the @var{n} first characters of @var{s}. +@end deffn + + string-drop +@c snarfed from srfi-13.c:555 +@deffn {Scheme Procedure} string-drop s n +@deffnx {C Function} scm_string_drop (s, n) +Return all but the first @var{n} characters of @var{s}. +@end deffn + + string-take-right +@c snarfed from srfi-13.c:565 +@deffn {Scheme Procedure} string-take-right s n +@deffnx {C Function} scm_string_take_right (s, n) +Return the @var{n} last characters of @var{s}. +@end deffn + + string-drop-right +@c snarfed from srfi-13.c:577 +@deffn {Scheme Procedure} string-drop-right s n +@deffnx {C Function} scm_string_drop_right (s, n) +Return all but the last @var{n} characters of @var{s}. +@end deffn + + string-pad +@c snarfed from srfi-13.c:592 +@deffn {Scheme Procedure} string-pad s len [chr [start [end]]] +@deffnx {C Function} scm_string_pad (s, len, chr, start, end) +Take that characters from @var{start} to @var{end} from the +string @var{s} and return a new string, right-padded by the +character @var{chr} to length @var{len}. If the resulting +string is longer than @var{len}, it is truncated on the right. +@end deffn + + string-pad-right +@c snarfed from srfi-13.c:632 +@deffn {Scheme Procedure} string-pad-right s len [chr [start [end]]] +@deffnx {C Function} scm_string_pad_right (s, len, chr, start, end) +Take that characters from @var{start} to @var{end} from the +string @var{s} and return a new string, left-padded by the +character @var{chr} to length @var{len}. If the resulting +string is longer than @var{len}, it is truncated on the left. +@end deffn + + string-trim +@c snarfed from srfi-13.c:686 +@deffn {Scheme Procedure} string-trim s [char_pred [start [end]]] +@deffnx {C Function} scm_string_trim (s, char_pred, start, end) +Trim @var{s} by skipping over all characters on the left +that satisfy the parameter @var{char_pred}: + +@itemize @bullet +@item +if it is the character @var{ch}, characters equal to +@var{ch} are trimmed, + +@item +if it is a procedure @var{pred} characters that +satisfy @var{pred} are trimmed, + +@item +if it is a character set, characters in that set are trimmed. +@end itemize + +If called without a @var{char_pred} argument, all whitespace is +trimmed. +@end deffn + + string-trim-right +@c snarfed from srfi-13.c:762 +@deffn {Scheme Procedure} string-trim-right s [char_pred [start [end]]] +@deffnx {C Function} scm_string_trim_right (s, char_pred, start, end) +Trim @var{s} by skipping over all characters on the rightt +that satisfy the parameter @var{char_pred}: + +@itemize @bullet +@item +if it is the character @var{ch}, characters equal to @var{ch} +are trimmed, + +@item +if it is a procedure @var{pred} characters that satisfy +@var{pred} are trimmed, + +@item +if it is a character sets, all characters in that set are +trimmed. +@end itemize + +If called without a @var{char_pred} argument, all whitespace is +trimmed. +@end deffn + + string-trim-both +@c snarfed from srfi-13.c:838 +@deffn {Scheme Procedure} string-trim-both s [char_pred [start [end]]] +@deffnx {C Function} scm_string_trim_both (s, char_pred, start, end) +Trim @var{s} by skipping over all characters on both sides of +the string that satisfy the parameter @var{char_pred}: + +@itemize @bullet +@item +if it is the character @var{ch}, characters equal to @var{ch} +are trimmed, + +@item +if it is a procedure @var{pred} characters that satisfy +@var{pred} are trimmed, + +@item +if it is a character set, the characters in the set are +trimmed. +@end itemize + +If called without a @var{char_pred} argument, all whitespace is +trimmed. @end deffn string-fill! -@c snarfed from strop.c:285 -@deffn {Scheme Procedure} string-fill! str chr -@deffnx {C Function} scm_string_fill_x (str, chr) -Store @var{char} in every element of the given @var{string} and -return an unspecified value. +@c snarfed from srfi-13.c:925 +@deffn {Scheme Procedure} string-fill! str chr [start [end]] +@deffnx {C Function} scm_substring_fill_x (str, chr, start, end) +Stores @var{chr} in every element of the given @var{str} and +returns an unspecified value. +@end deffn + + string-compare +@c snarfed from srfi-13.c:975 +@deffn {Scheme Procedure} string-compare s1 s2 proc_lt proc_eq proc_gt [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_compare (s1, s2, proc_lt, proc_eq, proc_gt, start1, end1, start2, end2) +Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the +mismatch index, depending upon whether @var{s1} is less than, +equal to, or greater than @var{s2}. The mismatch index is the +largest index @var{i} such that for every 0 <= @var{j} < +@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is, +@var{i} is the first position that does not match. +@end deffn + + string-compare-ci +@c snarfed from srfi-13.c:1018 +@deffn {Scheme Procedure} string-compare-ci s1 s2 proc_lt proc_eq proc_gt [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_compare_ci (s1, s2, proc_lt, proc_eq, proc_gt, start1, end1, start2, end2) +Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the +mismatch index, depending upon whether @var{s1} is less than, +equal to, or greater than @var{s2}. The mismatch index is the +largest index @var{i} such that for every 0 <= @var{j} < +@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is, +@var{i} is the first position that does not match. The +character comparison is done case-insensitively. +@end deffn + + string= +@c snarfed from srfi-13.c:1056 +@deffn {Scheme Procedure} string= s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_eq (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} and @var{s2} are not equal, a true +value otherwise. +@end deffn + + string<> +@c snarfed from srfi-13.c:1095 +@deffn {Scheme Procedure} string<> s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_neq (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} and @var{s2} are equal, a true +value otherwise. +@end deffn + + string< +@c snarfed from srfi-13.c:1138 +@deffn {Scheme Procedure} string< s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_lt (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a +true value otherwise. +@end deffn + + string> +@c snarfed from srfi-13.c:1181 +@deffn {Scheme Procedure} string> s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_gt (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is less or equal to @var{s2}, a +true value otherwise. +@end deffn + + string<= +@c snarfed from srfi-13.c:1224 +@deffn {Scheme Procedure} string<= s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_le (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is greater to @var{s2}, a true +value otherwise. +@end deffn + + string>= +@c snarfed from srfi-13.c:1267 +@deffn {Scheme Procedure} string>= s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ge (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is less to @var{s2}, a true value +otherwise. +@end deffn + + string-ci= +@c snarfed from srfi-13.c:1311 +@deffn {Scheme Procedure} string-ci= s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ci_eq (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} and @var{s2} are not equal, a true +value otherwise. The character comparison is done +case-insensitively. +@end deffn + + string-ci<> +@c snarfed from srfi-13.c:1355 +@deffn {Scheme Procedure} string-ci<> s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ci_neq (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} and @var{s2} are equal, a true +value otherwise. The character comparison is done +case-insensitively. +@end deffn + + string-ci< +@c snarfed from srfi-13.c:1399 +@deffn {Scheme Procedure} string-ci< s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ci_lt (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a +true value otherwise. The character comparison is done +case-insensitively. +@end deffn + + string-ci> +@c snarfed from srfi-13.c:1443 +@deffn {Scheme Procedure} string-ci> s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ci_gt (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is less or equal to @var{s2}, a +true value otherwise. The character comparison is done +case-insensitively. +@end deffn + + string-ci<= +@c snarfed from srfi-13.c:1487 +@deffn {Scheme Procedure} string-ci<= s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ci_le (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is greater to @var{s2}, a true +value otherwise. The character comparison is done +case-insensitively. +@end deffn + + string-ci>= +@c snarfed from srfi-13.c:1531 +@deffn {Scheme Procedure} string-ci>= s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ci_ge (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is less to @var{s2}, a true value +otherwise. The character comparison is done +case-insensitively. +@end deffn + + string-hash +@c snarfed from srfi-13.c:1576 +@deffn {Scheme Procedure} string-hash s [bound [start [end]]] +@deffnx {C Function} scm_substring_hash (s, bound, start, end) +Compute a hash value for @var{S}. the optional argument @var{bound} is a non-negative exact integer specifying the range of the hash function. A positive value restricts the return value to the range [0,bound). +@end deffn + + string-hash-ci +@c snarfed from srfi-13.c:1593 +@deffn {Scheme Procedure} string-hash-ci s [bound [start [end]]] +@deffnx {C Function} scm_substring_hash_ci (s, bound, start, end) +Compute a hash value for @var{S}. the optional argument @var{bound} is a non-negative exact integer specifying the range of the hash function. A positive value restricts the return value to the range [0,bound). +@end deffn + + string-prefix-length +@c snarfed from srfi-13.c:1605 +@deffn {Scheme Procedure} string-prefix-length s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_prefix_length (s1, s2, start1, end1, start2, end2) +Return the length of the longest common prefix of the two +strings. +@end deffn + + string-prefix-length-ci +@c snarfed from srfi-13.c:1634 +@deffn {Scheme Procedure} string-prefix-length-ci s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_prefix_length_ci (s1, s2, start1, end1, start2, end2) +Return the length of the longest common prefix of the two +strings, ignoring character case. +@end deffn + + string-suffix-length +@c snarfed from srfi-13.c:1663 +@deffn {Scheme Procedure} string-suffix-length s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_suffix_length (s1, s2, start1, end1, start2, end2) +Return the length of the longest common suffix of the two +strings. +@end deffn + + string-suffix-length-ci +@c snarfed from srfi-13.c:1692 +@deffn {Scheme Procedure} string-suffix-length-ci s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_suffix_length_ci (s1, s2, start1, end1, start2, end2) +Return the length of the longest common suffix of the two +strings, ignoring character case. +@end deffn + + string-prefix? +@c snarfed from srfi-13.c:1720 +@deffn {Scheme Procedure} string-prefix? s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_prefix_p (s1, s2, start1, end1, start2, end2) +Is @var{s1} a prefix of @var{s2}? +@end deffn + + string-prefix-ci? +@c snarfed from srfi-13.c:1749 +@deffn {Scheme Procedure} string-prefix-ci? s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_prefix_ci_p (s1, s2, start1, end1, start2, end2) +Is @var{s1} a prefix of @var{s2}, ignoring character case? +@end deffn + + string-suffix? +@c snarfed from srfi-13.c:1778 +@deffn {Scheme Procedure} string-suffix? s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_suffix_p (s1, s2, start1, end1, start2, end2) +Is @var{s1} a suffix of @var{s2}? +@end deffn + + string-suffix-ci? +@c snarfed from srfi-13.c:1807 +@deffn {Scheme Procedure} string-suffix-ci? s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_suffix_ci_p (s1, s2, start1, end1, start2, end2) +Is @var{s1} a suffix of @var{s2}, ignoring character case? +@end deffn + + string-index +@c snarfed from srfi-13.c:1848 +@deffn {Scheme Procedure} string-index s char_pred [start [end]] +@deffnx {C Function} scm_string_index (s, char_pred, start, end) +Search through the string @var{s} from left to right, returning +the index of the first occurence of a character which + +@itemize @bullet +@item +equals @var{char_pred}, if it is character, + +@item +satisifies the predicate @var{char_pred}, if it is a procedure, + +@item +is in the set @var{char_pred}, if it is a character set. +@end itemize +@end deffn + + string-index-right +@c snarfed from srfi-13.c:1907 +@deffn {Scheme Procedure} string-index-right s char_pred [start [end]] +@deffnx {C Function} scm_string_index_right (s, char_pred, start, end) +Search through the string @var{s} from right to left, returning +the index of the last occurence of a character which + +@itemize @bullet +@item +equals @var{char_pred}, if it is character, + +@item +satisifies the predicate @var{char_pred}, if it is a procedure, + +@item +is in the set if @var{char_pred} is a character set. +@end itemize +@end deffn + + string-rindex +@c snarfed from srfi-13.c:1966 +@deffn {Scheme Procedure} string-rindex s char_pred [start [end]] +@deffnx {C Function} scm_string_rindex (s, char_pred, start, end) +Search through the string @var{s} from right to left, returning +the index of the last occurence of a character which + +@itemize @bullet +@item +equals @var{char_pred}, if it is character, + +@item +satisifies the predicate @var{char_pred}, if it is a procedure, + +@item +is in the set if @var{char_pred} is a character set. +@end itemize +@end deffn + + string-skip +@c snarfed from srfi-13.c:1986 +@deffn {Scheme Procedure} string-skip s char_pred [start [end]] +@deffnx {C Function} scm_string_skip (s, char_pred, start, end) +Search through the string @var{s} from left to right, returning +the index of the first occurence of a character which + +@itemize @bullet +@item +does not equal @var{char_pred}, if it is character, + +@item +does not satisify the predicate @var{char_pred}, if it is a +procedure, + +@item +is not in the set if @var{char_pred} is a character set. +@end itemize +@end deffn + + string-skip-right +@c snarfed from srfi-13.c:2047 +@deffn {Scheme Procedure} string-skip-right s char_pred [start [end]] +@deffnx {C Function} scm_string_skip_right (s, char_pred, start, end) +Search through the string @var{s} from right to left, returning +the index of the last occurence of a character which + +@itemize @bullet +@item +does not equal @var{char_pred}, if it is character, + +@item +does not satisfy the predicate @var{char_pred}, if it is a +procedure, + +@item +is not in the set if @var{char_pred} is a character set. +@end itemize +@end deffn + + string-count +@c snarfed from srfi-13.c:2107 +@deffn {Scheme Procedure} string-count s char_pred [start [end]] +@deffnx {C Function} scm_string_count (s, char_pred, start, end) +Return the count of the number of characters in the string +@var{s} which + +@itemize @bullet +@item +equals @var{char_pred}, if it is character, + +@item +satisifies the predicate @var{char_pred}, if it is a procedure. + +@item +is in the set @var{char_pred}, if it is a character set. +@end itemize +@end deffn + + string-contains +@c snarfed from srfi-13.c:2162 +@deffn {Scheme Procedure} string-contains s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_contains (s1, s2, start1, end1, start2, end2) +Does string @var{s1} contain string @var{s2}? Return the index +in @var{s1} where @var{s2} occurs as a substring, or false. +The optional start/end indices restrict the operation to the +indicated substrings. +@end deffn + + string-contains-ci +@c snarfed from srfi-13.c:2203 +@deffn {Scheme Procedure} string-contains-ci s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_contains_ci (s1, s2, start1, end1, start2, end2) +Does string @var{s1} contain string @var{s2}? Return the index +in @var{s1} where @var{s2} occurs as a substring, or false. +The optional start/end indices restrict the operation to the +indicated substrings. Character comparison is done +case-insensitively. @end deffn string-upcase! -@c snarfed from strop.c:327 -@deffn {Scheme Procedure} string-upcase! str -@deffnx {C Function} scm_string_upcase_x (str) -Destructively upcase every character in @var{str} and return -@var{str}. +@c snarfed from srfi-13.c:2261 +@deffn {Scheme Procedure} string-upcase! str [start [end]] +@deffnx {C Function} scm_substring_upcase_x (str, start, end) +Destructively upcase every character in @code{str}. + @lisp -y @result{} "arrdefg" -(string-upcase! y) @result{} "ARRDEFG" -y @result{} "ARRDEFG" +(string-upcase! y) +@result{} "ARRDEFG" +y +@result{} "ARRDEFG" @end lisp @end deffn string-upcase -@c snarfed from strop.c:340 -@deffn {Scheme Procedure} string-upcase str -@deffnx {C Function} scm_string_upcase (str) -Return a freshly allocated string containing the characters of -@var{str} in upper case. +@c snarfed from srfi-13.c:2282 +@deffn {Scheme Procedure} string-upcase str [start [end]] +@deffnx {C Function} scm_substring_upcase (str, start, end) +Upcase every character in @code{str}. @end deffn string-downcase! -@c snarfed from strop.c:376 -@deffn {Scheme Procedure} string-downcase! str -@deffnx {C Function} scm_string_downcase_x (str) -Destructively downcase every character in @var{str} and return -@var{str}. +@c snarfed from srfi-13.c:2328 +@deffn {Scheme Procedure} string-downcase! str [start [end]] +@deffnx {C Function} scm_substring_downcase_x (str, start, end) +Destructively downcase every character in @var{str}. + @lisp -y @result{} "ARRDEFG" -(string-downcase! y) @result{} "arrdefg" -y @result{} "arrdefg" +y +@result{} "ARRDEFG" +(string-downcase! y) +@result{} "arrdefg" +y +@result{} "arrdefg" @end lisp @end deffn string-downcase -@c snarfed from strop.c:389 -@deffn {Scheme Procedure} string-downcase str -@deffnx {C Function} scm_string_downcase (str) -Return a freshly allocation string containing the characters in -@var{str} in lower case. +@c snarfed from srfi-13.c:2349 +@deffn {Scheme Procedure} string-downcase str [start [end]] +@deffnx {C Function} scm_substring_downcase (str, start, end) +Downcase every character in @var{str}. +@end deffn + + string-titlecase! +@c snarfed from srfi-13.c:2404 +@deffn {Scheme Procedure} string-titlecase! str [start [end]] +@deffnx {C Function} scm_string_titlecase_x (str, start, end) +Destructively titlecase every first character in a word in +@var{str}. +@end deffn + + string-titlecase +@c snarfed from srfi-13.c:2420 +@deffn {Scheme Procedure} string-titlecase str [start [end]] +@deffnx {C Function} scm_string_titlecase (str, start, end) +Titlecase every first character in a word in @var{str}. @end deffn string-capitalize! -@c snarfed from strop.c:441 +@c snarfed from srfi-13.c:2445 @deffn {Scheme Procedure} string-capitalize! str @deffnx {C Function} scm_string_capitalize_x (str) Upcase the first character of every word in @var{str} @@ -5162,7 +5676,7 @@ y @result{} "Hello World" @end deffn string-capitalize -@c snarfed from strop.c:455 +@c snarfed from srfi-13.c:2457 @deffn {Scheme Procedure} string-capitalize str @deffnx {C Function} scm_string_capitalize (str) Return a freshly allocated string with the characters in @@ -5170,8 +5684,230 @@ Return a freshly allocated string with the characters in capitalized. @end deffn + string-reverse +@c snarfed from srfi-13.c:2488 +@deffn {Scheme Procedure} string-reverse str [start [end]] +@deffnx {C Function} scm_string_reverse (str, start, end) +Reverse the string @var{str}. The optional arguments +@var{start} and @var{end} delimit the region of @var{str} to +operate on. +@end deffn + + string-reverse! +@c snarfed from srfi-13.c:2512 +@deffn {Scheme Procedure} string-reverse! str [start [end]] +@deffnx {C Function} scm_string_reverse_x (str, start, end) +Reverse the string @var{str} in-place. The optional arguments +@var{start} and @var{end} delimit the region of @var{str} to +operate on. The return value is unspecified. +@end deffn + + string-append/shared +@c snarfed from srfi-13.c:2535 +@deffn {Scheme Procedure} string-append/shared . ls +@deffnx {C Function} scm_string_append_shared (ls) +Like @code{string-append}, but the result may share memory +with the argument strings. +@end deffn + + string-concatenate +@c snarfed from srfi-13.c:2556 +@deffn {Scheme Procedure} string-concatenate ls +@deffnx {C Function} scm_string_concatenate (ls) +Append the elements of @var{ls} (which must be strings) +together into a single string. Guaranteed to return a freshly +allocated string. +@end deffn + + string-concatenate-reverse +@c snarfed from srfi-13.c:2578 +@deffn {Scheme Procedure} string-concatenate-reverse ls [final_string [end]] +@deffnx {C Function} scm_string_concatenate_reverse (ls, final_string, end) +Without optional arguments, this procedure is equivalent to + +@smalllisp +(string-concatenate (reverse ls)) +@end smalllisp + +If the optional argument @var{final_string} is specified, it is +consed onto the beginning to @var{ls} before performing the +list-reverse and string-concatenate operations. If @var{end} +is given, only the characters of @var{final_string} up to index +@var{end} are used. + +Guaranteed to return a freshly allocated string. +@end deffn + + string-concatenate/shared +@c snarfed from srfi-13.c:2647 +@deffn {Scheme Procedure} string-concatenate/shared ls +@deffnx {C Function} scm_string_concatenate_shared (ls) +Like @code{string-concatenate}, but the result may share memory +with the strings in the list @var{ls}. +@end deffn + + string-concatenate-reverse/shared +@c snarfed from srfi-13.c:2658 +@deffn {Scheme Procedure} string-concatenate-reverse/shared ls [final_string [end]] +@deffnx {C Function} scm_string_concatenate_reverse_shared (ls, final_string, end) +Like @code{string-concatenate-reverse}, but the result may +share memory with the the strings in the @var{ls} arguments. +@end deffn + + string-map +@c snarfed from srfi-13.c:2671 +@deffn {Scheme Procedure} string-map proc s [start [end]] +@deffnx {C Function} scm_string_map (proc, s, start, end) +@var{proc} is a char->char procedure, it is mapped over +@var{s}. The order in which the procedure is applied to the +string elements is not specified. +@end deffn + + string-map! +@c snarfed from srfi-13.c:2704 +@deffn {Scheme Procedure} string-map! proc s [start [end]] +@deffnx {C Function} scm_string_map_x (proc, s, start, end) +@var{proc} is a char->char procedure, it is mapped over +@var{s}. The order in which the procedure is applied to the +string elements is not specified. The string @var{s} is +modified in-place, the return value is not specified. +@end deffn + + string-fold +@c snarfed from srfi-13.c:2731 +@deffn {Scheme Procedure} string-fold kons knil s [start [end]] +@deffnx {C Function} scm_string_fold (kons, knil, s, start, end) +Fold @var{kons} over the characters of @var{s}, with @var{knil} +as the terminating element, from left to right. @var{kons} +must expect two arguments: The actual character and the last +result of @var{kons}' application. +@end deffn + + string-fold-right +@c snarfed from srfi-13.c:2760 +@deffn {Scheme Procedure} string-fold-right kons knil s [start [end]] +@deffnx {C Function} scm_string_fold_right (kons, knil, s, start, end) +Fold @var{kons} over the characters of @var{s}, with @var{knil} +as the terminating element, from right to left. @var{kons} +must expect two arguments: The actual character and the last +result of @var{kons}' application. +@end deffn + + string-unfold +@c snarfed from srfi-13.c:2803 +@deffn {Scheme Procedure} string-unfold p f g seed [base [make_final]] +@deffnx {C Function} scm_string_unfold (p, f, g, seed, base, make_final) +@itemize @bullet +@item @var{g} is used to generate a series of @emph{seed} +values from the initial @var{seed}: @var{seed}, (@var{g} +@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), +@dots{} +@item @var{p} tells us when to stop -- when it returns true +when applied to one of these seed values. +@item @var{f} maps each seed value to the corresponding +character in the result string. These chars are assembled +into the string in a left-to-right order. +@item @var{base} is the optional initial/leftmost portion +of the constructed string; it default to the empty +string. +@item @var{make_final} is applied to the terminal seed +value (on which @var{p} returns true) to produce +the final/rightmost portion of the constructed string. +It defaults to @code{(lambda (x) )}. +@end itemize +@end deffn + + string-unfold-right +@c snarfed from srfi-13.c:2866 +@deffn {Scheme Procedure} string-unfold-right p f g seed [base [make_final]] +@deffnx {C Function} scm_string_unfold_right (p, f, g, seed, base, make_final) +@itemize @bullet +@item @var{g} is used to generate a series of @emph{seed} +values from the initial @var{seed}: @var{seed}, (@var{g} +@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), +@dots{} +@item @var{p} tells us when to stop -- when it returns true +when applied to one of these seed values. +@item @var{f} maps each seed value to the corresponding +character in the result string. These chars are assembled +into the string in a right-to-left order. +@item @var{base} is the optional initial/rightmost portion +of the constructed string; it default to the empty +string. +@item @var{make_final} is applied to the terminal seed +value (on which @var{p} returns true) to produce +the final/leftmost portion of the constructed string. +It defaults to @code{(lambda (x) )}. +@end itemize +@end deffn + + string-for-each +@c snarfed from srfi-13.c:2913 +@deffn {Scheme Procedure} string-for-each proc s [start [end]] +@deffnx {C Function} scm_string_for_each (proc, s, start, end) +@var{proc} is mapped over @var{s} in left-to-right order. The +return value is not specified. +@end deffn + + string-for-each-index +@c snarfed from srfi-13.c:2937 +@deffn {Scheme Procedure} string-for-each-index proc s [start [end]] +@deffnx {C Function} scm_string_for_each_index (proc, s, start, end) +@var{proc} is mapped over @var{s} in left-to-right order. The +return value is not specified. +@end deffn + + xsubstring +@c snarfed from srfi-13.c:2967 +@deffn {Scheme Procedure} xsubstring s from [to [start [end]]] +@deffnx {C Function} scm_xsubstring (s, from, to, start, end) +This is the @emph{extended substring} procedure that implements +replicated copying of a substring of some string. + +@var{s} is a string, @var{start} and @var{end} are optional +arguments that demarcate a substring of @var{s}, defaulting to +0 and the length of @var{s}. Replicate this substring up and +down index space, in both the positive and negative directions. +@code{xsubstring} returns the substring of this string +beginning at index @var{from}, and ending at @var{to}, which +defaults to @var{from} + (@var{end} - @var{start}). +@end deffn + + string-xcopy! +@c snarfed from srfi-13.c:3010 +@deffn {Scheme Procedure} string-xcopy! target tstart s sfrom [sto [start [end]]] +@deffnx {C Function} scm_string_xcopy_x (target, tstart, s, sfrom, sto, start, end) +Exactly the same as @code{xsubstring}, but the extracted text +is written into the string @var{target} starting at index +@var{tstart}. The operation is not defined if @code{(eq? +@var{target} @var{s})} or these arguments share storage -- you +cannot copy a string on top of itself. +@end deffn + + string-replace +@c snarfed from srfi-13.c:3058 +@deffn {Scheme Procedure} string-replace s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_replace (s1, s2, start1, end1, start2, end2) +Return the string @var{s1}, but with the characters +@var{start1} @dots{} @var{end1} replaced by the characters +@var{start2} @dots{} @var{end2} from @var{s2}. +@end deffn + + string-tokenize +@c snarfed from srfi-13.c:3093 +@deffn {Scheme Procedure} string-tokenize s [token_set [start [end]]] +@deffnx {C Function} scm_string_tokenize (s, token_set, start, end) +Split the string @var{s} into a list of substrings, where each +substring is a maximal non-empty contiguous sequence of +characters from the character set @var{token_set}, which +defaults to @code{char-set:graphic}. +If @var{start} or @var{end} indices are provided, they restrict +@code{string-tokenize} to operating on the indicated substring +of @var{s}. +@end deffn + string-split -@c snarfed from strop.c:484 +@c snarfed from srfi-13.c:3157 @deffn {Scheme Procedure} string-split str chr @deffnx {C Function} scm_string_split (str, chr) Split the string @var{str} into the a list of the substrings delimited @@ -5194,17 +5930,439 @@ result list. @end lisp @end deffn - string-ci->symbol -@c snarfed from strop.c:520 -@deffn {Scheme Procedure} string-ci->symbol str -@deffnx {C Function} scm_string_ci_to_symbol (str) -Return the symbol whose name is @var{str}. @var{str} is -converted to lowercase before the conversion is done, if Guile -is currently reading symbols case-insensitively. + string-filter +@c snarfed from srfi-13.c:3195 +@deffn {Scheme Procedure} string-filter s char_pred [start [end]] +@deffnx {C Function} scm_string_filter (s, char_pred, start, end) +Filter the string @var{s}, retaining only those characters that +satisfy the @var{char_pred} argument. If the argument is a +procedure, it is applied to each character as a predicate, if +it is a character, it is tested for equality and if it is a +character set, it is tested for membership. +@end deffn + + string-delete +@c snarfed from srfi-13.c:3265 +@deffn {Scheme Procedure} string-delete s char_pred [start [end]] +@deffnx {C Function} scm_string_delete (s, char_pred, start, end) +Filter the string @var{s}, retaining only those characters that +do not satisfy the @var{char_pred} argument. If the argument +is a procedure, it is applied to each character as a predicate, +if it is a character, it is tested for equality and if it is a +character set, it is tested for membership. +@end deffn + + char-set? +@c snarfed from srfi-14.c:85 +@deffn {Scheme Procedure} char-set? obj +@deffnx {C Function} scm_char_set_p (obj) +Return @code{#t} if @var{obj} is a character set, @code{#f} +otherwise. +@end deffn + + char-set= +@c snarfed from srfi-14.c:95 +@deffn {Scheme Procedure} char-set= . char_sets +@deffnx {C Function} scm_char_set_eq (char_sets) +Return @code{#t} if all given character sets are equal. +@end deffn + + char-set<= +@c snarfed from srfi-14.c:125 +@deffn {Scheme Procedure} char-set<= . char_sets +@deffnx {C Function} scm_char_set_leq (char_sets) +Return @code{#t} if every character set @var{cs}i is a subset +of character set @var{cs}i+1. +@end deffn + + char-set-hash +@c snarfed from srfi-14.c:163 +@deffn {Scheme Procedure} char-set-hash cs [bound] +@deffnx {C Function} scm_char_set_hash (cs, bound) +Compute a hash value for the character set @var{cs}. If +@var{bound} is given and non-zero, it restricts the +returned value to the range 0 @dots{} @var{bound - 1}. +@end deffn + + char-set-cursor +@c snarfed from srfi-14.c:196 +@deffn {Scheme Procedure} char-set-cursor cs +@deffnx {C Function} scm_char_set_cursor (cs) +Return a cursor into the character set @var{cs}. +@end deffn + + char-set-ref +@c snarfed from srfi-14.c:216 +@deffn {Scheme Procedure} char-set-ref cs cursor +@deffnx {C Function} scm_char_set_ref (cs, cursor) +Return the character at the current cursor position +@var{cursor} in the character set @var{cs}. It is an error to +pass a cursor for which @code{end-of-char-set?} returns true. +@end deffn + + char-set-cursor-next +@c snarfed from srfi-14.c:233 +@deffn {Scheme Procedure} char-set-cursor-next cs cursor +@deffnx {C Function} scm_char_set_cursor_next (cs, cursor) +Advance the character set cursor @var{cursor} to the next +character in the character set @var{cs}. It is an error if the +cursor given satisfies @code{end-of-char-set?}. +@end deffn + + end-of-char-set? +@c snarfed from srfi-14.c:254 +@deffn {Scheme Procedure} end-of-char-set? cursor +@deffnx {C Function} scm_end_of_char_set_p (cursor) +Return @code{#t} if @var{cursor} has reached the end of a +character set, @code{#f} otherwise. +@end deffn + + char-set-fold +@c snarfed from srfi-14.c:266 +@deffn {Scheme Procedure} char-set-fold kons knil cs +@deffnx {C Function} scm_char_set_fold (kons, knil, cs) +Fold the procedure @var{kons} over the character set @var{cs}, +initializing it with @var{knil}. +@end deffn + + char-set-unfold +@c snarfed from srfi-14.c:296 +@deffn {Scheme Procedure} char-set-unfold p f g seed [base_cs] +@deffnx {C Function} scm_char_set_unfold (p, f, g, seed, base_cs) +This is a fundamental constructor for character sets. +@itemize @bullet +@item @var{g} is used to generate a series of ``seed'' values +from the initial seed: @var{seed}, (@var{g} @var{seed}), +(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{} +@item @var{p} tells us when to stop -- when it returns true +when applied to one of the seed values. +@item @var{f} maps each seed value to a character. These +characters are added to the base character set @var{base_cs} to +form the result; @var{base_cs} defaults to the empty set. +@end itemize +@end deffn + + char-set-unfold! +@c snarfed from srfi-14.c:340 +@deffn {Scheme Procedure} char-set-unfold! p f g seed base_cs +@deffnx {C Function} scm_char_set_unfold_x (p, f, g, seed, base_cs) +This is a fundamental constructor for character sets. +@itemize @bullet +@item @var{g} is used to generate a series of ``seed'' values +from the initial seed: @var{seed}, (@var{g} @var{seed}), +(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{} +@item @var{p} tells us when to stop -- when it returns true +when applied to one of the seed values. +@item @var{f} maps each seed value to a character. These +characters are added to the base character set @var{base_cs} to +form the result; @var{base_cs} defaults to the empty set. +@end itemize +@end deffn + + char-set-for-each +@c snarfed from srfi-14.c:369 +@deffn {Scheme Procedure} char-set-for-each proc cs +@deffnx {C Function} scm_char_set_for_each (proc, cs) +Apply @var{proc} to every character in the character set +@var{cs}. The return value is not specified. +@end deffn + + char-set-map +@c snarfed from srfi-14.c:388 +@deffn {Scheme Procedure} char-set-map proc cs +@deffnx {C Function} scm_char_set_map (proc, cs) +Map the procedure @var{proc} over every character in @var{cs}. +@var{proc} must be a character -> character procedure. +@end deffn + + char-set-copy +@c snarfed from srfi-14.c:414 +@deffn {Scheme Procedure} char-set-copy cs +@deffnx {C Function} scm_char_set_copy (cs) +Return a newly allocated character set containing all +characters in @var{cs}. +@end deffn + + char-set +@c snarfed from srfi-14.c:434 +@deffn {Scheme Procedure} char-set . rest +@deffnx {C Function} scm_char_set (rest) +Return a character set containing all given characters. +@end deffn + + list->char-set +@c snarfed from srfi-14.c:462 +@deffn {Scheme Procedure} list->char-set list [base_cs] +@deffnx {C Function} scm_list_to_char_set (list, base_cs) +Convert the character list @var{list} to a character set. If +the character set @var{base_cs} is given, the character in this +set are also included in the result. +@end deffn + + list->char-set! +@c snarfed from srfi-14.c:496 +@deffn {Scheme Procedure} list->char-set! list base_cs +@deffnx {C Function} scm_list_to_char_set_x (list, base_cs) +Convert the character list @var{list} to a character set. The +characters are added to @var{base_cs} and @var{base_cs} is +returned. +@end deffn + + string->char-set +@c snarfed from srfi-14.c:523 +@deffn {Scheme Procedure} string->char-set str [base_cs] +@deffnx {C Function} scm_string_to_char_set (str, base_cs) +Convert the string @var{str} to a character set. If the +character set @var{base_cs} is given, the characters in this +set are also included in the result. +@end deffn + + string->char-set! +@c snarfed from srfi-14.c:557 +@deffn {Scheme Procedure} string->char-set! str base_cs +@deffnx {C Function} scm_string_to_char_set_x (str, base_cs) +Convert the string @var{str} to a character set. The +characters from the string are added to @var{base_cs}, and +@var{base_cs} is returned. +@end deffn + + char-set-filter +@c snarfed from srfi-14.c:584 +@deffn {Scheme Procedure} char-set-filter pred cs [base_cs] +@deffnx {C Function} scm_char_set_filter (pred, cs, base_cs) +Return a character set containing every character from @var{cs} +so that it satisfies @var{pred}. If provided, the characters +from @var{base_cs} are added to the result. +@end deffn + + char-set-filter! +@c snarfed from srfi-14.c:620 +@deffn {Scheme Procedure} char-set-filter! pred cs base_cs +@deffnx {C Function} scm_char_set_filter_x (pred, cs, base_cs) +Return a character set containing every character from @var{cs} +so that it satisfies @var{pred}. The characters are added to +@var{base_cs} and @var{base_cs} is returned. +@end deffn + + ucs-range->char-set +@c snarfed from srfi-14.c:658 +@deffn {Scheme Procedure} ucs-range->char-set lower upper [error [base_cs]] +@deffnx {C Function} scm_ucs_range_to_char_set (lower, upper, error, base_cs) +Return a character set containing all characters whose +character codes lie in the half-open range +[@var{lower},@var{upper}). + +If @var{error} is a true value, an error is signalled if the +specified range contains characters which are not contained in +the implemented character range. If @var{error} is @code{#f}, +these characters are silently left out of the resultung +character set. + +The characters in @var{base_cs} are added to the result, if +given. +@end deffn + + ucs-range->char-set! +@c snarfed from srfi-14.c:711 +@deffn {Scheme Procedure} ucs-range->char-set! lower upper error base_cs +@deffnx {C Function} scm_ucs_range_to_char_set_x (lower, upper, error, base_cs) +Return a character set containing all characters whose +character codes lie in the half-open range +[@var{lower},@var{upper}). + +If @var{error} is a true value, an error is signalled if the +specified range contains characters which are not contained in +the implemented character range. If @var{error} is @code{#f}, +these characters are silently left out of the resultung +character set. + +The characters are added to @var{base_cs} and @var{base_cs} is +returned. +@end deffn + + ->char-set +@c snarfed from srfi-14.c:741 +@deffn {Scheme Procedure} ->char-set x +@deffnx {C Function} scm_to_char_set (x) +Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is. +@end deffn + + char-set-size +@c snarfed from srfi-14.c:757 +@deffn {Scheme Procedure} char-set-size cs +@deffnx {C Function} scm_char_set_size (cs) +Return the number of elements in character set @var{cs}. +@end deffn + + char-set-count +@c snarfed from srfi-14.c:774 +@deffn {Scheme Procedure} char-set-count pred cs +@deffnx {C Function} scm_char_set_count (pred, cs) +Return the number of the elements int the character set +@var{cs} which satisfy the predicate @var{pred}. +@end deffn + + char-set->list +@c snarfed from srfi-14.c:797 +@deffn {Scheme Procedure} char-set->list cs +@deffnx {C Function} scm_char_set_to_list (cs) +Return a list containing the elements of the character set +@var{cs}. +@end deffn + + char-set->string +@c snarfed from srfi-14.c:816 +@deffn {Scheme Procedure} char-set->string cs +@deffnx {C Function} scm_char_set_to_string (cs) +Return a string containing the elements of the character set +@var{cs}. The order in which the characters are placed in the +string is not defined. +@end deffn + + char-set-contains? +@c snarfed from srfi-14.c:841 +@deffn {Scheme Procedure} char-set-contains? cs ch +@deffnx {C Function} scm_char_set_contains_p (cs, ch) +Return @code{#t} iff the character @var{ch} is contained in the +character set @var{cs}. +@end deffn + + char-set-every +@c snarfed from srfi-14.c:854 +@deffn {Scheme Procedure} char-set-every pred cs +@deffnx {C Function} scm_char_set_every (pred, cs) +Return a true value if every character in the character set +@var{cs} satisfies the predicate @var{pred}. +@end deffn + + char-set-any +@c snarfed from srfi-14.c:878 +@deffn {Scheme Procedure} char-set-any pred cs +@deffnx {C Function} scm_char_set_any (pred, cs) +Return a true value if any character in the character set +@var{cs} satisfies the predicate @var{pred}. +@end deffn + + char-set-adjoin +@c snarfed from srfi-14.c:901 +@deffn {Scheme Procedure} char-set-adjoin cs . rest +@deffnx {C Function} scm_char_set_adjoin (cs, rest) +Add all character arguments to the first argument, which must +be a character set. +@end deffn + + char-set-delete +@c snarfed from srfi-14.c:929 +@deffn {Scheme Procedure} char-set-delete cs . rest +@deffnx {C Function} scm_char_set_delete (cs, rest) +Delete all character arguments from the first argument, which +must be a character set. +@end deffn + + char-set-adjoin! +@c snarfed from srfi-14.c:957 +@deffn {Scheme Procedure} char-set-adjoin! cs . rest +@deffnx {C Function} scm_char_set_adjoin_x (cs, rest) +Add all character arguments to the first argument, which must +be a character set. +@end deffn + + char-set-delete! +@c snarfed from srfi-14.c:984 +@deffn {Scheme Procedure} char-set-delete! cs . rest +@deffnx {C Function} scm_char_set_delete_x (cs, rest) +Delete all character arguments from the first argument, which +must be a character set. +@end deffn + + char-set-complement +@c snarfed from srfi-14.c:1010 +@deffn {Scheme Procedure} char-set-complement cs +@deffnx {C Function} scm_char_set_complement (cs) +Return the complement of the character set @var{cs}. +@end deffn + + char-set-union +@c snarfed from srfi-14.c:1031 +@deffn {Scheme Procedure} char-set-union . rest +@deffnx {C Function} scm_char_set_union (rest) +Return the union of all argument character sets. +@end deffn + + char-set-intersection +@c snarfed from srfi-14.c:1060 +@deffn {Scheme Procedure} char-set-intersection . rest +@deffnx {C Function} scm_char_set_intersection (rest) +Return the intersection of all argument character sets. +@end deffn + + char-set-difference +@c snarfed from srfi-14.c:1100 +@deffn {Scheme Procedure} char-set-difference cs1 . rest +@deffnx {C Function} scm_char_set_difference (cs1, rest) +Return the difference of all argument character sets. +@end deffn + + char-set-xor +@c snarfed from srfi-14.c:1130 +@deffn {Scheme Procedure} char-set-xor . rest +@deffnx {C Function} scm_char_set_xor (rest) +Return the exclusive-or of all argument character sets. +@end deffn + + char-set-diff+intersection +@c snarfed from srfi-14.c:1171 +@deffn {Scheme Procedure} char-set-diff+intersection cs1 . rest +@deffnx {C Function} scm_char_set_diff_plus_intersection (cs1, rest) +Return the difference and the intersection of all argument +character sets. +@end deffn + + char-set-complement! +@c snarfed from srfi-14.c:1209 +@deffn {Scheme Procedure} char-set-complement! cs +@deffnx {C Function} scm_char_set_complement_x (cs) +Return the complement of the character set @var{cs}. +@end deffn + + char-set-union! +@c snarfed from srfi-14.c:1226 +@deffn {Scheme Procedure} char-set-union! cs1 . rest +@deffnx {C Function} scm_char_set_union_x (cs1, rest) +Return the union of all argument character sets. +@end deffn + + char-set-intersection! +@c snarfed from srfi-14.c:1254 +@deffn {Scheme Procedure} char-set-intersection! cs1 . rest +@deffnx {C Function} scm_char_set_intersection_x (cs1, rest) +Return the intersection of all argument character sets. +@end deffn + + char-set-difference! +@c snarfed from srfi-14.c:1282 +@deffn {Scheme Procedure} char-set-difference! cs1 . rest +@deffnx {C Function} scm_char_set_difference_x (cs1, rest) +Return the difference of all argument character sets. +@end deffn + + char-set-xor! +@c snarfed from srfi-14.c:1310 +@deffn {Scheme Procedure} char-set-xor! cs1 . rest +@deffnx {C Function} scm_char_set_xor_x (cs1, rest) +Return the exclusive-or of all argument character sets. +@end deffn + + char-set-diff+intersection! +@c snarfed from srfi-14.c:1349 +@deffn {Scheme Procedure} char-set-diff+intersection! cs1 cs2 . rest +@deffnx {C Function} scm_char_set_diff_plus_intersection_x (cs1, cs2, rest) +Return the difference and the intersection of all argument +character sets. @end deffn string=? -@c snarfed from strorder.c:38 +@c snarfed from strorder.c:50 @deffn {Scheme Procedure} string=? s1 s2 Lexicographic equality predicate; return @code{#t} if the two strings are the same length and contain the same characters in @@ -5217,7 +6375,7 @@ characters. @end deffn string-ci=? -@c snarfed from strorder.c:77 +@c snarfed from strorder.c:62 @deffn {Scheme Procedure} string-ci=? s1 s2 Case-insensitive string equality predicate; return @code{#t} if the two strings are the same length and their component @@ -5226,35 +6384,35 @@ return @code{#f}. @end deffn string? -@c snarfed from strorder.c:168 +@c snarfed from strorder.c:92 @deffn {Scheme Procedure} string>? s1 s2 Lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than @var{s2}. @end deffn string>=? -@c snarfed from strorder.c:182 +@c snarfed from strorder.c:102 @deffn {Scheme Procedure} string>=? s1 s2 Lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than or equal to @var{s2}. @end deffn string-ci? -@c snarfed from strorder.c:253 +@c snarfed from strorder.c:135 @deffn {Scheme Procedure} string-ci>? s1 s2 Case insensitive lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than @@ -5278,7 +6436,7 @@ Case insensitive lexicographic ordering predicate; return @end deffn string-ci>=? -@c snarfed from strorder.c:268 +@c snarfed from strorder.c:146 @deffn {Scheme Procedure} string-ci>=? s1 s2 Case insensitive lexicographic ordering predicate; return @code{#t} if @var{s1} is lexicographically greater than or @@ -5530,7 +6688,7 @@ Set the name of the vtable @var{vtable} to @var{name}. @end deffn symbol? -@c snarfed from symbols.c:156 +@c snarfed from symbols.c:158 @deffn {Scheme Procedure} symbol? obj @deffnx {C Function} scm_symbol_p (obj) Return @code{#t} if @var{obj} is a symbol, otherwise return @@ -5538,7 +6696,7 @@ Return @code{#t} if @var{obj} is a symbol, otherwise return @end deffn symbol-interned? -@c snarfed from symbols.c:166 +@c snarfed from symbols.c:168 @deffn {Scheme Procedure} symbol-interned? symbol @deffnx {C Function} scm_symbol_interned_p (symbol) Return @code{#t} if @var{symbol} is interned, otherwise return @@ -5546,14 +6704,14 @@ Return @code{#t} if @var{symbol} is interned, otherwise return @end deffn make-symbol -@c snarfed from symbols.c:178 +@c snarfed from symbols.c:180 @deffn {Scheme Procedure} make-symbol name @deffnx {C Function} scm_make_symbol (name) Return a new uninterned symbol with the name @var{name}. The returned symbol is guaranteed to be unique and future calls to @code{string->symbol} will not return it. @end deffn symbol->string -@c snarfed from symbols.c:210 +@c snarfed from symbols.c:212 @deffn {Scheme Procedure} symbol->string s @deffnx {C Function} scm_symbol_to_string (s) Return the name of @var{symbol} as a string. If the symbol was @@ -5582,7 +6740,7 @@ standard case is lower case: @end deffn string->symbol -@c snarfed from symbols.c:240 +@c snarfed from symbols.c:242 @deffn {Scheme Procedure} string->symbol string @deffnx {C Function} scm_string_to_symbol (string) Return the symbol whose name is @var{string}. This procedure @@ -5607,8 +6765,17 @@ standard case is lower case: @end lisp @end deffn + string-ci->symbol +@c snarfed from symbols.c:254 +@deffn {Scheme Procedure} string-ci->symbol str +@deffnx {C Function} scm_string_ci_to_symbol (str) +Return the symbol whose name is @var{str}. @var{str} is +converted to lowercase before the conversion is done, if Guile +is currently reading symbols case-insensitively. +@end deffn + gensym -@c snarfed from symbols.c:256 +@c snarfed from symbols.c:271 @deffn {Scheme Procedure} gensym [prefix] @deffnx {C Function} scm_gensym (prefix) Create a new symbol with a name constructed from a prefix and @@ -5619,35 +6786,35 @@ resetting the counter. @end deffn symbol-hash -@c snarfed from symbols.c:282 +@c snarfed from symbols.c:297 @deffn {Scheme Procedure} symbol-hash symbol @deffnx {C Function} scm_symbol_hash (symbol) Return a hash value for @var{symbol}. @end deffn symbol-fref -@c snarfed from symbols.c:292 +@c snarfed from symbols.c:307 @deffn {Scheme Procedure} symbol-fref s @deffnx {C Function} scm_symbol_fref (s) Return the contents of @var{symbol}'s @dfn{function slot}. @end deffn symbol-pref -@c snarfed from symbols.c:303 +@c snarfed from symbols.c:318 @deffn {Scheme Procedure} symbol-pref s @deffnx {C Function} scm_symbol_pref (s) Return the @dfn{property list} currently associated with @var{symbol}. @end deffn symbol-fset! -@c snarfed from symbols.c:314 +@c snarfed from symbols.c:329 @deffn {Scheme Procedure} symbol-fset! s val @deffnx {C Function} scm_symbol_fset_x (s, val) Change the binding of @var{symbol}'s function slot. @end deffn symbol-pset! -@c snarfed from symbols.c:326 +@c snarfed from symbols.c:341 @deffn {Scheme Procedure} symbol-pset! s val @deffnx {C Function} scm_symbol_pset_x (s, val) Change the binding of @var{symbol}'s property slot. From f2b9c48b648c8ab9817af446b27d9411758e0328 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 13:39:26 +0000 Subject: [PATCH 078/100] Left inf? in its place, since wants to be here so much. --- doc/ref/new-docstrings.texi | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/doc/ref/new-docstrings.texi b/doc/ref/new-docstrings.texi index f97d181ee..f3ea72758 100644 --- a/doc/ref/new-docstrings.texi +++ b/doc/ref/new-docstrings.texi @@ -1,5 +1,13 @@ @c module-for-docstring (guile) +@c This one crops up here constantly although it is already +@c in api-data.texi. Have to investigate somewhen. + +@deffn {Scheme Procedure} inf? x +@deffnx {C Function} scm_inf_p (x) +Return @code{#t} if @var{x} is either @samp{+inf.0} +or @samp{-inf.0}, @code{#f} otherwise. +@end deffn From 5676b4fab788cf5cd02e51d3a368ae40448b1acf Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 13:40:21 +0000 Subject: [PATCH 079/100] Moved docs for SRFI-14 into main API chapter. Updated docstrings from libguile/. --- doc/ref/api-data.texi | 808 ++++++++++++++++++++++++++++++++++---- doc/ref/srfi-modules.texi | 687 +------------------------------- 2 files changed, 724 insertions(+), 771 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 117abd23d..8d429ef91 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1800,42 +1800,36 @@ Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the @deffn {Scheme Procedure} char-alphabetic? chr @deffnx {C Function} scm_char_alphabetic_p (chr) Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}. -Alphabetic means the same thing as the @code{isalpha} C library function. @end deffn @rnindex char-numeric? @deffn {Scheme Procedure} char-numeric? chr @deffnx {C Function} scm_char_numeric_p (chr) Return @code{#t} iff @var{chr} is numeric, else @code{#f}. -Numeric means the same thing as the @code{isdigit} C library function. @end deffn @rnindex char-whitespace? @deffn {Scheme Procedure} char-whitespace? chr @deffnx {C Function} scm_char_whitespace_p (chr) Return @code{#t} iff @var{chr} is whitespace, else @code{#f}. -Whitespace means the same thing as the @code{isspace} C library function. @end deffn @rnindex char-upper-case? @deffn {Scheme Procedure} char-upper-case? chr @deffnx {C Function} scm_char_upper_case_p (chr) Return @code{#t} iff @var{chr} is uppercase, else @code{#f}. -Uppercase means the same thing as the @code{isupper} C library function. @end deffn @rnindex char-lower-case? @deffn {Scheme Procedure} char-lower-case? chr @deffnx {C Function} scm_char_lower_case_p (chr) Return @code{#t} iff @var{chr} is lowercase, else @code{#f}. -Lowercase means the same thing as the @code{islower} C library function. @end deffn @deffn {Scheme Procedure} char-is-both? chr @deffnx {C Function} scm_char_is_both_p (chr) Return @code{#t} iff @var{chr} is either uppercase or lowercase, else -@code{#f}. Uppercase and lowercase are as defined by the -@code{isupper} and @code{islower} C library functions. +@code{#f}. @end deffn @rnindex char->integer @@ -2380,16 +2374,18 @@ substrings} since the substring and the original string share modifications to each other. @menu -* String Syntax:: Read syntax for strings. -* String Predicates:: Testing strings for certain properties. -* String Constructors:: Creating new string objects. -* List/String Conversion:: Converting from/to lists of characters. -* String Selection:: Select portions from strings. -* String Modification:: Modify parts or whole strings. -* String Comparison:: Lexicographic ordering predicates. -* String Searching:: Searching in strings. -* Alphabetic Case Mapping:: Convert the alphabetic case of strings. -* Appending Strings:: Appending strings to form a new string. +* String Syntax:: Read syntax for strings. +* String Predicates:: Testing strings for certain properties. +* String Constructors:: Creating new string objects. +* List/String Conversion:: Converting from/to lists of characters. +* String Selection:: Select portions from strings. +* String Modification:: Modify parts or whole strings. +* String Comparison:: Lexicographic ordering predicates. +* String Searching:: Searching in strings. +* Alphabetic Case Mapping:: Convert the alphabetic case of strings. +* Reversing and Appending Strings:: Appending strings to form a new string. +* Mapping Folding and Unfolding:: Iterating over strings. +* Miscellaneous String Operations:: Replicating, insertion, parsing, ... * Conversion to/from C:: @end menu @@ -2481,6 +2477,40 @@ y @result{} "foo" @end lisp @end deffn +@deffn {Scheme Procedure} string-any char_pred s [start [end]] +@deffnx {C Function} scm_string_any (char_pred, s, start, end) +Check if the predicate @var{pred} is true for any character in +the string @var{s}. + +Calls to @var{pred} are made from left to right across @var{s}. +When it returns true (ie.@: non-@code{#f}), that return value +is the return from @code{string-any}. + +The SRFI-13 specification requires that the call to @var{pred} +on the last character of @var{s} (assuming that point is +reached) be a tail call, but currently in Guile this is not the +case. +@end deffn + +@deffn {Scheme Procedure} string-every char_pred s [start [end]] +@deffnx {C Function} scm_string_every (char_pred, s, start, end) +Check if the predicate @var{pred} is true for every character +in the string @var{s}. + +Calls to @var{pred} are made from left to right across @var{s}. +If the predicate is true for every character then the return +value from the last @var{pred} call is the return from +@code{string-every}. + +If there are no characters in @var{s} (ie.@: @var{start} equals +@var{end}) then the return is @code{#t}. + +The SRFI-13 specification requires that the call to @var{pred} +on the last character of @var{s} (assuming that point is +reached) be a tail call, but currently in Guile this is not the +case. +@end deffn + @node String Constructors @subsubsection String Constructors @@ -2514,6 +2544,46 @@ Like @code{scm_make_string}, but expects the length as a @code{size_t}. @end deftypefn +@deffn {Scheme Procedure} string-tabulate proc len +@deffnx {C Function} scm_string_tabulate (proc, len) +@var{proc} is an integer->char procedure. Construct a string +of size @var{len} by applying @var{proc} to each index to +produce the corresponding string element. The order in which +@var{proc} is applied to the indices is not specified. +@end deffn + +@deffn {Scheme Procedure} reverse-list->string chrs +@deffnx {C Function} scm_reverse_list_to_string (chrs) +An efficient implementation of @code{(compose string->list +reverse)}: + +@smalllisp +(reverse-list->string '(#\a #\B #\c)) @result{} "cBa" +@end smalllisp +@end deffn + +@deffn {Scheme Procedure} string-join ls [delimiter [grammar]] +@deffnx {C Function} scm_string_join (ls, delimiter, grammar) +Append the string in the string list @var{ls}, using the string +@var{delim} as a delimiter between the elements of @var{ls}. +@var{grammar} is a symbol which specifies how the delimiter is +placed between the strings, and defaults to the symbol +@code{infix}. + +@table @code +@item infix +Insert the separator between list elements. An empty string +will produce an empty list. +@item string-infix +Like @code{infix}, but will raise an error if given the empty +list. +@item suffix +Insert the separator after every list element. +@item prefix +Insert the separator before each list element. +@end table +@end deffn + @node List/String Conversion @subsubsection List/String conversion @@ -2523,12 +2593,10 @@ work with the resulting list, and then convert it back into a string. These procedures are useful for similar tasks. @rnindex string->list -@deffn {Scheme Procedure} string->list str +@deffn {Scheme Procedure} string->list str [start [end]] +@deffnx {C Function} scm_substring_to_list (str, start, end) @deffnx {C Function} scm_string_to_list (str) -Return a newly allocated list of the characters that make up -the given string @var{str}. @code{string->list} and -@code{list->string} are inverses as far as @samp{equal?} is -concerned. +Convert the string @var{str} into a list of characters. @end deffn @deffn {Scheme Procedure} string-split str chr @@ -2584,9 +2652,10 @@ indexing. @var{k} must be a valid index of @var{str}. @end deftypefn @rnindex string-copy -@deffn {Scheme Procedure} string-copy str +@deffn {Scheme Procedure} string-copy str [start [end]] +@deffnx {C Function} scm_substring_copy (str, start, end) @deffnx {C Function} scm_string_copy (str) -Return a copy of the given @var{string}. +Return a copy of the given string @var{str}. The returned string shares storage with @var{str} initially, but it is copied as soon as one of the two strings is modified. @@ -2626,6 +2695,110 @@ immediately. Like @code{scm_substring}, etc. but the bounds are given as a @code{size_t}. @end deftypefn +@deffn {Scheme Procedure} string-take s n +@deffnx {C Function} scm_string_take (s, n) +Return the @var{n} first characters of @var{s}. +@end deffn + +@deffn {Scheme Procedure} string-drop s n +@deffnx {C Function} scm_string_drop (s, n) +Return all but the first @var{n} characters of @var{s}. +@end deffn + +@deffn {Scheme Procedure} string-take-right s n +@deffnx {C Function} scm_string_take_right (s, n) +Return the @var{n} last characters of @var{s}. +@end deffn + +@deffn {Scheme Procedure} string-drop-right s n +@deffnx {C Function} scm_string_drop_right (s, n) +Return all but the last @var{n} characters of @var{s}. +@end deffn + +@deffn {Scheme Procedure} string-pad s len [chr [start [end]]] +@deffnx {C Function} scm_string_pad (s, len, chr, start, end) +Take that characters from @var{start} to @var{end} from the +string @var{s} and return a new string, right-padded by the +character @var{chr} to length @var{len}. If the resulting +string is longer than @var{len}, it is truncated on the right. +@end deffn + +@deffn {Scheme Procedure} string-pad-right s len [chr [start [end]]] +@deffnx {C Function} scm_string_pad_right (s, len, chr, start, end) +Take that characters from @var{start} to @var{end} from the +string @var{s} and return a new string, left-padded by the +character @var{chr} to length @var{len}. If the resulting +string is longer than @var{len}, it is truncated on the left. +@end deffn + +@deffn {Scheme Procedure} string-trim s [char_pred [start [end]]] +@deffnx {C Function} scm_string_trim (s, char_pred, start, end) +Trim @var{s} by skipping over all characters on the left +that satisfy the parameter @var{char_pred}: + +@itemize @bullet +@item +if it is the character @var{ch}, characters equal to +@var{ch} are trimmed, + +@item +if it is a procedure @var{pred} characters that +satisfy @var{pred} are trimmed, + +@item +if it is a character set, characters in that set are trimmed. +@end itemize + +If called without a @var{char_pred} argument, all whitespace is +trimmed. +@end deffn + +@deffn {Scheme Procedure} string-trim-right s [char_pred [start [end]]] +@deffnx {C Function} scm_string_trim_right (s, char_pred, start, end) +Trim @var{s} by skipping over all characters on the rightt +that satisfy the parameter @var{char_pred}: + +@itemize @bullet +@item +if it is the character @var{ch}, characters equal to @var{ch} +are trimmed, + +@item +if it is a procedure @var{pred} characters that satisfy +@var{pred} are trimmed, + +@item +if it is a character sets, all characters in that set are +trimmed. +@end itemize + +If called without a @var{char_pred} argument, all whitespace is +trimmed. +@end deffn + +@deffn {Scheme Procedure} string-trim-both s [char_pred [start [end]]] +@deffnx {C Function} scm_string_trim_both (s, char_pred, start, end) +Trim @var{s} by skipping over all characters on both sides of +the string that satisfy the parameter @var{char_pred}: + +@itemize @bullet +@item +if it is the character @var{ch}, characters equal to @var{ch} +are trimmed, + +@item +if it is a procedure @var{pred} characters that satisfy +@var{pred} are trimmed, + +@item +if it is a character set, the characters in the set are +trimmed. +@end itemize + +If called without a @var{char_pred} argument, all whitespace is +trimmed. +@end deffn + @node String Modification @subsubsection String Modification @@ -2646,10 +2819,11 @@ Like @code{scm_string_set_x}, but the index is given as a @code{size_t}. @end deftypefn @rnindex string-fill! -@deffn {Scheme Procedure} string-fill! str chr +@deffn {Scheme Procedure} string-fill! str chr [start [end]] +@deffnx {C Function} scm_substring_fill_x (str, chr, start, end) @deffnx {C Function} scm_string_fill_x (str, chr) -Store @var{char} in every element of the given @var{string} and -return an unspecified value. +Stores @var{chr} in every element of the given @var{str} and +returns an unspecified value. @end deffn @deffn {Scheme Procedure} substring-fill! str start end fill @@ -2672,16 +2846,28 @@ into @var{str2} beginning at position @var{start2}. @var{str1} and @var{str2} can be the same string. @end deffn +@deffn {Scheme Procedure} string-copy! target tstart s [start [end]] +@deffnx {C Function} scm_string_copy_x (target, tstart, s, start, end) +Copy the sequence of characters from index range [@var{start}, +@var{end}) in string @var{s} to string @var{target}, beginning +at index @var{tstart}. The characters are copied left-to-right +or right-to-left as needed -- the copy is guaranteed to work, +even if @var{target} and @var{s} are the same string. It is an +error if the copy operation runs off the end of the target +string. +@end deffn + @node String Comparison @subsubsection String Comparison The procedures in this section are similar to the character ordering predicates (@pxref{Characters}), but are defined on character sequences. -They all return @code{#t} on success and @code{#f} on failure. The -predicates ending in @code{-ci} ignore the character case when comparing -strings. +The first set is specified in R5RS and has names that end in @code{?}. +The second set is specified in SRFI-13 and the names have no ending +@code{?}. The predicates ending in @code{-ci} ignore the character case +when comparing strings. @rnindex string=? @deffn {Scheme Procedure} string=? s1 s2 @@ -2727,7 +2913,7 @@ characters match (ignoring case) at each position; otherwise return @code{#f}. @end deffn -@rnindex string-ci< +@rnindex string-ci s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_neq (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} and @var{s2} are equal, a true +value otherwise. +@end deffn + +@deffn {Scheme Procedure} string< s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_lt (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a +true value otherwise. +@end deffn + +@deffn {Scheme Procedure} string> s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_gt (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is less or equal to @var{s2}, a +true value otherwise. +@end deffn + +@deffn {Scheme Procedure} string<= s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_le (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is greater to @var{s2}, a true +value otherwise. +@end deffn + +@deffn {Scheme Procedure} string>= s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ge (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is less to @var{s2}, a true value +otherwise. +@end deffn + +@deffn {Scheme Procedure} string-ci= s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ci_eq (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} and @var{s2} are not equal, a true +value otherwise. The character comparison is done +case-insensitively. +@end deffn + +@deffn {Scheme Procedure} string-ci<> s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ci_neq (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} and @var{s2} are equal, a true +value otherwise. The character comparison is done +case-insensitively. +@end deffn + +@deffn {Scheme Procedure} string-ci< s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ci_lt (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a +true value otherwise. The character comparison is done +case-insensitively. +@end deffn + +@deffn {Scheme Procedure} string-ci> s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ci_gt (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is less or equal to @var{s2}, a +true value otherwise. The character comparison is done +case-insensitively. +@end deffn + +@deffn {Scheme Procedure} string-ci<= s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ci_le (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is greater to @var{s2}, a true +value otherwise. The character comparison is done +case-insensitively. +@end deffn + +@deffn {Scheme Procedure} string-ci>= s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_ci_ge (s1, s2, start1, end1, start2, end2) +Return @code{#f} if @var{s1} is less to @var{s2}, a true value +otherwise. The character comparison is done +case-insensitively. +@end deffn + +@deffn {Scheme Procedure} string-hash s [bound [start [end]]] +@deffnx {C Function} scm_substring_hash (s, bound, start, end) +Compute a hash value for @var{S}. the optional argument @var{bound} is a non-negative exact integer specifying the range of the hash function. A positive value restricts the return value to the range [0,bound). +@end deffn + +@deffn {Scheme Procedure} string-hash-ci s [bound [start [end]]] +@deffnx {C Function} scm_substring_hash_ci (s, bound, start, end) +Compute a hash value for @var{S}. the optional argument @var{bound} is a non-negative exact integer specifying the range of the hash function. A positive value restricts the return value to the range [0,bound). +@end deffn @node String Searching @subsubsection String Searching -When searching for the index of a character in a string, these -procedures can be used. +@deffn {Scheme Procedure} string-index s char_pred [start [end]] +@deffnx {C Function} scm_string_index (s, char_pred, start, end) +Search through the string @var{s} from left to right, returning +the index of the first occurence of a character which -@deffn {Scheme Procedure} string-index str chr [frm [to]] -@deffnx {C Function} scm_string_index (str, chr, frm, to) -Return the index of the first occurrence of @var{chr} in -@var{str}. The optional integer arguments @var{frm} and -@var{to} limit the search to a portion of the string. This -procedure essentially implements the @code{index} or -@code{strchr} functions from the C library. +@itemize @bullet +@item +equals @var{char_pred}, if it is character, -@lisp -(string-index "weiner" #\e) -@result{} 1 +@item +satisifies the predicate @var{char_pred}, if it is a procedure, -(string-index "weiner" #\e 2) -@result{} 4 - -(string-index "weiner" #\e 2 4) -@result{} #f -@end lisp +@item +is in the set @var{char_pred}, if it is a character set. +@end itemize @end deffn -@deffn {Scheme Procedure} string-rindex str chr [frm [to]] -@deffnx {C Function} scm_string_rindex (str, chr, frm, to) -Like @code{string-index}, but search from the right of the -string rather than from the left. This procedure essentially -implements the @code{rindex} or @code{strrchr} functions from -the C library. +@deffn {Scheme Procedure} string-rindex s char_pred [start [end]] +@deffnx {C Function} scm_string_rindex (s, char_pred, start, end) +Search through the string @var{s} from right to left, returning +the index of the last occurence of a character which -@lisp -(string-rindex "weiner" #\e) -@result{} 4 +@itemize @bullet +@item +equals @var{char_pred}, if it is character, -(string-rindex "weiner" #\e 2 4) -@result{} #f +@item +satisifies the predicate @var{char_pred}, if it is a procedure, -(string-rindex "weiner" #\e 2 5) -@result{} 4 -@end lisp +@item +is in the set if @var{char_pred} is a character set. +@end itemize +@end deffn + +@deffn {Scheme Procedure} string-prefix-length s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_prefix_length (s1, s2, start1, end1, start2, end2) +Return the length of the longest common prefix of the two +strings. +@end deffn + +@deffn {Scheme Procedure} string-prefix-length-ci s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_prefix_length_ci (s1, s2, start1, end1, start2, end2) +Return the length of the longest common prefix of the two +strings, ignoring character case. +@end deffn + +@deffn {Scheme Procedure} string-suffix-length s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_suffix_length (s1, s2, start1, end1, start2, end2) +Return the length of the longest common suffix of the two +strings. +@end deffn + +@deffn {Scheme Procedure} string-suffix-length-ci s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_suffix_length_ci (s1, s2, start1, end1, start2, end2) +Return the length of the longest common suffix of the two +strings, ignoring character case. +@end deffn + +@deffn {Scheme Procedure} string-prefix? s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_prefix_p (s1, s2, start1, end1, start2, end2) +Is @var{s1} a prefix of @var{s2}? +@end deffn + +@deffn {Scheme Procedure} string-prefix-ci? s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_prefix_ci_p (s1, s2, start1, end1, start2, end2) +Is @var{s1} a prefix of @var{s2}, ignoring character case? +@end deffn + +@deffn {Scheme Procedure} string-suffix? s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_suffix_p (s1, s2, start1, end1, start2, end2) +Is @var{s1} a suffix of @var{s2}? +@end deffn + +@deffn {Scheme Procedure} string-suffix-ci? s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_suffix_ci_p (s1, s2, start1, end1, start2, end2) +Is @var{s1} a suffix of @var{s2}, ignoring character case? +@end deffn + +@deffn {Scheme Procedure} string-index-right s char_pred [start [end]] +@deffnx {C Function} scm_string_index_right (s, char_pred, start, end) +Search through the string @var{s} from right to left, returning +the index of the last occurence of a character which + +@itemize @bullet +@item +equals @var{char_pred}, if it is character, + +@item +satisifies the predicate @var{char_pred}, if it is a procedure, + +@item +is in the set if @var{char_pred} is a character set. +@end itemize +@end deffn + +@deffn {Scheme Procedure} string-skip s char_pred [start [end]] +@deffnx {C Function} scm_string_skip (s, char_pred, start, end) +Search through the string @var{s} from left to right, returning +the index of the first occurence of a character which + +@itemize @bullet +@item +does not equal @var{char_pred}, if it is character, + +@item +does not satisify the predicate @var{char_pred}, if it is a +procedure, + +@item +is not in the set if @var{char_pred} is a character set. +@end itemize +@end deffn + +@deffn {Scheme Procedure} string-skip-right s char_pred [start [end]] +@deffnx {C Function} scm_string_skip_right (s, char_pred, start, end) +Search through the string @var{s} from right to left, returning +the index of the last occurence of a character which + +@itemize @bullet +@item +does not equal @var{char_pred}, if it is character, + +@item +does not satisfy the predicate @var{char_pred}, if it is a +procedure, + +@item +is not in the set if @var{char_pred} is a character set. +@end itemize +@end deffn + +@deffn {Scheme Procedure} string-count s char_pred [start [end]] +@deffnx {C Function} scm_string_count (s, char_pred, start, end) +Return the count of the number of characters in the string +@var{s} which + +@itemize @bullet +@item +equals @var{char_pred}, if it is character, + +@item +satisifies the predicate @var{char_pred}, if it is a procedure. + +@item +is in the set @var{char_pred}, if it is a character set. +@end itemize +@end deffn + +@deffn {Scheme Procedure} string-contains s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_contains (s1, s2, start1, end1, start2, end2) +Does string @var{s1} contain string @var{s2}? Return the index +in @var{s1} where @var{s2} occurs as a substring, or false. +The optional start/end indices restrict the operation to the +indicated substrings. +@end deffn + +@deffn {Scheme Procedure} string-contains-ci s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_contains_ci (s1, s2, start1, end1, start2, end2) +Does string @var{s1} contain string @var{s2}? Return the index +in @var{s1} where @var{s2} occurs as a substring, or false. +The optional start/end indices restrict the operation to the +indicated substrings. Character comparison is done +case-insensitively. @end deffn @node Alphabetic Case Mapping @@ -2807,37 +3224,43 @@ the C library. These are procedures for mapping strings to their upper- or lower-case equivalents, respectively, or for capitalizing strings. -@deffn {Scheme Procedure} string-upcase str +@deffn {Scheme Procedure} string-upcase str [start [end]] +@deffnx {C Function} scm_substring_upcase (str, start, end) @deffnx {C Function} scm_string_upcase (str) -Return a freshly allocated string containing the characters of -@var{str} in upper case. +Upcase every character in @code{str}. @end deffn -@deffn {Scheme Procedure} string-upcase! str +@deffn {Scheme Procedure} string-upcase! str [start [end]] +@deffnx {C Function} scm_substring_upcase_x (str, start, end) @deffnx {C Function} scm_string_upcase_x (str) -Destructively upcase every character in @var{str} and return -@var{str}. +Destructively upcase every character in @code{str}. + @lisp -y @result{} "arrdefg" -(string-upcase! y) @result{} "ARRDEFG" -y @result{} "ARRDEFG" +(string-upcase! y) +@result{} "ARRDEFG" +y +@result{} "ARRDEFG" @end lisp @end deffn -@deffn {Scheme Procedure} string-downcase str +@deffn {Scheme Procedure} string-downcase str [start [end]] +@deffnx {C Function} scm_substring_downcase (str, start, end) @deffnx {C Function} scm_string_downcase (str) -Return a freshly allocation string containing the characters in -@var{str} in lower case. +Downcase every character in @var{str}. @end deffn -@deffn {Scheme Procedure} string-downcase! str +@deffn {Scheme Procedure} string-downcase! str [start [end]] +@deffnx {C Function} scm_substring_downcase_x (str, start, end) @deffnx {C Function} scm_string_downcase_x (str) -Destructively downcase every character in @var{str} and return -@var{str}. +Destructively downcase every character in @var{str}. + @lisp -y @result{} "ARRDEFG" -(string-downcase! y) @result{} "arrdefg" -y @result{} "arrdefg" +y +@result{} "ARRDEFG" +(string-downcase! y) +@result{} "arrdefg" +y +@result{} "arrdefg" @end lisp @end deffn @@ -2860,12 +3283,33 @@ y @result{} "Hello World" @end lisp @end deffn +@deffn {Scheme Procedure} string-titlecase str [start [end]] +@deffnx {C Function} scm_string_titlecase (str, start, end) +Titlecase every first character in a word in @var{str}. +@end deffn -@node Appending Strings -@subsubsection Appending Strings +@deffn {Scheme Procedure} string-titlecase! str [start [end]] +@deffnx {C Function} scm_string_titlecase_x (str, start, end) +Destructively titlecase every first character in a word in +@var{str}. +@end deffn -The procedure @code{string-append} appends several strings together to -form a longer result string. +@node Reversing and Appending Strings +@subsubsection Reversing and Appending Strings + +@deffn {Scheme Procedure} string-reverse str [start [end]] +@deffnx {C Function} scm_string_reverse (str, start, end) +Reverse the string @var{str}. The optional arguments +@var{start} and @var{end} delimit the region of @var{str} to +operate on. +@end deffn + +@deffn {Scheme Procedure} string-reverse! str [start [end]] +@deffnx {C Function} scm_string_reverse_x (str, start, end) +Reverse the string @var{str} in-place. The optional arguments +@var{start} and @var{end} delimit the region of @var{str} to +operate on. The return value is unspecified. +@end deffn @rnindex string-append @deffn {Scheme Procedure} string-append . args @@ -2880,6 +3324,200 @@ concatenation of the given strings, @var{args}. @end example @end deffn +@deffn {Scheme Procedure} string-append/shared . ls +@deffnx {C Function} scm_string_append_shared (ls) +Like @code{string-append}, but the result may share memory +with the argument strings. +@end deffn + +@deffn {Scheme Procedure} string-concatenate ls +@deffnx {C Function} scm_string_concatenate (ls) +Append the elements of @var{ls} (which must be strings) +together into a single string. Guaranteed to return a freshly +allocated string. +@end deffn + +@deffn {Scheme Procedure} string-concatenate-reverse ls [final_string [end]] +@deffnx {C Function} scm_string_concatenate_reverse (ls, final_string, end) +Without optional arguments, this procedure is equivalent to + +@smalllisp +(string-concatenate (reverse ls)) +@end smalllisp + +If the optional argument @var{final_string} is specified, it is +consed onto the beginning to @var{ls} before performing the +list-reverse and string-concatenate operations. If @var{end} +is given, only the characters of @var{final_string} up to index +@var{end} are used. + +Guaranteed to return a freshly allocated string. +@end deffn + +@deffn {Scheme Procedure} string-concatenate/shared ls +@deffnx {C Function} scm_string_concatenate_shared (ls) +Like @code{string-concatenate}, but the result may share memory +with the strings in the list @var{ls}. +@end deffn + +@deffn {Scheme Procedure} string-concatenate-reverse/shared ls [final_string [end]] +@deffnx {C Function} scm_string_concatenate_reverse_shared (ls, final_string, end) +Like @code{string-concatenate-reverse}, but the result may +share memory with the the strings in the @var{ls} arguments. +@end deffn + +@node Mapping Folding and Unfolding +@subsubsection Mapping, Folding, and Unfolding + +@deffn {Scheme Procedure} string-map proc s [start [end]] +@deffnx {C Function} scm_string_map (proc, s, start, end) +@var{proc} is a char->char procedure, it is mapped over +@var{s}. The order in which the procedure is applied to the +string elements is not specified. +@end deffn + +@deffn {Scheme Procedure} string-map! proc s [start [end]] +@deffnx {C Function} scm_string_map_x (proc, s, start, end) +@var{proc} is a char->char procedure, it is mapped over +@var{s}. The order in which the procedure is applied to the +string elements is not specified. The string @var{s} is +modified in-place, the return value is not specified. +@end deffn + +@deffn {Scheme Procedure} string-for-each proc s [start [end]] +@deffnx {C Function} scm_string_for_each (proc, s, start, end) +@var{proc} is mapped over @var{s} in left-to-right order. The +return value is not specified. +@end deffn + +@deffn {Scheme Procedure} string-for-each-index proc s [start [end]] +@deffnx {C Function} scm_string_for_each_index (proc, s, start, end) +@var{proc} is mapped over @var{s} in left-to-right order. The +return value is not specified. +@end deffn + +@deffn {Scheme Procedure} string-fold kons knil s [start [end]] +@deffnx {C Function} scm_string_fold (kons, knil, s, start, end) +Fold @var{kons} over the characters of @var{s}, with @var{knil} +as the terminating element, from left to right. @var{kons} +must expect two arguments: The actual character and the last +result of @var{kons}' application. +@end deffn + +@deffn {Scheme Procedure} string-fold-right kons knil s [start [end]] +@deffnx {C Function} scm_string_fold_right (kons, knil, s, start, end) +Fold @var{kons} over the characters of @var{s}, with @var{knil} +as the terminating element, from right to left. @var{kons} +must expect two arguments: The actual character and the last +result of @var{kons}' application. +@end deffn + +@deffn {Scheme Procedure} string-unfold p f g seed [base [make_final]] +@deffnx {C Function} scm_string_unfold (p, f, g, seed, base, make_final) +@itemize @bullet +@item @var{g} is used to generate a series of @emph{seed} +values from the initial @var{seed}: @var{seed}, (@var{g} +@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), +@dots{} +@item @var{p} tells us when to stop -- when it returns true +when applied to one of these seed values. +@item @var{f} maps each seed value to the corresponding +character in the result string. These chars are assembled +into the string in a left-to-right order. +@item @var{base} is the optional initial/leftmost portion +of the constructed string; it default to the empty +string. +@item @var{make_final} is applied to the terminal seed +value (on which @var{p} returns true) to produce +the final/rightmost portion of the constructed string. +It defaults to @code{(lambda (x) )}. +@end itemize +@end deffn + +@deffn {Scheme Procedure} string-unfold-right p f g seed [base [make_final]] +@deffnx {C Function} scm_string_unfold_right (p, f, g, seed, base, make_final) +@itemize @bullet +@item @var{g} is used to generate a series of @emph{seed} +values from the initial @var{seed}: @var{seed}, (@var{g} +@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), +@dots{} +@item @var{p} tells us when to stop -- when it returns true +when applied to one of these seed values. +@item @var{f} maps each seed value to the corresponding +character in the result string. These chars are assembled +into the string in a right-to-left order. +@item @var{base} is the optional initial/rightmost portion +of the constructed string; it default to the empty +string. +@item @var{make_final} is applied to the terminal seed +value (on which @var{p} returns true) to produce +the final/leftmost portion of the constructed string. +It defaults to @code{(lambda (x) )}. +@end itemize +@end deffn + +@node Miscellaneous String Operations +@subsubsection Miscellaneous String Operations + +@deffn {Scheme Procedure} xsubstring s from [to [start [end]]] +@deffnx {C Function} scm_xsubstring (s, from, to, start, end) +This is the @emph{extended substring} procedure that implements +replicated copying of a substring of some string. + +@var{s} is a string, @var{start} and @var{end} are optional +arguments that demarcate a substring of @var{s}, defaulting to +0 and the length of @var{s}. Replicate this substring up and +down index space, in both the positive and negative directions. +@code{xsubstring} returns the substring of this string +beginning at index @var{from}, and ending at @var{to}, which +defaults to @var{from} + (@var{end} - @var{start}). +@end deffn + +@deffn {Scheme Procedure} string-xcopy! target tstart s sfrom [sto [start [end]]] +@deffnx {C Function} scm_string_xcopy_x (target, tstart, s, sfrom, sto, start, end) +Exactly the same as @code{xsubstring}, but the extracted text +is written into the string @var{target} starting at index +@var{tstart}. The operation is not defined if @code{(eq? +@var{target} @var{s})} or these arguments share storage -- you +cannot copy a string on top of itself. +@end deffn + +@deffn {Scheme Procedure} string-replace s1 s2 [start1 [end1 [start2 [end2]]]] +@deffnx {C Function} scm_string_replace (s1, s2, start1, end1, start2, end2) +Return the string @var{s1}, but with the characters +@var{start1} @dots{} @var{end1} replaced by the characters +@var{start2} @dots{} @var{end2} from @var{s2}. +@end deffn + +@deffn {Scheme Procedure} string-tokenize s [token_set [start [end]]] +@deffnx {C Function} scm_string_tokenize (s, token_set, start, end) +Split the string @var{s} into a list of substrings, where each +substring is a maximal non-empty contiguous sequence of +characters from the character set @var{token_set}, which +defaults to @code{char-set:graphic}. +If @var{start} or @var{end} indices are provided, they restrict +@code{string-tokenize} to operating on the indicated substring +of @var{s}. +@end deffn + +@deffn {Scheme Procedure} string-filter s char_pred [start [end]] +@deffnx {C Function} scm_string_filter (s, char_pred, start, end) +Filter the string @var{s}, retaining only those characters that +satisfy the @var{char_pred} argument. If the argument is a +procedure, it is applied to each character as a predicate, if +it is a character, it is tested for equality and if it is a +character set, it is tested for membership. +@end deffn + +@deffn {Scheme Procedure} string-delete s char_pred [start [end]] +@deffnx {C Function} scm_string_delete (s, char_pred, start, end) +Filter the string @var{s}, retaining only those characters that +do not satisfy the @var{char_pred} argument. If the argument +is a procedure, it is applied to each character as a predicate, +if it is a character, it is tested for equality and if it is a +character set, it is tested for membership. +@end deffn + @node Conversion to/from C @subsubsection Conversion to/from C diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 9a6659a05..0aadb36d5 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1275,692 +1275,7 @@ expressions. @subsection SRFI-13 - String Library @cindex SRFI-13 -In this section, we will describe all procedures defined in SRFI-13 -(string library) and implemented by the module @code{(srfi srfi-13)}. - -Note that only the procedures from SRFI-13 are documented here which are -not already contained in Guile. For procedures not documented here -please refer to the relevant chapters in the Guile Reference Manual, for -example the documentation of strings and string procedures -(@pxref{Strings}). - -All of the procedures defined in SRFI-13, which are not already -included in the Guile core library, are implemented in the module -@code{(srfi srfi-13)}. The procedures which are both in Guile and in -SRFI-13 are slightly extended in this module. Their bindings -overwrite those in the Guile core. - -The procedures which are defined in the section @emph{Low-level -procedures} of SRFI-13 for parsing optional string indices, substring -specification checking and Knuth-Morris-Pratt-Searching are not -implemented. - -The procedures @code{string-contains} and @code{string-contains-ci} are -not implemented very efficiently at the moment. This will be changed as -soon as possible. - -@menu -* Loading SRFI-13:: How to load SRFI-13 support. -* SRFI-13 Predicates:: String predicates. -* SRFI-13 Constructors:: String constructing procedures. -* SRFI-13 List/String Conversion:: Conversion from/to lists. -* SRFI-13 Selection:: Selection portions of strings. -* SRFI-13 Modification:: Modify strings in-place. -* SRFI-13 Comparison:: Compare strings. -* SRFI-13 Prefixes/Suffixes:: Detect common pre-/suffixes. -* SRFI-13 Searching:: Searching for substrings. -* SRFI-13 Case Mapping:: Mapping to lower-/upper-case. -* SRFI-13 Reverse/Append:: Reverse and append strings. -* SRFI-13 Fold/Unfold/Map:: Construct/deconstruct strings. -* SRFI-13 Replicate/Rotate:: Replicate and rotate portions of strings. -* SRFI-13 Miscellaneous:: Left-over string procedures. -* SRFI-13 Filtering/Deleting:: Filter and delete characters from strings. -@end menu - - -@node Loading SRFI-13 -@subsubsection Loading SRFI-13 - -When Guile is properly installed, SRFI-13 support can be loaded into a -running Guile by using the @code{(srfi srfi-13)} module. - -@example -$ guile -guile> (use-modules (srfi srfi-13)) -guile> -@end example - -When this step causes any errors, Guile is not properly installed. - -One possible reason is that Guile cannot find either the Scheme module -file @file{srfi-13.scm}, or it cannot find the shared object file -@file{libguile-srfi-srfi-13-14.so}. Make sure that the former is in the -Guile load path and that the latter is either installed in some default -location like @file{/usr/local/lib} or that the directory it was -installed to is in your @code{LTDL_LIBRARY_PATH}. The same applies to -@file{srfi-14.scm}. - -Now you can test whether the SRFI-13 procedures are working by calling -the @code{string-concatenate} procedure. - -@example -guile> (string-concatenate '("Hello" " " "World!")) -"Hello World!" -@end example - -@node SRFI-13 Predicates -@subsubsection Predicates - -In addition to the primitives @code{string?} and @code{string-null?}, -which are already in the Guile core, the string predicates -@code{string-any} and @code{string-every} are defined by SRFI-13. - -@deffn {Scheme Procedure} string-any char_pred s [start end] -Return true if @code{char_pred} is satisfied for any character in the -string @var{s}. @var{char_pred} can be - -@itemize @bullet -@item -A character, to to test for any in @var{s} equal to that. -@item -A character set (@pxref{SRFI-14}), to test for any character in -@var{s} in that character set. -@item -A predicate function, called as @code{(@var{char_pred} c)} for each -character in @var{s}, from left to right, to test for any on which -@var{char_pred} returns true. - -When @var{char_pred} does return true (ie.@: non-@code{#f}), that -value is the value returned by @code{string-any}. -@end itemize - -If there are no characters in @var{s} (ie.@: @var{start} equals -@var{end}) then the return is @code{#f}. - -SRFI-13 specifies that when @var{char_pred} is a predicate function, -the call on the last character of @var{s} (assuming that point is -reached) is a tail call, but currently in Guile this is not the case. -@end deffn - -@deffn {Scheme Procedure} string-every char_pred s [start end] -Return true if @var{char_pred} is satisifed for every character in the -string @var{s}. @var{char_pred} can be - -@itemize @bullet -@item -A character, to to test for every character in @var{s} equal to that. -@item -A character set (@pxref{SRFI-14}), to test for every character in -@var{s} being in that character set. -@item -A predicate function, called as @code{(@var{char_pred} c)} for each -character in @var{s}, from left to right, to test that it returns true -for every character in @var{s}. - -When @var{char_pred} does return true (ie.@: non-@code{#f}) for every -character, the return from the last call is the value returned by -@code{string-every}. -@end itemize - -If there are no characters in @var{s} (ie.@: @var{start} equals -@var{end}) then the return is @code{#t}. - -SRFI-13 specifies that when @var{char_pred} is a predicate function, -the call on the last character of @var{s} (assuming that point is -reached) is a tail call, but currently in Guile this is not the case. -@end deffn - -@c =================================================================== - -@node SRFI-13 Constructors -@subsubsection Constructors - -SRFI-13 defines several procedures for constructing new strings. In -addition to @code{make-string} and @code{string} (available in the Guile -core library), the procedure @code{string-tabulate} does exist. - -@deffn {Scheme Procedure} string-tabulate proc len -@var{proc} is an integer->char procedure. Construct a string -of size @var{len} by applying @var{proc} to each index to -produce the corresponding string element. The order in which -@var{proc} is applied to the indices is not specified. -@end deffn - - -@c =================================================================== - -@node SRFI-13 List/String Conversion -@subsubsection List/String Conversion - -The procedure @code{string->list} is extended by SRFI-13, that is why it -is included in @code{(srfi srfi-13)}. The other procedures are new. -The Guile core already contains the procedure @code{list->string} for -converting a list of characters into a string (@pxref{List/String -Conversion}). - -@deffn {Scheme Procedure} string->list str [start end] -Convert the string @var{str} into a list of characters. -@end deffn - -@deffn {Scheme Procedure} reverse-list->string chrs -An efficient implementation of @code{(compose string->list -reverse)}: - -@smalllisp -(reverse-list->string '(#\a #\B #\c)) @result{} "cBa" -@end smalllisp -@end deffn - -@deffn {Scheme Procedure} string-join ls [delimiter grammar] -Append the string in the string list @var{ls}, using the string -@var{delim} as a delimiter between the elements of @var{ls}. -@var{grammar} is a symbol which specifies how the delimiter is -placed between the strings, and defaults to the symbol -@code{infix}. - -@table @code -@item infix -Insert the separator between list elements. An empty string -will produce an empty list. - -@item string-infix -Like @code{infix}, but will raise an error if given the empty -list. - -@item suffix -Insert the separator after every list element. - -@item prefix -Insert the separator before each list element. -@end table -@end deffn - - -@c =================================================================== - -@node SRFI-13 Selection -@subsubsection Selection - -These procedures are called @dfn{selectors}, because they access -information about the string or select pieces of a given string. - -Additional selector procedures are documented in the Strings section -(@pxref{String Selection}), like @code{string-length} or -@code{string-ref}. - -@code{string-copy} is also available in core Guile, but this version -accepts additional start/end indices. - -@deffn {Scheme Procedure} string-copy str [start end] -Return a freshly allocated copy of the string @var{str}. If -given, @var{start} and @var{end} delimit the portion of -@var{str} which is copied. -@end deffn - -@deffn {Scheme Procedure} substring/shared str start [end] -Like @code{substring}, but the result may share memory with the -argument @var{str}. -@end deffn - -@deffn {Scheme Procedure} string-copy! target tstart s [start end] -Copy the sequence of characters from index range [@var{start}, -@var{end}) in string @var{s} to string @var{target}, beginning -at index @var{tstart}. The characters are copied left-to-right -or right-to-left as needed - the copy is guaranteed to work, -even if @var{target} and @var{s} are the same string. It is an -error if the copy operation runs off the end of the target -string. -@end deffn - -@deffn {Scheme Procedure} string-take s n -@deffnx {Scheme Procedure} string-take-right s n -Return the @var{n} first/last characters of @var{s}. -@end deffn - -@deffn {Scheme Procedure} string-drop s n -@deffnx {Scheme Procedure} string-drop-right s n -Return all but the first/last @var{n} characters of @var{s}. -@end deffn - -@deffn {Scheme Procedure} string-pad s len [chr start end] -@deffnx {Scheme Procedure} string-pad-right s len [chr start end] -Take that characters from @var{start} to @var{end} from the -string @var{s} and return a new string, right(left)-padded by the -character @var{chr} to length @var{len}. If the resulting -string is longer than @var{len}, it is truncated on the right (left). -@end deffn - -@deffn {Scheme Procedure} string-trim s [char_pred start end] -@deffnx {Scheme Procedure} string-trim-right s [char_pred start end] -@deffnx {Scheme Procedure} string-trim-both s [char_pred start end] -Trim @var{s} by skipping over all characters on the left/right/both -sides of the string that satisfy the parameter @var{char_pred}: - -@itemize @bullet -@item -if it is the character @var{ch}, characters equal to -@var{ch} are trimmed, - -@item -if it is a procedure @var{pred} characters that -satisfy @var{pred} are trimmed, - -@item -if it is a character set, characters in that set are trimmed. -@end itemize - -If called without a @var{char_pred} argument, all whitespace is -trimmed. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Modification -@subsubsection Modification - -The procedure @code{string-fill!} is extended from R5RS because it -accepts optional start/end indices. This bindings shadows the procedure -of the same name in the Guile core. The second modification procedure -@code{string-set!} is documented in the Strings section (@pxref{String -Modification}). - -@deffn {Scheme Procedure} string-fill! str chr [start end] -Stores @var{chr} in every element of the given @var{str} and -returns an unspecified value. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Comparison -@subsubsection Comparison - -The procedures in this section are used for comparing strings in -different ways. The comparison predicates differ from those in R5RS in -that they do not only return @code{#t} or @code{#f}, but the mismatch -index in the case of a true return value. - -@code{string-hash} and @code{string-hash-ci} are for calculating hash -values for strings, useful for implementing fast lookup mechanisms. - -@deffn {Scheme Procedure} string-compare s1 s2 proc_lt proc_eq proc_gt [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-compare-ci s1 s2 proc_lt proc_eq proc_gt [start1 end1 start2 end2] -Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the -mismatch index, depending upon whether @var{s1} is less than, -equal to, or greater than @var{s2}. The mismatch index is the -largest index @var{i} such that for every 0 <= @var{j} < -@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] - that is, -@var{i} is the first position that does not match. The -character comparison is done case-insensitively. -@end deffn - -@deffn {Scheme Procedure} string= s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string<> s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string< s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string> s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string<= s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string>= s1 s2 [start1 end1 start2 end2] -Compare @var{s1} and @var{s2} and return @code{#f} if the predicate -fails. Otherwise, the mismatch index is returned (or @var{end1} in the -case of @code{string=}. -@end deffn - -@deffn {Scheme Procedure} string-ci= s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-ci<> s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-ci< s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-ci> s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-ci<= s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-ci>= s1 s2 [start1 end1 start2 end2] -Compare @var{s1} and @var{s2} and return @code{#f} if the predicate -fails. Otherwise, the mismatch index is returned (or @var{end1} in the -case of @code{string=}. These are the case-insensitive variants. -@end deffn - -@deffn {Scheme Procedure} string-hash s [bound start end] -@deffnx {Scheme Procedure} string-hash-ci s [bound start end] -Return a hash value of the string @var{s} in the range 0 @dots{} -@var{bound} - 1. @code{string-hash-ci} is the case-insensitive variant. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Prefixes/Suffixes -@subsubsection Prefixes/Suffixes - -Using these procedures you can determine whether a given string is a -prefix or suffix of another string or how long a common prefix/suffix -is. - -@deffn {Scheme Procedure} string-prefix-length s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-prefix-length-ci s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-suffix-length s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-suffix-length-ci s1 s2 [start1 end1 start2 end2] -Return the length of the longest common prefix/suffix of the two -strings. @code{string-prefix-length-ci} and -@code{string-suffix-length-ci} are the case-insensitive variants. -@end deffn - -@deffn {Scheme Procedure} string-prefix? s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-prefix-ci? s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-suffix? s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-suffix-ci? s1 s2 [start1 end1 start2 end2] -Is @var{s1} a prefix/suffix of @var{s2}. @code{string-prefix-ci?} and -@code{string-suffix-ci?} are the case-insensitive variants. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Searching -@subsubsection Searching - -Use these procedures to find out whether a string contains a given -character or a given substring, or a character from a set of characters. - -@deffn {Scheme Procedure} string-index s char_pred [start end] -@deffnx {Scheme Procedure} string-index-right s char_pred [start end] -Search through the string @var{s} from left to right (right to left), -returning the index of the first (last) occurrence of a character which - -@itemize @bullet -@item -equals @var{char_pred}, if it is character, - -@item -satisfies the predicate @var{char_pred}, if it is a -procedure, - -@item -is in the set @var{char_pred}, if it is a character set. -@end itemize -@end deffn - -@deffn {Scheme Procedure} string-skip s char_pred [start end] -@deffnx {Scheme Procedure} string-skip-right s char_pred [start end] -Search through the string @var{s} from left to right (right to left), -returning the index of the first (last) occurrence of a character which - -@itemize @bullet -@item -does not equal @var{char_pred}, if it is character, - -@item -does not satisfy the predicate @var{char_pred}, if it is -a procedure. - -@item -is not in the set if @var{char_pred} is a character set. -@end itemize -@end deffn - -@deffn {Scheme Procedure} string-count s char_pred [start end] -Return the count of the number of characters in the string -@var{s} which - -@itemize @bullet -@item -equals @var{char_pred}, if it is character, - -@item -satisfies the predicate @var{char_pred}, if it is a procedure. - -@item -is in the set @var{char_pred}, if it is a character set. -@end itemize -@end deffn - -@deffn {Scheme Procedure} string-contains s1 s2 [start1 end1 start2 end2] -@deffnx {Scheme Procedure} string-contains-ci s1 s2 [start1 end1 start2 end2] -Does string @var{s1} contain string @var{s2}? Return the index -in @var{s1} where @var{s2} occurs as a substring, or false. -The optional start/end indices restrict the operation to the -indicated substrings. - -@code{string-contains-ci} is the case-insensitive variant. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Case Mapping -@subsubsection Alphabetic Case Mapping - -These procedures convert the alphabetic case of strings. They are -similar to the procedures in the Guile core, but are extended to handle -optional start/end indices. - -@deffn {Scheme Procedure} string-upcase s [start end] -@deffnx {Scheme Procedure} string-upcase! s [start end] -Upcase every character in @var{s}. @code{string-upcase!} is the -side-effecting variant. -@end deffn - -@deffn {Scheme Procedure} string-downcase s [start end] -@deffnx {Scheme Procedure} string-downcase! s [start end] -Downcase every character in @var{s}. @code{string-downcase!} is the -side-effecting variant. -@end deffn - -@deffn {Scheme Procedure} string-titlecase s [start end] -@deffnx {Scheme Procedure} string-titlecase! s [start end] -Upcase every first character in every word in @var{s}, downcase the -other characters. @code{string-titlecase!} is the side-effecting -variant. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Reverse/Append -@subsubsection Reverse/Append - -One appending procedure, @code{string-append} is the same in R5RS and in -SRFI-13, so it is not redefined. - -@deffn {Scheme Procedure} string-reverse str [start end] -@deffnx {Scheme Procedure} string-reverse! str [start end] -Reverse the string @var{str}. The optional arguments -@var{start} and @var{end} delimit the region of @var{str} to -operate on. - -@code{string-reverse!} modifies the argument string and returns an -unspecified value. -@end deffn - -@deffn {Scheme Procedure} string-append/shared ls @dots{} -Like @code{string-append}, but the result may share memory -with the argument strings. -@end deffn - -@deffn {Scheme Procedure} string-concatenate ls -Append the elements of @var{ls} (which must be strings) -together into a single string. Guaranteed to return a freshly -allocated string. -@end deffn - -@deffn {Scheme Procedure} string-concatenate/shared ls -Like @code{string-concatenate}, but the result may share memory -with the strings in the list @var{ls}. -@end deffn - -@deffn {Scheme Procedure} string-concatenate-reverse ls final_string end -Without optional arguments, this procedure is equivalent to - -@smalllisp -(string-concatenate (reverse ls)) -@end smalllisp - -If the optional argument @var{final_string} is specified, it is -consed onto the beginning to @var{ls} before performing the -list-reverse and string-concatenate operations. If @var{end} -is given, only the characters of @var{final_string} up to index -@var{end} are used. - -Guaranteed to return a freshly allocated string. -@end deffn - -@deffn {Scheme Procedure} string-concatenate-reverse/shared ls final_string end -Like @code{string-concatenate-reverse}, but the result may -share memory with the the strings in the @var{ls} arguments. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Fold/Unfold/Map -@subsubsection Fold/Unfold/Map - -@code{string-map}, @code{string-for-each} etc. are for iterating over -the characters a string is composed of. The fold and unfold procedures -are list iterators and constructors. - -@deffn {Scheme Procedure} string-map proc s [start end] -@var{proc} is a char->char procedure, it is mapped over -@var{s}. The order in which the procedure is applied to the -string elements is not specified. -@end deffn - -@deffn {Scheme Procedure} string-map! proc s [start end] -@var{proc} is a char->char procedure, it is mapped over -@var{s}. The order in which the procedure is applied to the -string elements is not specified. The string @var{s} is -modified in-place, the return value is not specified. -@end deffn - -@deffn {Scheme Procedure} string-fold kons knil s [start end] -@deffnx {Scheme Procedure} string-fold-right kons knil s [start end] -Fold @var{kons} over the characters of @var{s}, with @var{knil} as the -terminating element, from left to right (or right to left, for -@code{string-fold-right}). @var{kons} must expect two arguments: The -actual character and the last result of @var{kons}' application. -@end deffn - -@deffn {Scheme Procedure} string-unfold p f g seed [base make_final] -@deffnx {Scheme Procedure} string-unfold-right p f g seed [base make_final] -These are the fundamental string constructors. -@itemize @bullet -@item @var{g} is used to generate a series of @emph{seed} -values from the initial @var{seed}: @var{seed}, (@var{g} -@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), -@dots{} -@item @var{p} tells us when to stop - when it returns true -when applied to one of these seed values. -@item @var{f} maps each seed value to the corresponding -character in the result string. These chars are assembled into the -string in a left-to-right (right-to-left) order. -@item @var{base} is the optional initial/leftmost (rightmost) - portion of the constructed string; it default to the empty string. -@item @var{make_final} is applied to the terminal seed -value (on which @var{p} returns true) to produce the final/rightmost -(leftmost) portion of the constructed string. It defaults to -@code{(lambda (x) "")}. -@end itemize -@end deffn - -@deffn {Scheme Procedure} string-for-each proc s [start end] -@var{proc} is mapped over @var{s} in left-to-right order. The -return value is not specified. -@end deffn - -@deffn {Scheme Procedure} string-for-each-index proc s [start [end]] -@deffnx {C Function} scm_string_for_each_index (proc, s, start, end) -@var{proc} is mapped over @var{s} in left-to-right order. The -return value is not specified. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Replicate/Rotate -@subsubsection Replicate/Rotate - -These procedures are special substring procedures, which can also be -used for replicating strings. They are a bit tricky to use, but -consider this code fragment, which replicates the input string -@code{"foo"} so often that the resulting string has a length of six. - -@lisp -(xsubstring "foo" 0 6) -@result{} -"foofoo" -@end lisp - -@deffn {Scheme Procedure} xsubstring s from [to start end] -This is the @emph{extended substring} procedure that implements -replicated copying of a substring of some string. - -@var{s} is a string, @var{start} and @var{end} are optional -arguments that demarcate a substring of @var{s}, defaulting to -0 and the length of @var{s}. Replicate this substring up and -down index space, in both the positive and negative directions. -@code{xsubstring} returns the substring of this string -beginning at index @var{from}, and ending at @var{to}, which -defaults to @var{from} + (@var{end} - @var{start}). -@end deffn - -@deffn {Scheme Procedure} string-xcopy! target tstart s sfrom [sto start end] -Exactly the same as @code{xsubstring}, but the extracted text -is written into the string @var{target} starting at index -@var{tstart}. The operation is not defined if @code{(eq? -@var{target} @var{s})} or these arguments share storage - you -cannot copy a string on top of itself. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Miscellaneous -@subsubsection Miscellaneous - -@code{string-replace} is for replacing a portion of a string with -another string and @code{string-tokenize} splits a string into a list of -strings, breaking it up at a specified character. - -@deffn {Scheme Procedure} string-replace s1 s2 [start1 end1 start2 end2] -Return the string @var{s1}, but with the characters -@var{start1} @dots{} @var{end1} replaced by the characters -@var{start2} @dots{} @var{end2} from @var{s2}. - -For reference, note that SRFI-13 specifies @var{start1} and @var{end1} -as mandatory, but in Guile they are optional. -@end deffn - -@deffn {Scheme Procedure} string-tokenize s [token-set start end] -Split the string @var{s} into a list of substrings, where each -substring is a maximal non-empty contiguous sequence of characters -from the character set @var{token_set}, which defaults to an -equivalent of @code{char-set:graphic}. If @var{start} or @var{end} -indices are provided, they restrict @code{string-tokenize} to -operating on the indicated substring of @var{s}. -@end deffn - - -@c =================================================================== - -@node SRFI-13 Filtering/Deleting -@subsubsection Filtering/Deleting - -@dfn{Filtering} means to remove all characters from a string which do -not match a given criteria, @dfn{deleting} means the opposite. - -@deffn {Scheme Procedure} string-filter s char_pred [start end] -Filter the string @var{s}, retaining only those characters that -satisfy the @var{char_pred} argument. If the argument is a -procedure, it is applied to each character as a predicate, if -it is a character, it is tested for equality and if it is a -character set, it is tested for membership. -@end deffn - -@deffn {Scheme Procedure} string-delete s char_pred [start end] -Filter the string @var{s}, retaining only those characters that -do not satisfy the @var{char_pred} argument. If the argument -is a procedure, it is applied to each character as a predicate, -if it is a character, it is tested for equality and if it is a -character set, it is tested for membership. -@end deffn - +The SRFI-13 procedures are always available, @xref{Strings}. @node SRFI-14 @subsection SRFI-14 - Character-set Library From 4a3057fc1e51d740d04a0cc8a9e4f3d8293f88e2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 13:40:53 +0000 Subject: [PATCH 080/100] Correct xref to SRFI-13, now points to node Strings. --- doc/ref/api-compound.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 990a7c9c0..279286763 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -2361,7 +2361,7 @@ values are arbitrary as long as they're in the range 0 to @math{@var{size}-1}. Helpful functions for forming a hash value, in addition to @code{hashq} etc below, include @code{symbol-hash} (@pxref{Symbol Keys}), @code{string-hash} and @code{string-hash-ci} -(@pxref{SRFI-13 Comparison}), and @code{char-set-hash} +(@pxref{String Comparison}), and @code{char-set-hash} (@pxref{Character Set Predicates/Comparison}). Note that currently, unfortunately, there's no @code{hashx-remove!} From ecedc0ca1bcbd877addce727083d75405c39fb96 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 13:41:14 +0000 Subject: [PATCH 081/100] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 732524a43..d62724db2 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2004-08-25 Marius Vollmer + + * api-data.texi, srfi-modules.texi: Moved docs for SRFI-14 into + main API chapter. Updated docstrings from libguile/. + 2004-08-25 Marius Vollmer * api-data.texi, srfi-modules.texi: Moved docs for SRFI-14 into From 2562032b617ee7a0a5fc148549180061a4274cbc Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 13:42:04 +0000 Subject: [PATCH 082/100] (scm_string_rindex): Export to Scheme, as it has always been. --- libguile/srfi-13.c | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c index 8f1a89ff5..9b4f4eca9 100644 --- a/libguile/srfi-13.c +++ b/libguile/srfi-13.c @@ -1949,10 +1949,23 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, } #undef FUNC_NAME -SCM -scm_string_rindex (SCM str, SCM chr, SCM frm, SCM to) +SCM_DEFINE (scm_string_rindex, "string-rindex", 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") { - return scm_string_index_right (str, chr, frm, to); + return scm_string_index_right (s, char_pred, start, end); } SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, From 7311b3e8381f756c09516cedf4151933d8e105ba Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 13:47:52 +0000 Subject: [PATCH 083/100] (scm_compile_shell_switches): Use scm_from_locale_string instead of scm_makfrom0str. --- libguile/script.c | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/libguile/script.c b/libguile/script.c index 086b9beef..efb15407c 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -503,12 +503,13 @@ scm_compile_shell_switches (int argc, char **argv) else if (! strcmp (argv[i], "-L")) /* add to %load-path */ { if (++i < argc) - user_load_path = scm_cons (scm_list_3 (sym_set_x, - sym_load_path, - scm_list_3(sym_cons, - scm_makfrom0str (argv[i]), - sym_load_path)), - user_load_path); + user_load_path = + scm_cons (scm_list_3 (sym_set_x, + sym_load_path, + scm_list_3 (sym_cons, + scm_from_locale_string (argv[i]), + sym_load_path)), + user_load_path); else scm_shell_usage (1, "missing argument to `-L' switch"); } From ce25760f071de2addd80cfc0b8bc28c9352ec1a0 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 13:49:48 +0000 Subject: [PATCH 084/100] *** empty log message *** --- libguile/ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1fd9ceb66..00e4f050d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2004-08-25 Marius Vollmer + + * script.c (scm_compile_shell_switches): Use + scm_from_locale_string instead of scm_makfrom0str. + + * srfi-13.c (scm_string_rindex): Export to Scheme, as it has + always been. + 2004-08-25 Marius Vollmer Moved SRFI-13 and SRFI-14 into the core, taking over the role of From 3731fc6718a91a19cd5a89b27d0bf7b00cc7aef1 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 16:04:09 +0000 Subject: [PATCH 085/100] * srfi-13.c: First cut at thread-safeness and proper use of scm_i_string_chars et al. Copious scm_remember_upto_heres have been inserted. Made sure that no internal string pointer is used across a SCM_TICK or a possible GC. --- libguile/srfi-13.c | 476 +++++++++++++++++++++++++-------------------- 1 file changed, 264 insertions(+), 212 deletions(-) diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c index 9b4f4eca9..37f378ab0 100644 --- a/libguile/srfi-13.c +++ b/libguile/srfi-13.c @@ -51,15 +51,6 @@ start, &c_start, end, &c_end); \ } while (0) -/* Likewise for SCM_VALIDATE_STRING_COPY. */ - -#define MY_VALIDATE_STRING_COPY(pos, str, cvar) \ - do { \ - scm_validate_string (pos, str); \ - cvar = scm_i_string_chars (str); \ - } while (0) - - SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0, (SCM str), "Return @code{#t} if @var{str}'s length is zero, and\n" @@ -76,6 +67,14 @@ SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0, } #undef FUNC_NAME +#if 0 +static void +race_error () +{ + scm_misc_error (NULL, "race condition detected", SCM_EOL); +} +#endif + SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, (SCM char_pred, SCM s, SCM start, SCM end), "Check if the predicate @var{pred} is true for any character in\n" @@ -92,8 +91,8 @@ SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, #define FUNC_NAME s_scm_string_any { const char *cstr; - int cstart, cend; - SCM res; + size_t cstart, cend; + SCM res = SCM_BOOL_F; MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, 3, start, cstart, @@ -101,32 +100,36 @@ SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0, if (SCM_CHARP (char_pred)) { - return (memchr (cstr+cstart, (int) SCM_CHAR (char_pred), - cend-cstart) == NULL - ? SCM_BOOL_F : SCM_BOOL_T); + res = (memchr (cstr+cstart, (int) SCM_CHAR (char_pred), + cend-cstart) == NULL + ? SCM_BOOL_F : SCM_BOOL_T); } else if (SCM_CHARSETP (char_pred)) { int i; for (i = cstart; i < cend; i++) if (SCM_CHARSET_GET (char_pred, cstr[i])) - return SCM_BOOL_T; + { + res = SCM_BOOL_T; + break; + } } else { SCM_VALIDATE_PROC (1, char_pred); - cstr += cstart; while (cstart < cend) { - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (*cstr)); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (scm_is_true (res)) - return res; - cstr++; + break; + cstr = scm_i_string_chars (s); cstart++; } } - return SCM_BOOL_F; + + scm_remember_upto_here_1 (s); + return res; } #undef FUNC_NAME @@ -151,8 +154,8 @@ SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0, #define FUNC_NAME s_scm_string_every { const char *cstr; - int cstart, cend; - SCM res; + size_t cstart, cend; + SCM res = SCM_BOOL_T; MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, 3, start, cstart, @@ -163,33 +166,37 @@ SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0, int i; for (i = cstart; i < cend; i++) if (cstr[i] != cchr) - return SCM_BOOL_F; - return SCM_BOOL_T; + { + res = SCM_BOOL_F; + break; + } } else if (SCM_CHARSETP (char_pred)) { int i; for (i = cstart; i < cend; i++) - if (! SCM_CHARSET_GET (char_pred, cstr[i])) - return SCM_BOOL_F; - return SCM_BOOL_T; + if (!SCM_CHARSET_GET (char_pred, cstr[i])) + { + res = SCM_BOOL_F; + break; + } } else { SCM_VALIDATE_PROC (1, char_pred); - res = SCM_BOOL_T; - cstr += cstart; while (cstart < cend) { - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (*cstr)); + res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (scm_is_false (res)) - return res; - cstr++; + break; + cstr = scm_i_string_chars (s); cstart++; } - return res; } + + scm_remember_upto_here_1 (s); + return res; } #undef FUNC_NAME @@ -235,7 +242,7 @@ SCM_DEFINE (scm_substring_to_list, "string->list", 1, 2, 0, #define FUNC_NAME s_scm_substring_to_list { const char *cstr; - int cstart, cend; + size_t cstart, cend; SCM result = SCM_EOL; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, @@ -245,7 +252,9 @@ SCM_DEFINE (scm_substring_to_list, "string->list", 1, 2, 0, { cend--; result = scm_cons (SCM_MAKE_CHAR (cstr[cend]), result); + cstr = scm_i_string_chars (str); } + scm_remember_upto_here_1 (str); return result; } #undef FUNC_NAME @@ -282,7 +291,7 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0, { data += i; - while (!SCM_NULLP (chrs)) + while (i > 0 && SCM_CONSP (chrs)) { SCM elt = SCM_CAR (chrs); @@ -290,8 +299,10 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0, data--; *data = SCM_CHAR (elt); chrs = SCM_CDR (chrs); + i--; } } + return result; } #undef FUNC_NAME @@ -302,6 +313,18 @@ SCM_SYMBOL (scm_sym_strict_infix, "strict-infix"); SCM_SYMBOL (scm_sym_suffix, "suffix"); SCM_SYMBOL (scm_sym_prefix, "prefix"); +static void +append_string (char **sp, size_t *lp, SCM str) +{ + size_t len; + len = scm_c_string_length (str); + if (len > *lp) + len = *lp; + memcpy (*sp, scm_i_string_chars (str), len); + *lp -= len; + *sp += len; +} + 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" @@ -331,9 +354,9 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, SCM tmp; SCM result; int gram = GRAM_INFIX; - int del_len = 0, extra_len = 0; - int len = 0; - char * p; + size_t del_len = 0; + size_t len = 0; + char *p; long strings = scm_ilength (ls); /* Validate the string list. */ @@ -347,10 +370,7 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, del_len = 1; } else - { - SCM_VALIDATE_STRING (2, delimiter); - del_len = scm_i_string_length (delimiter); - } + del_len = scm_c_string_length (delimiter); /* Validate the grammar symbol and remember the grammar. */ if (SCM_UNBNDP (grammar)) @@ -372,80 +392,61 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, { case GRAM_INFIX: if (!SCM_NULLP (ls)) - extra_len = (strings > 0) ? ((strings - 1) * del_len) : 0; + 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; + len = (strings - 1) * del_len; break; default: - extra_len = strings * del_len; + len = strings * del_len; break; } tmp = ls; while (SCM_CONSP (tmp)) { - SCM elt = SCM_CAR (tmp); - SCM_VALIDATE_STRING (1, elt); - len += scm_i_string_length (elt); + len += scm_c_string_length (SCM_CAR (tmp)); tmp = SCM_CDR (tmp); } - result = scm_i_make_string (len + extra_len, &p); + result = scm_i_make_string (len, &p); tmp = ls; switch (gram) { case GRAM_INFIX: case GRAM_STRICT_INFIX: - while (!SCM_NULLP (tmp)) + while (SCM_CONSP (tmp)) { - SCM elt = SCM_CAR (tmp); - memmove (p, scm_i_string_chars (elt), - scm_i_string_length (elt)); - p += scm_i_string_length (elt); + append_string (&p, &len, SCM_CAR (tmp)); if (!SCM_NULLP (SCM_CDR (tmp)) && del_len > 0) - { - memmove (p, scm_i_string_chars (delimiter), del_len); - p += del_len; - } + append_string (&p, &len, delimiter); tmp = SCM_CDR (tmp); } break; case GRAM_SUFFIX: - while (!SCM_NULLP (tmp)) + while (SCM_CONSP (tmp)) { - SCM elt = SCM_CAR (tmp); - memmove (p, scm_i_string_chars (elt), - scm_i_string_length (elt)); - p += scm_i_string_length (elt); + append_string (&p, &len, SCM_CAR (tmp)); if (del_len > 0) - { - memmove (p, scm_i_string_chars (delimiter), del_len); - p += del_len; - } + append_string (&p, &len, delimiter); tmp = SCM_CDR (tmp); } break; case GRAM_PREFIX: - while (!SCM_NULLP (tmp)) + while (SCM_CONSP (tmp)) { - SCM elt = SCM_CAR (tmp); if (del_len > 0) - { - memmove (p, scm_i_string_chars (delimiter), del_len); - p += del_len; - } - memmove (p, scm_i_string_chars (elt), - scm_i_string_length (elt)); - p += scm_i_string_length (elt); + append_string (&p, &len, delimiter); + append_string (&p, &len, SCM_CAR (tmp)); tmp = SCM_CDR (tmp); } break; } + return result; #undef GRAM_INFIX #undef GRAM_STRICT_INFIX @@ -524,6 +525,7 @@ SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0, ctarget = scm_i_string_writable_chars (target); memmove (ctarget + ctstart, cstr + cstart, len); scm_i_string_stop_writing (); + scm_remember_upto_here_1 (target); return SCM_UNSPECIFIED; } @@ -593,12 +595,11 @@ SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0, #define FUNC_NAME s_scm_string_pad { char cchr; - const char *cstr; size_t cstart, cend, clen; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 4, start, cstart, - 5, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 4, start, cstart, + 5, end, cend); clen = scm_to_size_t (len); if (SCM_UNBNDP (chr)) @@ -617,7 +618,8 @@ SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0, result = scm_i_make_string (clen, &dst); memset (dst, cchr, (clen - (cend - cstart))); - memmove (dst + clen - (cend - cstart), cstr + cstart, cend - cstart); + memmove (dst + clen - (cend - cstart), + scm_i_string_chars (s) + cstart, cend - cstart); return result; } } @@ -633,12 +635,11 @@ SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0, #define FUNC_NAME s_scm_string_pad_right { char cchr; - const char *cstr; size_t cstart, cend, clen; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 4, start, cstart, - 5, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 4, start, cstart, + 5, end, cend); clen = scm_to_size_t (len); if (SCM_UNBNDP (chr)) @@ -657,7 +658,7 @@ SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0, result = scm_i_make_string (clen, &dst); memset (dst + (cend - cstart), cchr, clen - (cend - cstart)); - memmove (dst, cstr + cstart, cend - cstart); + memmove (dst, scm_i_string_chars (s) + cstart, cend - cstart); return result; } } @@ -955,6 +956,8 @@ SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0, for (k = cstart; k < cend; k++) cstr[k] = c; scm_i_string_stop_writing (); + scm_remember_upto_here_1 (str); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -977,6 +980,7 @@ SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0, { const char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; + SCM proc; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 6, start1, cstart1, @@ -991,18 +995,28 @@ SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (cstr1[cstart1] < cstr2[cstart2]) - return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); + { + proc = proc_lt; + goto ret; + } else if (cstr1[cstart1] > cstr2[cstart2]) - return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); + { + proc = proc_gt; + goto ret; + } cstart1++; cstart2++; } if (cstart1 < cend1) - return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); + proc = proc_gt; else if (cstart2 < cend2) - return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); + proc = proc_lt; else - return scm_call_1 (proc_eq, scm_from_size_t (cstart1)); + proc = proc_eq; + + ret: + scm_remember_upto_here_2 (s1, s2); + return scm_call_1 (proc, scm_from_size_t (cstart1)); } #undef FUNC_NAME @@ -1020,6 +1034,7 @@ SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0, { const char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; + SCM proc; MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, 6, start1, cstart1, @@ -1034,18 +1049,30 @@ SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); + { + proc = proc_lt; + goto ret; + } + else if (scm_c_downcase (cstr1[cstart1]) + > scm_c_downcase (cstr2[cstart2])) + { + proc = proc_gt; + goto ret; + } cstart1++; cstart2++; } + if (cstart1 < cend1) - return scm_call_1 (proc_gt, scm_from_size_t (cstart1)); + proc = proc_gt; else if (cstart2 < cend2) - return scm_call_1 (proc_lt, scm_from_size_t (cstart1)); + proc = proc_lt; else - return scm_call_1 (proc_eq, scm_from_size_t (cstart1)); + proc = proc_eq; + + ret: + scm_remember_upto_here (s1, s2); + return scm_call_1 (proc, scm_from_size_t (cstart1)); } #undef FUNC_NAME @@ -1618,11 +1645,14 @@ SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (cstr1[cstart1] != cstr2[cstart2]) - return scm_from_size_t (len); + goto ret; len++; cstart1++; cstart2++; } + + ret: + scm_remember_upto_here_2 (s1, s2); return scm_from_size_t (len); } #undef FUNC_NAME @@ -1647,11 +1677,14 @@ SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2])) - return scm_from_size_t (len); + goto ret; len++; cstart1++; cstart2++; } + + ret: + scm_remember_upto_here_2 (s1, s2); return scm_from_size_t (len); } #undef FUNC_NAME @@ -1678,9 +1711,12 @@ SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0, cend1--; cend2--; if (cstr1[cend1] != cstr2[cend2]) - return scm_from_size_t (len); + goto ret; len++; } + + ret: + scm_remember_upto_here_2 (s1, s2); return scm_from_size_t (len); } #undef FUNC_NAME @@ -1707,9 +1743,12 @@ SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0, cend1--; cend2--; if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2])) - return scm_from_size_t (len); + goto ret; len++; } + + ret: + scm_remember_upto_here_2 (s1, s2); return scm_from_size_t (len); } #undef FUNC_NAME @@ -1734,11 +1773,14 @@ SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (cstr1[cstart1] != cstr2[cstart2]) - return scm_from_bool (len == len1); + goto ret; len++; cstart1++; cstart2++; } + + ret: + scm_remember_upto_here_2 (s1, s2); return scm_from_bool (len == len1); } #undef FUNC_NAME @@ -1763,11 +1805,14 @@ SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0, while (cstart1 < cend1 && cstart2 < cend2) { if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2])) - return scm_from_bool (len == len1); + goto ret; len++; cstart1++; cstart2++; } + + ret: + scm_remember_upto_here_2 (s1, s2); return scm_from_bool (len == len1); } #undef FUNC_NAME @@ -1794,9 +1839,12 @@ SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0, cend1--; cend2--; if (cstr1[cend1] != cstr2[cend2]) - return scm_from_bool (len == len1); + goto ret; len++; } + + ret: + scm_remember_upto_here_2 (s1, s2); return scm_from_bool (len == len1); } #undef FUNC_NAME @@ -1823,9 +1871,12 @@ SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0, cend1--; cend2--; if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2])) - return scm_from_bool (len == len1); + goto ret; len++; } + + ret: + scm_remember_upto_here_2 (s1, s2); return scm_from_bool (len == len1); } #undef FUNC_NAME @@ -1860,7 +1911,7 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, while (cstart < cend) { if (cchr == cstr[cstart]) - return scm_from_size_t (cstart); + goto found; cstart++; } } @@ -1869,7 +1920,7 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, while (cstart < cend) { if (SCM_CHARSET_GET (char_pred, cstr[cstart])) - return scm_from_size_t (cstart); + goto found; cstart++; } } @@ -1881,12 +1932,18 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, SCM res; res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (scm_is_true (res)) - return scm_from_size_t (cstart); + goto found; cstr = scm_i_string_chars (s); cstart++; } } + + scm_remember_upto_here_1 (s); return SCM_BOOL_F; + + found: + scm_remember_upto_here_1 (s); + return scm_from_size_t (cstart); } #undef FUNC_NAME @@ -1920,7 +1977,7 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, { cend--; if (cchr == cstr[cend]) - return scm_from_size_t (cend); + goto found; } } else if (SCM_CHARSETP (char_pred)) @@ -1929,7 +1986,7 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, { cend--; if (SCM_CHARSET_GET (char_pred, cstr[cend])) - return scm_from_size_t (cend); + goto found; } } else @@ -1941,11 +1998,17 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, cend--; res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend])); if (scm_is_true (res)) - return scm_from_size_t (cend); + goto found; cstr = scm_i_string_chars (s); } } + + scm_remember_upto_here_1 (s); return SCM_BOOL_F; + + found: + scm_remember_upto_here_1 (s); + return scm_from_size_t (cend); } #undef FUNC_NAME @@ -1964,9 +2027,11 @@ SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0, "@item\n" "is in the set if @var{char_pred} is a character set.\n" "@end itemize") +#define FUNC_NAME s_scm_string_rindex { return scm_string_index_right (s, char_pred, start, end); } +#undef FUNC_NAME SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, (SCM s, SCM char_pred, SCM start, SCM end), @@ -1998,7 +2063,7 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, while (cstart < cend) { if (cchr != cstr[cstart]) - return scm_from_size_t (cstart); + goto found; cstart++; } } @@ -2007,7 +2072,7 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, while (cstart < cend) { if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) - return scm_from_size_t (cstart); + goto found; cstart++; } } @@ -2019,12 +2084,18 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, SCM res; res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart])); if (scm_is_false (res)) - return scm_from_size_t (cstart); + goto found; cstr = scm_i_string_chars (s); cstart++; } } + + scm_remember_upto_here_1 (s); return SCM_BOOL_F; + + found: + scm_remember_upto_here_1 (s); + return scm_from_size_t (cstart); } #undef FUNC_NAME @@ -2060,7 +2131,7 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, { cend--; if (cchr != cstr[cend]) - return scm_from_size_t (cend); + goto found; } } else if (SCM_CHARSETP (char_pred)) @@ -2069,7 +2140,7 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, { cend--; if (!SCM_CHARSET_GET (char_pred, cstr[cend])) - return scm_from_size_t (cend); + goto found; } } else @@ -2081,11 +2152,18 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, cend--; res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend])); if (scm_is_false (res)) - return scm_from_size_t (cend); + goto found; cstr = scm_i_string_chars (s); } } + + scm_remember_upto_here_1 (s); return SCM_BOOL_F; + + found: + scm_remember_upto_here_1 (s); + return scm_from_size_t (cend); + } #undef FUNC_NAME @@ -2146,6 +2224,8 @@ SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0, cstart++; } } + + scm_remember_upto_here_1 (s); return scm_from_size_t (count); } #undef FUNC_NAME @@ -2183,9 +2263,14 @@ SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0, j++; } if (j == cend2) - return scm_from_size_t (cstart1); + { + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + } cstart1++; } + + scm_remember_upto_here_2 (s1, s2); return SCM_BOOL_F; } #undef FUNC_NAME @@ -2225,9 +2310,14 @@ SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0, j++; } if (j == cend2) - return scm_from_size_t (cstart1); + { + scm_remember_upto_here_2 (s1, s2); + return scm_from_size_t (cstart1); + } cstart1++; } + + scm_remember_upto_here_2 (s1, s2); return SCM_BOOL_F; } #undef FUNC_NAME @@ -2245,6 +2335,7 @@ string_upcase_x (SCM v, int start, int end) for (k = start; k < end; ++k) dst[k] = scm_c_upcase (dst[k]); scm_i_string_stop_writing (); + scm_remember_upto_here_1 (v); return v; } @@ -2310,6 +2401,7 @@ string_downcase_x (SCM v, int start, int end) for (k = start; k < end; ++k) dst[k] = scm_c_downcase (dst[k]); scm_i_string_stop_writing (); + scm_remember_upto_here_1 (v); return v; } @@ -2393,6 +2485,7 @@ string_titlecase_x (SCM str, int start, int end) in_word = 0; } scm_i_string_stop_writing (); + scm_remember_upto_here_1 (str); return str; } @@ -2430,9 +2523,6 @@ SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0, } #undef FUNC_NAME -/* Old names, the functions. - */ - SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0, (SCM str), "Upcase the first character of every word in @var{str}\n" @@ -2500,6 +2590,7 @@ SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0, ctarget = scm_i_string_writable_chars (result); string_reverse_x (ctarget, cstart, cend); scm_i_string_stop_writing (); + scm_remember_upto_here_1 (str); return result; } #undef FUNC_NAME @@ -2522,7 +2613,6 @@ SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0, cstr = scm_i_string_writable_chars (str); string_reverse_x (cstr, cstart, cend); scm_i_string_stop_writing (); - scm_remember_upto_here_1 (str); return SCM_UNSPECIFIED; } @@ -2578,65 +2668,13 @@ SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, "Guaranteed to return a freshly allocated string.") #define FUNC_NAME s_scm_string_concatenate_reverse { - long strings; - SCM tmp, result; - size_t len = 0; - char * p; - size_t cend = 0; + if (!SCM_UNBNDP (end)) + final_string = scm_substring (final_string, SCM_INUM0, end); - /* Check the optional arguments and calculate the additional length - of the result string. */ if (!SCM_UNBNDP (final_string)) - { - SCM_VALIDATE_STRING (2, final_string); - if (!SCM_UNBNDP (end)) - { - cend = scm_to_unsigned_integer (end, - 0, - scm_i_string_length (final_string)); - } - else - { - cend = scm_i_string_length (final_string); - } - len += cend; - } - strings = scm_ilength (ls); - /* Validate the string list. */ - if (strings < 0) - SCM_WRONG_TYPE_ARG (1, ls); + ls = scm_cons (final_string, ls); - /* Calculate the length of the result string. */ - tmp = ls; - while (!SCM_NULLP (tmp)) - { - SCM elt = SCM_CAR (tmp); - SCM_VALIDATE_STRING (1, elt); - len += scm_i_string_length (elt); - tmp = SCM_CDR (tmp); - } - - result = scm_i_make_string (len, &p); - - p += len; - - /* Construct the result string, possibly by using the optional final - string. */ - if (!SCM_UNBNDP (final_string)) - { - p -= cend; - memmove (p, scm_i_string_chars (final_string), cend); - } - tmp = ls; - while (!SCM_NULLP (tmp)) - { - SCM elt = SCM_CAR (tmp); - p -= scm_i_string_length (elt); - memmove (p, scm_i_string_chars (elt), - scm_i_string_length (elt)); - tmp = SCM_CDR (tmp); - } - return result; + return scm_string_concatenate (scm_reverse (ls)); } #undef FUNC_NAME @@ -2671,23 +2709,20 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, "string elements is not specified.") #define FUNC_NAME s_scm_string_map { - const char *cstr; char *p; size_t cstart, cend; SCM result; SCM_VALIDATE_PROC (1, proc); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (2, s, + 3, start, cstart, + 4, end, cend); result = scm_i_make_string (cend - cstart, &p); while (cstart < cend) { - unsigned int c = (unsigned char) cstr[cstart]; - SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (c)); + SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart)); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); - cstr = scm_i_string_chars (s); cstart++; *p++ = SCM_CHAR (ch); } @@ -2747,6 +2782,8 @@ SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0, cstr = scm_i_string_chars (s); cstart++; } + + scm_remember_upto_here_1 (s); return result; } #undef FUNC_NAME @@ -2776,6 +2813,8 @@ SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0, cstr = scm_i_string_chars (s); cend--; } + + scm_remember_upto_here_1 (s); return result; } #undef FUNC_NAME @@ -2927,6 +2966,8 @@ SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0, cstr = scm_i_string_chars (s); cstart++; } + + scm_remember_upto_here_1 (s); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -2937,18 +2978,20 @@ SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0, "return value is not specified.") #define FUNC_NAME s_scm_string_for_each_index { - const char *cstr; size_t cstart, cend; SCM_VALIDATE_PROC (1, proc); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (2, s, + 3, start, cstart, + 4, end, cend); + while (cstart < cend) { scm_call_1 (proc, scm_from_size_t (cstart)); cstart++; } + + scm_remember_upto_here_1 (s); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -2972,9 +3015,10 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, size_t cstart, cend, cfrom, cto; SCM result; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cs, - 4, start, cstart, - 5, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 4, start, cstart, + 5, end, cend); + cfrom = scm_to_size_t (from); if (SCM_UNBNDP (to)) cto = cfrom + (cend - cstart); @@ -2985,6 +3029,7 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, result = scm_i_make_string (cto - cfrom, &p); + cs = scm_i_string_chars (s); while (cfrom < cto) { int t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart); @@ -2995,6 +3040,7 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, cfrom++; p++; } + scm_remember_upto_here_1 (s); return result; } @@ -3019,9 +3065,9 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, MY_VALIDATE_SUBSTRING_SPEC (1, target, 2, tstart, ctstart, 2, dummy, cdummy); - MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cs, - 6, start, cstart, - 7, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (3, s, + 6, start, cstart, + 7, end, cend); csfrom = scm_to_size_t (sfrom); if (SCM_UNBNDP (sto)) csto = csfrom + (cend - cstart); @@ -3033,6 +3079,7 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, ctstart + (csto - csfrom) <= scm_i_string_length (target)); p = scm_i_string_writable_chars (target) + ctstart; + cs = scm_i_string_chars (s); while (csfrom < csto) { int t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart); @@ -3063,14 +3110,16 @@ SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0, size_t cstart1, cend1, cstart2, cend2; SCM result; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 5, start2, cstart2, + 6, end2, cend2); result = scm_i_make_string (cstart1 + (cend2 - cstart2) + scm_i_string_length (s1) - cend1, &p); + cstr1 = scm_i_string_chars (s1); + cstr2 = scm_i_string_chars (s2); memmove (p, cstr1, cstart1 * sizeof (char)); memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2) * sizeof (char)); memmove (p + cstart1 + (cend2 - cstart2), @@ -3129,7 +3178,9 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, cstr = scm_i_string_chars (s); } } - else SCM_WRONG_TYPE_ARG (2, token_set); + else + SCM_WRONG_TYPE_ARG (2, token_set); + scm_remember_upto_here_1 (s); return result; } @@ -3241,15 +3292,17 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, idx = cstart; while (idx < cend) { - SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx])); + SCM res, ch; + ch = SCM_MAKE_CHAR (cstr[idx]); + res = scm_call_1 (char_pred, ch); if (scm_is_true (res)) - ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + ls = scm_cons (ch, ls); cstr = scm_i_string_chars (s); idx++; } result = scm_reverse_list_to_string (ls); } + scm_remember_upto_here_1 (s); return result; } @@ -3311,22 +3364,21 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, idx = cstart; while (idx < cend) { - SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx])); + SCM res, ch = SCM_MAKE_CHAR (cstr[idx]); + res = scm_call_1 (char_pred, ch); if (scm_is_false (res)) - ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls); + ls = scm_cons (ch, ls); cstr = scm_i_string_chars (s); idx++; } result = scm_reverse_list_to_string (ls); } + + scm_remember_upto_here_1 (s); return result; } #undef FUNC_NAME - -/* Initialize the SRFI-13 module. This function will be called by the - loading Scheme module. */ void scm_init_srfi_13 (void) { From 19ff6ffc064fb24e3e4b860d51b5bdf1499c5ee2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 16:04:30 +0000 Subject: [PATCH 086/100] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 00e4f050d..a6d27d69e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,10 @@ 2004-08-25 Marius Vollmer + * srfi-13.c: First cut at thread-safeness and proper use of + scm_i_string_chars et al. Copious scm_remember_upto_heres have + been inserted. Made sure that no internal string pointer is used + across a SCM_TICK or a possible GC. + * script.c (scm_compile_shell_switches): Use scm_from_locale_string instead of scm_makfrom0str. From c08d10f5f3fe46acda4d837f97e7a2e77b7f4116 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 17:21:04 +0000 Subject: [PATCH 087/100] Include srfi-13.h and srfi-14.h, do not include strop.h. --- libguile.h | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile.h b/libguile.h index fe1351990..3be6dec63 100644 --- a/libguile.h +++ b/libguile.h @@ -110,7 +110,8 @@ extern "C" { #include "libguile/stackchk.h" #include "libguile/stime.h" #include "libguile/strings.h" -#include "libguile/strop.h" +#include "libguile/srfi-13.h" +#include "libguile/srfi-14.h" #include "libguile/strorder.h" #include "libguile/strports.h" #include "libguile/struct.h" From b0d10ba69f3309ffa15649df387cf863d53f1218 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 17:22:14 +0000 Subject: [PATCH 088/100] Tidied up somewhat. --- NEWS | 477 +++++++++++------------------------------------------------ 1 file changed, 87 insertions(+), 390 deletions(-) diff --git a/NEWS b/NEWS index 81f08a67c..e4bc8216a 100644 --- a/NEWS +++ b/NEWS @@ -12,7 +12,7 @@ Each release reports the NEWS in the following sections: * Changes to the C interface -Changes since the stable branch: +Changes since the 1.6.x series: * Changes to the distribution @@ -23,37 +23,21 @@ Changes since the stable branch: ** Guile now requires GNU MP (http://swox.com/gmp). Guile now uses the GNU MP library for arbitrary precision arithmetic. -At the moment it is being used to handle Guile's bignums. ** Guile now has separate private and public configuration headers. -Guile now has config.h and libguile/scmconfig.h. The former is not -installed and is private. The latter is installed and used by Guile's -public headers. config.h is generated by configure and autoheader, -and scmconfig.h is generated by a small C program, gen-scmconfig at -build time based in part on the contents of config.h. - -Seen libguile/__scm.h and gen-scmconfig.c for more information. - -Note too that nearly all public defines are now set to either 1 or 0 -rather than being set to 1 or left undefined. See gen-scmconfig.c and -the GNU Coding Guidelines for the rationale. However, pre-existing -defines that were not renamed were not changed. i.e. GUILE_DEBUG is -still either 1 or undefined. - -** The INSTALL file is now the generic automake installed one. - -Guile specific instructions can be found in the README. +That is, things like HAVE_STRING_H no longer leak from Guile's +headers. ** Guile now provides and uses an "effective" version number. Guile now provides scm_effective_version and effective-version functions which return the "effective" version number. This is just the normal full version string without the final micro-version number, -so the current effective-version is "1.6". The effective version +so the current effective-version is "1.7". The effective version should remain unchanged during a stable series, and should be used for items like the versioned share directory name -i.e. /usr/share/guile/1.6. +i.e. /usr/share/guile/1.7. Providing an unchanging version number during a stable release for things like the versioned share directory can be particularly @@ -86,6 +70,8 @@ you don't trust the thread safety of most of your program, but where you have some section(s) of code which you consider can run in parallel to other sections. +### move rest to manual + They "flag" (with dynamic extent) sections of code to be of "serial" or "parallel" nature and have the single effect of preventing a serial section from being run in parallel with any @@ -126,7 +112,8 @@ This is an implementation of SRFI-31 which provides a special form ** The modules (srfi srfi-13) and (srfi srfi-14) have been merged with the core, making their functionality always available. -The are still available, tho. +The modules are still available, tho, and you use them together with a +renaming import, for example. ** Guile now includes its own version of libltdl. @@ -188,7 +175,7 @@ writing For example (@ (ice-9 pretty-print) pretty-print) will directly access the pretty-print variable exported from the (ice-9 pretty-print) module. You don't need to 'use' that module first. You can also use -'@' with 'set!'. +'@' as a target of 'set!', as in (set! (@ mod var) val). The related syntax (@@ MODULE-NAME VARIABLE-NAME) works just like '@', but it can also access variables that have not been exported. It is @@ -205,12 +192,12 @@ dropped. ** 'call-with-current-continuation' is now also available under the name 'call/cc'. -** Checking for duplicate bindings in module system +** The module system now checks for duplicate bindings. The module system now can check for name conflicts among imported bindings. -The behavior can be controlled by specifying one or more duplicates +The behavior can be controlled by specifying one or more 'duplicates' handlers. For example, to make Guile return an error for every name collision, write: @@ -234,6 +221,8 @@ can add the line: to your .guile init file. +### move rest to manual + The syntax for the :duplicates option is: :duplicates HANDLER-NAME | (HANDLER1-NAME HANDLER2-NAME ...) @@ -286,7 +275,13 @@ a prefix to all imported bindings. will import all bindings exported from bar, but rename them by adding the prefix `bar:'. -** Merging generic functions +** Conflicting generic functions can be automatically merged. + +When two imported bindings conflict and they are both generic +functions, the two functions can now be merged automatically. This is +activated with the 'duplicates' handler 'merge-generics'. + +### move the rest to the manual It is sometimes tempting to use GOOPS accessors with short names. For example, it is tempting to use the name `x' for the x-coordinate @@ -349,10 +344,10 @@ Returns the "effective" version number. This is just the normal full version string without the final micro-version number. See "Changes to the distribution" above. -** Futures: future, make-future, future-ref +** New feature, 'futures': future, make-future, future-ref -Futures are like promises, but begun immediately in a new thread. See -the "Futures" section in the reference manual. +Futures are like promises, but begin execution immediately in a new +thread. See the "Futures" section in the reference manual. ** New threading functions: parallel, letpar, par-map, and friends @@ -376,7 +371,7 @@ A fair condition variable must be used together with a fair mutex, just as a standard condition variable must be used together with a standard mutex. -** New functions: make-fair-mutex, make-fair-condition-variable' +*** New functions: make-fair-mutex, make-fair-condition-variable' Make a new fair mutex and a new fair condition variable respectively. @@ -528,9 +523,9 @@ Previously, (odd? 1.0) would signal an error since only exact integers were recognized as integers. Now (odd? 1.0) returns #t, (odd? 2.0) returns #f and (odd? 1.5) signals an error. -** We now have uninterned symbols. +** Guile now has uninterned symbols. -The new function 'make-symbol' will return a uninterned symbol. This +The new function 'make-symbol' will return an uninterned symbol. This is a symbol that is unique and is guaranteed to remain unique. However, uninterned symbols can not yet be read back in. @@ -556,9 +551,9 @@ when evaluated and simply be ignored in a definition context. ** Deprecated: procedure->macro -Change your code to use either procedure->memoizing-macro or, probably better, -to use r5rs macros. Also, be aware that macro expansion will not be done -during evaluation, but prior to evaluation. +Change your code to use 'define-macro' or r5rs macros. Also, be aware +that macro expansion will not be done during evaluation, but prior to +evaluation. ** Soft ports now allow a `char-ready?' procedure @@ -577,39 +572,6 @@ chapter in the reference manual. There is no replacement for undefine. -** call-with-output-string doesn't segv on closed port - -Previously call-with-output-string would give a segmentation fault if -the string port was closed by the called function. An exception is -raised now. - -** (ice-9 popen) duplicate pipe fd fix - -open-pipe, open-input-pipe and open-output-pipe left an extra copy of -their pipe file descriptor in the child, which was normally harmless, -but it can prevent the parent seeing eof or a broken pipe immediately -and has now been fixed. - -** source-properties and set-source-properties! fix - -Properties set with set-source-properties! can now be read back -correctly with source-properties. - -** SRFI-1 fixes - -delete and delete! now call the "=" procedure with arguments in the -order described by the SRFI-1 specification - -list-copy now accepts improper lists, per the specification. - -** SRFI-4 fixes - -Larger values in 64-bit vectors should print correctly now. - -** SRFI-19 fixes - -date-week-number now correctly respects the requested day of week -starting the week. * Changes to the C interface @@ -667,15 +629,15 @@ Use scm_c_make_rectangular instead. ** The INUM macros have been deprecated. A lot of code uses these macros to do general integer conversions, -although they only work correctly with fixnums. Use the following -alternatives. +although the macros only work correctly with fixnums. Use the +following alternatives. SCM_INUMP -> scm_is_integer or similar SCM_NINUMP -> !scm_is_integer or similar SCM_MAKINUM -> scm_from_int or similar SCM_INUM -> scm_to_int or similar - SCM_VALIDATE_INUM_* -> Do not use these, scm_to_int, etc. will + SCM_VALIDATE_INUM_* -> Do not use these; scm_to_int, etc. will do the validating for you. ** The scm_num2 and scm_2num functions and scm_make_real @@ -720,12 +682,14 @@ easier to use from C. They export too many assumptions about the implementation of strings and symbols that are no longer true in the presence of -mutation-sharing substrings and later, when Guile switches to some -form of Unicode. +mutation-sharing substrings and when Guile switches to some form of +Unicode. When working with strings, it is often best to use the normal string functions provided by Guile, such as scm_c_string_ref, -scm_c_string_set_x, scm_string_append, etc. +scm_c_string_set_x, scm_string_append, etc. Be sure to look in the +manual since many more such functions are now provided than +previously. When you want to convert a SCM string to a C string, use the scm_to_locale_string function or similar instead. For symbols, use @@ -735,7 +699,7 @@ and is thus quite efficient. ** Some string and symbol functions have been discouraged. -They don't fot into the uniform naming scheme and are not explicit +They don't fit into the uniform naming scheme and are not explicit about the character encoding. Replace according to the following table: @@ -747,7 +711,7 @@ Replace according to the following table: scm_str2string -> scm_from_locale_string scm_makfrom0str -> scm_from_locale_string scm_mem2symbol -> scm_from_locale_symboln - scm_mem2uninterned_symbol -> scm_make_symbol + scm_from_locale_stringn + scm_mem2uninterned_symbol -> scm_from_locale_stringn + scm_make_symbol scm_str2symbol -> scm_from_locale_symbol SCM_SYMBOL_HASH -> scm_hashq @@ -755,7 +719,7 @@ Replace according to the following table: ** SCM_CELL_WORD_LOC has been deprecated. -Use the new macro SCM_CELL_OBJECT_LOC instead, which return a pointer +Use the new macro SCM_CELL_OBJECT_LOC instead, which returns a pointer to a SCM, as opposed to a pointer to a scm_t_bits. This was done to allow the correct use of pointers into the Scheme @@ -775,9 +739,9 @@ used to get and set the 16 exra bits in the zeroth word of a smob. And finally, there is SCM_SMOB_OBJECT and SCM_SMOB_SET_OBJECT for accesing the first immediate word of a smob as a SCM value, and there is SCM_SMOB_OBJECT_LOC for getting a pointer to the first immediate -smob words. Like wise for SCM_SMOB_OBJECT_2, etc. +smob word. Like wise for SCM_SMOB_OBJECT_2, etc. -** New way to deal with non-local exits and reentries. +** New way to deal with non-local exits and re-entries. There is a new set of functions that essentially do what scm_internal_dynamic_wind does, but in a way that is more convenient @@ -837,229 +801,46 @@ On platforms that have them, these types are identical to intmax_t and uintmax_t, respectively. On other platforms, they are identical to the largest integer types that Guile knows about. -** scm_unmemocopy and scm_unmemoize have been removed from public use. - -For guile internal use, the functions scm_i_unmemocopy_expr, -scm_i_unmemocopy_body and scm_i_unmemoize_expr are provided to replace -scm_unmemocopy and scm_unmemoize. User code should not have used -scm_unmemocopy and scm_unmemoize and thus should not use the replacement -functions also. - -Background: Formerly, scm_unmemocopy and scm_unmemoize would have allowed to -unmemoize a single expression as well as a sequence of body forms. This would -have lead to problems when unmemoizing code of the new memoizer. Now the two -cases have to be distinguished. +** The functions scm_unmemocopy and scm_unmemoize have been removed. +You should not have used them. ** Many public #defines with generic names have been made private. #defines with generic names like HAVE_FOO or SIZEOF_FOO have been made -private or renamed with a more suitable public name. See below for -the ones which have been renamed. - -** HAVE_STDINT_H and HAVE_INTTYPES_H have been removed from public use. - -HAVE_STDINT_H and HAVE_INTTYPES_H removed from public use. These are -no longer needed since the older uses of stdint.h and inttypes.h are -now handled by configure.in and gen-scmconfig.c. - -** USE_DLL_IMPORT is no longer defined publically. - -gen-scmconfig now uses it to decide what contents to place in the -public scmconfig.h header without adding the USE_DLL_IMPORT itself. - -** HAVE_LIMITS_H has been removed from public use. - -gen-scmconfig now just uses HAVE_LIMITS_H to decide whether or not to -add a limits.h include in scmconfig.h. - -** time.h, sys/time.h, etc. #ifdefery has been removed from public headers. - -gen-scmconfig now just uses the same logic to decide what time related -#includes to add to scmconfig.h. - -** HAVE_STRUCT_TIMESPEC has been removed from public use. - -scmconfig.h now just defines scm_t_timespec. - -** HAVE_PTRDIFF has been removed from public use and Guile doesn't - define ptrdiff_t. - -Guile now publically defines scm_t_ptrdiff and -SCM_SIZEOF_SCM_T_PTRDIFF in scmconfig.h, and all occurrences of -ptrdiff_t have been replaced with scm_t_ptrdiff. - -Guile defines its own type this rather than just relying on ptrdiff_t -and SCM_SIZEOF_PTRDIFF_T because Guile actually typedefs long to -scm_t_ptrdiff when ptrdiff_t isn't available. A public "typedef long -ptrdiff_t" could conflict with other headers. - -** HAVE_UINTPTR_T and HAVE_UINTPTR_T have been removed from public use. - -They are replaced by public definitions of SCM_SIZEOF_UINTPTR_T and -SCM_SIZEOF_INTPTR_T. These are defined to 0 if the corresponding type -is not available. - -** The public #define STDC_HEADERS has been renamed to SCM_HAVE_STDC_HEADERS. - -The previous name was too generic for the global public namespace. - -** The public #define HAVE_SYS_SELECT has been renamed to - SCM_HAVE_SYS_SELECT_H. - -The previous name was too generic for the global public namespace. - -** The public #define HAVE_FLOATINGPOINT_H has been renamed to - SCM_HAVE_FLOATINGPOINT_H. - -The previous name was too generic for the global public namespace. - -** The public #define HAVE_IEEEFP_H has been renamed to SCM_HAVE_IEEEFP_H. - -The previous name was too generic for the global public namespace. - -** The public #define HAVE_NAN_H has been renamed to SCM_HAVE_NAN_H. - -The previous name was too generic for the global public namespace. - -** The public #define HAVE_WINSOCK2_H has been renamed to SCM_HAVE_WINSOCK2_H. - -The previous name was too generic for the global public namespace. - -** The public #define HAVE_ARRAYS has been renamed to SCM_HAVE_ARRAYS. - -The previous name was too generic for the global public namespace. - -** The public #define STACK_GROWS_UP has been renamed to SCM_STACK_GROWS_UP. - -The previous name was too generic for the global public namespace. - -** The public #define USE_PTHREAD_THREADS has been renamed to - SCM_USE_PTHREAD_THREADS. - -The previous name was too generic for the global public namespace. - -** The public #define USE_NULL_THREADS has been renamed to - SCM_USE_NULL_THREADS. - -The previous name was too generic for the global public namespace. - -** The public #define USE_COOP_THREADS has been renamed to - SCM_USE_COOP_THREADS. - -The previous name was too generic for the global public namespace. - -** SCM_C_INLINE is publically defined if possible. - -If the platform has a way to define inline functions, SCM_C_INLINE -will be defined to that text. Otherwise it will be undefined. This -is a little bit different than autoconf's normal handling of the -inline define via AC_C_INLINE. - -** Guile now publically defines some basic type infrastructure. - -Guile always defines - - SCM_SIZEOF_CHAR - SCM_SIZEOF_UNSIGNED_CHAR - SCM_SIZEOF_SHORT - SCM_SIZEOF_UNSIGNED_SHORT - SCM_SIZEOF_LONG - SCM_SIZEOF_UNSIGNED_LONG - SCM_SIZEOF_INT - SCM_SIZEOF_UNSIGNED_INT - SCM_SIZEOF_LONG_LONG /* defined to 0 if type not available */ - SCM_SIZEOF_UNSIGNED_LONG_LONG /* defined to 0 if type not available */ - - scm_t_int8 - scm_t_uint8 - scm_t_int16 - scm_t_uint16 - scm_t_int32 - scm_t_uint32 - -Guile always defines these to 0 or 1 - - SCM_HAVE_T_INT64 - SCM_HAVE_T_UINT64 - -and when either of these are defined to 1, also defines - - scm_t_int64 - scm_t_uint64 - -respectively. - -Guile always defines - - scm_t_timespec - -** The macro SCM_IFLAGP now only returns true for flags - -User code should never have used this macro anyway. And, you should not use -it in the future either. Thus, the following explanation is just for the -impropable case that your code actually made use of this macro, and that you -are willing to depend on internals which will probably change in the near -future. - -Formerly, SCM_IFLAGP also returned true for evaluator bytecodes created with -SCM_MAKSPCSYM (short instructions) and evaluator bytecodes created with -SCM_MAKISYM (short instructions). Now, SCM_IFLAG only returns true for -Guile's special constants created with SCM_MAKIFLAG. To achieve the old -behaviour, instead of - - SCM_IFLAGP(x) - -you would have to write - - (SCM_ISYMP(x) || SCM_IFLAGP(x)) +private or renamed with a more suitable public name. ** The macro SCM_TYP16S has been deprecated. -This macro is not intended for public use. However, if you allocated types -with tc16 type codes in a way that you would have needed this macro, you are -expected to have a deep knowledge of Guile's type system. Thus, you should -know how to replace this macro. +This macro is not intended for public use. ** The macro SCM_SLOPPY_INEXACTP has been deprecated. -Use SCM_INEXACTP instead. +Use scm_is_true (scm_inexact_p (...)) instead. ** The macro SCM_SLOPPY_REALP has been deprecated. -Use SCM_REALP instead. +Use scm_is_real instead. ** The macro SCM_SLOPPY_COMPLEXP has been deprecated. -Use SCM_COMPLEXP instead. +Use scm_is_complex instead. -** The preprocessor define USE_THREADS has been deprecated. +** Some preprocessor defines have been deprecated. -Going forward, assume that the thread API is always present. +These defines indicated whether a certain feature was present in Guile +or not. Going forward, assume that the features are always present. -** The preprocessor define GUILE_ISELECT has been deprecated. +The macros are: USE_THREADS, GUILE_ISELECT, READER_EXTENSIONS, +DEBUG_EXTENSIONS, DYNAMIC_LINKING. -Going forward, assume that scm_internal_select is always present. - -** The preprocessor define READER_EXTENSIONS has been deprecated. - -Going forward, assume that the features represented by -READER_EXTENSIONS are always present. - -** The preprocessor define DEBUG_EXTENSIONS has been deprecated. - -Going forward, assume that the features represented by -DEBUG_EXTENSIONS are always present. - -** The preprocessor define DYNAMIC_LINKING has been deprecated. - -Going forward, assume that the features represented by -DYNAMIC_LINKING are always present. +The following macros have been removed completely: MEMOIZE_LOCALS, +SCM_RECKLESS, SCM_CAUTIOUS. ** The preprocessor define STACK_DIRECTION has been deprecated. There should be no need to know about the stack direction for ordinary -programs. (Do not use.) +programs. ** New function: scm_effective_version @@ -1125,7 +906,7 @@ GUILE_INIT_SEGMENT_SIZE_1, and GUILE_MIN_YIELD_2 should be used. The name scm_definedp is deprecated. -** The struct scm_cell has been renamed to scm_t_cell +** The struct scm_cell type has been renamed to scm_t_cell This is in accordance to Guile's naming scheme for types. Note that the name scm_cell is now used for a function that allocates and @@ -1151,11 +932,6 @@ The old functions for memory management have been deprecated. They are: scm_must_malloc, scm_must_realloc, scm_must_free, scm_must_strdup, scm_must_strndup, scm_done_malloc, scm_done_free. -** New function: scm_str2string - -This function creates a scheme string from a 0-terminated C string. The input -string is copied. - ** Declarations of exported features are marked with SCM_API. Every declaration of a feature that belongs to the exported Guile API @@ -1168,15 +944,16 @@ If you `#define SCM_IMPORT' before including , SCM_API will expand into "__declspec (dllimport) extern", which is needed for linking to the Guile DLL in Windows. -There are also SCM_RL_IMPORT, QT_IMPORT, SCM_SRFI1314_IMPORT, and +There are also SCM_RL_IMPORT, SCM_SRFI1314_IMPORT, and SCM_SRFI4_IMPORT, for the corresponding libraries. ** SCM_NEWCELL and SCM_NEWCELL2 have been deprecated. -Use the new functions scm_cell and scm_double_cell instead. The old macros -had problems because with them allocation and initialization was separated and -the GC could sometimes observe half initialized cells. Only careful coding by -the user of SCM_NEWCELL and SCM_NEWCELL2 could make this safe and efficient. +Use the new functions scm_cell and scm_double_cell instead. The old +macros had problems because with them allocation and initialization +was separated and the GC could sometimes observe half initialized +cells. Only careful coding by the user of SCM_NEWCELL and +SCM_NEWCELL2 could make this safe and efficient. ** CHECK_ENTRY, CHECK_APPLY and CHECK_EXIT have been deprecated. @@ -1189,105 +966,35 @@ Use scm_c_source_property_breakpoint_p instead. ** Deprecated: scm_makmacro -Change your code to use either scm_makmmacro or, probably better, to use r5rs -macros. Also, be aware that macro expansion will not be done during -evaluation, but prior to evaluation. - -** Removed from scm_root_state: def_inp, def_outp, def_errp, together -with corresponding macros scm_def_inp, scm_def_outp and scm_def_errp. -These were undocumented and unused copies of the standard ports at the -time that Guile was initialised. Normally the current ports should be -used instead, obtained from scm_current_input_port () etc. If an -application needs to retain earlier ports, it should save them in a -gc-protected location. - -** Removed compile time option MEMOIZE_LOCALS - -Now, caching of local variable positions during memoization is mandatory. -However, the option to disable the caching has most probably not been used -anyway. - -** Removed compile time option SCM_RECKLESS - -Full number of arguments checking of closures is mandatory now. However, the -option to disable the checking has most probably not been used anyway. - -** Removed compile time option SCM_CAUTIOUS - -Full number of arguments checking of closures is mandatory now. However, the -option to disable the checking has most probably not been used anyway. - -** Deprecated configure flags USE_THREADS and GUILE_ISELECT - -Previously, when the C preprocessor macro USE_THREADS was defined, -libguile included a thread API. This API is now always included, even -when threads are not really supported. Thus, you don't need to test -for USE_THREADS. - -Analogously, GUILE_ISELECT was defined when the function -scm_internal_select was provided by Guile. This function is now -always defined, and GUILE_ISELECT with it. +Change your code to use either scm_makmmacro or to define macros in +Scheme, using 'define-macro'. ** New function scm_c_port_for_each. This function is like scm_port_for_each but takes a pointer to a C function as the callback instead of a SCM value. -** Deprecated definitions of error strings: scm_s_expression, scm_s_test, -scm_s_body, scm_s_bindings, scm_s_variable, scm_s_clauses, scm_s_formals +** Many definitions have been removed that were previously deprecated. -These error message strings were used to issue syntax error messages by -guile's evaluator. It's unlikely that they have been used by user code. - -** Deprecated helper macros for evaluation and application: SCM_EVALIM2, -SCM_EVALIM, SCM_XEVAL, SCM_XEVALCAR - -These macros were used in the implementation of the evaluator. It's unlikely -that they have been used by user code. - -** Deprecated helper functions for evaluation and application: -scm_m_expand_body, scm_macroexp - -These functions were used in the implementation of the evaluator. It's -unlikely that they have been used by user code. - -** Deprecated functions and variables for evaluation and application: -scm_ceval, scm_deval and scm_ceval_ptr - -These functions and variables were used in the implementation of the -evaluator. It's unlikely that they have been used by user code. If you have -used these functions, switch to scm_eval or scm_eval_x. - -** Deprecated functions for unmemoization: scm_unmemocar - -** Deprecated definitions for iloc and isym handling - -SCM_ILOC00, SCM_IDINC, SCM_IDSTMSK, SCM_IFRINC, SCM_ICDR, SCM_IFRAME, -SCM_IDIST, SCM_ICDRP, SCM_ISYMNUM, SCM_ISYMCHARS, scm_isymnames. - -These definitions were used in the implementation of the evaluator. It's -unlikely that they have been used by user code. - -** Removed definitions: scm_lisp_nil, scm_lisp_t, s_nil_ify, -scm_m_nil_ify, s_t_ify, scm_m_t_ify, s_0_cond, scm_m_0_cond, s_0_ify, -scm_m_0_ify, s_1_ify, scm_m_1_ify, scm_debug_newcell, -scm_debug_newcell2, scm_tc16_allocated, SCM_SET_SYMBOL_HASH, -SCM_IM_NIL_IFY, SCM_IM_T_IFY, SCM_IM_0_COND, SCM_IM_0_IFY, -SCM_IM_1_IFY, SCM_GC_SET_ALLOCATED, scm_debug_newcell, -scm_debug_newcell2, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, -SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, -SCM_TICK_SIGNAL, SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS, -scm_top_level_lookup_closure_var, *top-level-lookup-closure*, -scm_system_transformer, scm_eval_3, scm_eval2, -root_module_lookup_closure, SCM_SLOPPY_STRINGP, SCM_RWSTRINGP, -scm_read_only_string_p, scm_make_shared_substring, scm_tc7_substring, -sym_huh, SCM_VARVCELL, SCM_UDVARIABLEP, SCM_DEFVARIABLEP, scm_mkbig, -scm_big2inum, scm_adjbig, scm_normbig, scm_copybig, scm_2ulong2big, -scm_dbl2big, scm_big2dbl, SCM_FIXNUM_BIT, SCM_SETCHARS, -SCM_SLOPPY_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_LENGTH_MAX, -SCM_SETLENGTH, SCM_ROSTRINGP, SCM_ROLENGTH, SCM_ROCHARS, SCM_ROUCHARS, -SCM_SUBSTRP, SCM_COERCE_SUBSTR, scm_sym2vcell, scm_intern, -scm_intern0, scm_sysintern, scm_sysintern0, +scm_lisp_nil, scm_lisp_t, s_nil_ify, scm_m_nil_ify, s_t_ify, +scm_m_t_ify, s_0_cond, scm_m_0_cond, s_0_ify, scm_m_0_ify, s_1_ify, +scm_m_1_ify, scm_debug_newcell, scm_debug_newcell2, +scm_tc16_allocated, SCM_SET_SYMBOL_HASH, SCM_IM_NIL_IFY, SCM_IM_T_IFY, +SCM_IM_0_COND, SCM_IM_0_IFY, SCM_IM_1_IFY, SCM_GC_SET_ALLOCATED, +scm_debug_newcell, scm_debug_newcell2, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, +SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, +SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, SCM_ORD_SIG, +SCM_NUM_SIGS, scm_top_level_lookup_closure_var, +*top-level-lookup-closure*, scm_system_transformer, scm_eval_3, +scm_eval2, root_module_lookup_closure, SCM_SLOPPY_STRINGP, +SCM_RWSTRINGP, scm_read_only_string_p, scm_make_shared_substring, +scm_tc7_substring, sym_huh, SCM_VARVCELL, SCM_UDVARIABLEP, +SCM_DEFVARIABLEP, scm_mkbig, scm_big2inum, scm_adjbig, scm_normbig, +scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl, SCM_FIXNUM_BIT, +SCM_SETCHARS, SCM_SLOPPY_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, +SCM_LENGTH_MAX, SCM_SETLENGTH, SCM_ROSTRINGP, SCM_ROLENGTH, +SCM_ROCHARS, SCM_ROUCHARS, SCM_SUBSTRP, SCM_COERCE_SUBSTR, +scm_sym2vcell, scm_intern, scm_intern0, scm_sysintern, scm_sysintern0, scm_sysintern0_no_module_lookup, scm_init_symbols_deprecated, scm_vector_set_length_x, scm_contregs, scm_debug_info, scm_debug_frame, SCM_DSIDEVAL, SCM_CONST_LONG, SCM_VCELL, @@ -1301,16 +1008,6 @@ SCM_NECONSP, SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL, SCM_GLOC_VAL_LOC, scm_make_gloc, scm_gloc_p, scm_tc16_variable, SCM_CHARS, SCM_LENGTH, SCM_SET_STRING_CHARS, SCM_SET_STRING_LENGTH. -** Deprecated definitions for debugging: scm_debug_mode, SCM_DEBUGGINGP - -These functions were used in the implementation of the evaluator. It's -unlikely that they have been used by user code. - -** Removed macro SCM_MAKSPCSYM - -This macro was used for defining byte codes of the evaluator. It is almost -impossible that user code has used this macro. - Changes since Guile 1.4: From 70bb81136d3a09bc401c1d85ad8e688d3c7e84a3 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 17:22:38 +0000 Subject: [PATCH 089/100] Removed things that are no longer true. Updated in general. --- README | 106 +++++++++++---------------------------------------------- 1 file changed, 19 insertions(+), 87 deletions(-) diff --git a/README b/README index 967a03161..4723760c8 100644 --- a/README +++ b/README @@ -1,6 +1,6 @@ !!! This is not a Guile release; it is a source tree retrieved via anonymous CVS or as a nightly snapshot at some random time after the -Guile 1.4 release. If this were a Guile release, you would not see +Guile 1.6 release. If this were a Guile release, you would not see this message. !!! [fixme: zonk on release] This is a 1.7 development version of Guile, Project GNU's extension @@ -10,7 +10,7 @@ own scripting language. Guile will eventually support other languages as well, giving users of Guile-based applications a choice of languages. -Guile versions with an odd middle number, i.e. 1.5.* are unstable +Guile versions with an odd middle number, i.e. 1.7.* are unstable development versions. Even middle numbers indicate stable versions. This has been the case since the 1.3.* series. @@ -53,23 +53,7 @@ instructions above, but it seems that a few systems still need special treatment. If you can send us fixes for these problems, we'd be grateful. -SunOS 4.1: Guile's shared library support seems to be confused, but - hey; shared libraries are confusing. You may need to configure - Guile with a command like: - ./configure --disable-shared - For more information on `--disable-shared', see below, "Flags - Accepted by Configure". - -HP/UX: GCC 2.7.2 (and maybe other versions) have trouble creating - shared libraries if they depend on any non-shared libraries. GCC - seems to have other problems as well. To work around this, we - suggest you configure Guile to use the system's C compiler: - CC=cc ./configure - -NetBSD: Perry Metzger says, "Guile will build under NetBSD only using - gmake -- the native make will not work. (gmake is in our package - system, so this will not be a problem when we packagize 1.3.)" - + Guile specific flags Accepted by Configure ================================= @@ -79,25 +63,11 @@ switches specific to Guile you may find useful in some circumstances. --with-threads --- Build with thread support - Build a Guile executable and library that supports cooperative - threading. If you use this switch, Guile will also build and - install the QuickThreads non-preemptive threading library, - libqthreads, which you will need to link into your programs after - libguile. When you use `guile-config', you will pick up all - neccessary linker flags automatically. + Build a Guile executable and library that supports multi-threading. - Cooperative threads are not yet thoroughly tested; once they are, - they will be enabled by default. The interaction with blocking I/O - is pretty ad hoc at the moment. In our experience, bugs in the - thread support do not affect you if you don't actually use threads. - ---with-modules --- Specify statically linked `modules' - - Guile can dynamically load `plugin modules' during runtime, using - facilities provided by libtool. Not all platforms support this, - however. On these platforms, you can statically link the plugin - modules into libguile when Guile itself is built. XXX - how does - one specify the modules? + The default is to enable threading support when your operating + system offsers 'POSIX threads'. When you do not want threading, use + `--without-threads'. --enable-deprecated=LEVEL @@ -110,7 +80,7 @@ switches specific to Guile you may find useful in some circumstances. Deprecated features are considered harmful; using them is likely a bug. See below for the related notion of `discouraged' features, - which are OK but have fallen out of favour. + which are OK but have fallen out of favor. See the file NEWS for a list of features that are currently deprecated. Each entry will also tell you what you should replace @@ -173,11 +143,10 @@ switches specific to Guile you may find useful in some circumstances. Normally, both static and shared libraries will be built if your system supports them. - --enable-debug-freelist --- Enable freelist debugging. - This enables a debugging version of SCM_NEWCELL(), and also - registers an extra primitive, the setter + This enables a debugging version of scm_cell and scm_double_cell, + and also registers an extra primitive, the setter `gc-set-debug-check-freelist!'. Configure with the --enable-debug-freelist option to enable the @@ -191,26 +160,17 @@ switches specific to Guile you may find useful in some circumstances. down the interpreter dramatically, so the setter should be used to turn on this extra processing only when necessary. - --enable-debug-malloc --- Enable malloc debugging. - Include code for debugging of calls to scm_must_malloc/realloc/free. + Include code for debugging of calls to scm_malloc, scm_realloc, etc. - Checks that - - 1. objects freed by scm_must_free has been mallocated by scm_must_malloc - 2. objects reallocated by scm_must_realloc has been allocated by - scm_must_malloc - 3. reallocated objects are reallocated with the same what string - - But, most importantly, it records the number of allocated objects of - each kind. This is useful when searching for memory leaks. + It records the number of allocated objects of each kind. This is + useful when searching for memory leaks. A Guile compiled with this option provides the primitive `malloc-stats' which returns an alist with pairs of kind and the number of objects of that kind. - --enable-guile-debug --- Include internal debugging functions --disable-arrays --- omit array and uniform array support --disable-posix --- omit posix interfaces @@ -243,33 +203,9 @@ GUILE_FOR_BUILD variable, it defaults to just "guile". Using Guile Without Installing It ========================================= -If you want to run Guile without installing it, set the environment -variable `GUILE_LOAD_PATH' to a colon-separated list of directories, -including the directory containing this INSTALL file. If you used a -separate build directory, you'll need to include the build directory -in the path as well. - -For example, suppose the Guile distribution unpacked into a directory -called `/home/jimb/guile-snap' (so the full name of this INSTALL file -would be `/home/jimb/guile-snap/INSTALL'). Then you might say, if -you're using Bash or any other Bourne shell variant, - - export GUILE_LOAD_PATH=/home/jimb/guile-snap - -or if you're using CSH or one of its variants: - - setenv GUILE_LOAD_PATH /home/jimb/guile-snap - -You will additionally need to set your `LTDL_LIBRARY_PATH' environment -variable to the directory in which the compiled SRFI support modules -are created if you want to use the modules for SRFI-4, SRFI-13 or -SRFI-14 support. Similar to the example above, this will be, - - export LTDL_LIBRARY_PATH=/home/jimb/guile-snap/srfi/.libs - -or if you're using CSH or one of its variants: - - setenv LTDL_LIBRARY_PATH /home/jimb/guile-snap/srfi/.libs +The top directory of the Guile sources contains a script called +"pre-inst-guile" that can be used to run the Guile that has just been +built. Installing SLIB =========================================================== @@ -304,6 +240,7 @@ Example: (require 'primes) (prime? 7) + Guile Documentation ================================================== If you've never used Scheme before, then the Guile Tutorial @@ -349,8 +286,6 @@ Executables, in ${prefix}/bin: guile-snarf --- a script to parse declarations in your C code for Scheme-visible C functions, Scheme objects to be used by C code, etc. - guile-tools --- a wrapper to invoke the executable modules in - subdirectory `scripts' (also installed). Libraries, in ${prefix}/lib. Depending on the platform and options given to configure, you may get shared libraries in addition @@ -358,12 +293,9 @@ Libraries, in ${prefix}/lib. Depending on the platform and options libguile.a --- an object library containing the Guile interpreter, You can use Guile in your own programs by linking against this. - libqthreads.a --- an object library containing the QuickThreads - primitives. If you enabled thread support when you configured - Guile, you will need to link your code against this too. libguilereadline.a --- an object library containing glue code for the - GNU readline library. See NEWS for instructions on how to enable - readline for your personal use. + GNU readline library. + libguile-srfi-*.a --- various SRFI support libraries Header files, in ${prefix}/include: From 41e4b9926dac3152975aaddc44eee379ca5b08f5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 17:22:52 +0000 Subject: [PATCH 090/100] *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 77d7e4c6e..39bf86d0d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2004-08-25 Marius Vollmer + + * libguile.h: Include srfi-13.h and srfi-14.h, do not include + strop.h. + 2004-08-02 Marius Vollmer * README: Document the new --disable-discouraged option. From c310ad4f20c9828a194bf3a7437f21f9a20c5cfb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 19:02:34 +0000 Subject: [PATCH 091/100] Typos fixed. Use existing functions in explaining symbol and keyword snarfer. --- doc/ref/api-snarf.texi | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/ref/api-snarf.texi b/doc/ref/api-snarf.texi index 988f80db6..fbefda670 100644 --- a/doc/ref/api-snarf.texi +++ b/doc/ref/api-snarf.texi @@ -72,7 +72,7 @@ respectively. While snarfing, they both expand into the initialization code @smallexample -@var{c_name} = scm_permanent_object (scm_from_symbol (@var{scheme_name})); +@var{c_name} = scm_permanent_object (scm_from_locale_symbol (@var{scheme_name})); @end smallexample Thus, you can use them declare a static or global variable of type @@ -98,7 +98,7 @@ respectively. While snarfing, they both expand into the initialization code @smallexample -@var{c_name} = scm_permanent_object (scm_from_keyword (@var{scheme_name})); +@var{c_name} = scm_permanent_object (scm_c_make_keyword (@var{scheme_name})); @end smallexample Thus, you can use them declare a static or global variable of type @@ -132,12 +132,12 @@ respectively. While snarfing, they both expand into the initialization code @smallexample -@var{c_name} = scm_permanent_object (scm_c_define (@var{scheme_name}, @var{value}); +@var{c_name} = scm_permanent_object (scm_c_define (@var{scheme_name}, @var{value})); @end smallexample Thus, you can use them declare a static or global C variable of type @code{SCM} that will be initialized to the object representing the -Scheme variable named d@var{scheme_name} in the current module. The +Scheme variable named @var{scheme_name} in the current module. The variable will be defined when it doesn't already exist. It is always set to @var{value}. @end deffn From c9dc8c6cec0da016b791409186bcd8095b83adb4 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 25 Aug 2004 19:03:14 +0000 Subject: [PATCH 092/100] Additions. --- doc/ref/api-data.texi | 95 +++++++++++++++++++++++++++---------------- 1 file changed, 61 insertions(+), 34 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 8d429ef91..0f50f9ba4 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -667,6 +667,10 @@ predicate will also be fulfilled if @var{x} is a real, rational or integer number. @end deffn +@deftypefn {C Function} int scm_is_complex (SCM val) +Equivalent to @code{scm_is_true (scm_complex_p (val))}. +@end deftypefn + @node Exactness @subsubsection Exact and Inexact Numbers @tpindex Exact numbers @@ -2256,75 +2260,92 @@ character sets. In order to make the use of the character set data type and procedures useful, several predefined character set variables exist. -@defvar char-set:lower-case +@defvr {Scheme Variable} char-set:lower-case +@defvrx {C Variable} scm_char_set_lower_case All lower-case characters. -@end defvar +@end defvr -@defvar char-set:upper-case +@defvr {Scheme Variable} char-set:upper-case +@defvrx {C Variable} scm_char_set_upper_case All upper-case characters. -@end defvar +@end defvr -@defvar char-set:title-case +@defvr {Scheme Variable} char-set:title-case +@defvrx {C Variable} scm_char_set_title_case This is empty, because ASCII has no titlecase characters. -@end defvar +@end defvr -@defvar char-set:letter +@defvr {Scheme Variable} char-set:letter +@defvrx {C Variable} scm_char_set_letter All letters, e.g. the union of @code{char-set:lower-case} and @code{char-set:upper-case}. -@end defvar +@end defvr -@defvar char-set:digit +@defvr {Scheme Variable} char-set:digit +@defvrx {C Variable} scm_char_set_digit All digits. -@end defvar +@end defvr -@defvar char-set:letter+digit +@defvr {Scheme Variable} char-set:letter+digit +@defvrx {C Variable} scm_char_set_letter_and_digit The union of @code{char-set:letter} and @code{char-set:digit}. -@end defvar +@end defvr -@defvar char-set:graphic +@defvr {Scheme Variable} char-set:graphic +@defvrx {C Variable} scm_char_set_graphic All characters which would put ink on the paper. -@end defvar +@end defvr -@defvar char-set:printing +@defvr {Scheme Variable} char-set:printing +@defvrx {C Variable} scm_char_set_printing The union of @code{char-set:graphic} and @code{char-set:whitespace}. -@end defvar +@end defvr -@defvar char-set:whitespace +@defvr {Scheme Variable} char-set:whitespace +@defvrx {C Variable} scm_char_set_whitespace All whitespace characters. -@end defvar +@end defvr -@defvar char-set:blank +@defvr {Scheme Variable} char-set:blank +@defvrx {C Variable} scm_char_set_blank All horizontal whitespace characters, that is @code{#\space} and @code{#\tab}. -@end defvar +@end defvr -@defvar char-set:iso-control +@defvr {Scheme Variable} char-set:iso-control +@defvrx {C Variable} scm_char_set_iso_control The ISO control characters with the codes 0--31 and 127. -@end defvar +@end defvr -@defvar char-set:punctuation +@defvr {Scheme Variable} char-set:punctuation +@defvrx {C Variable} scm_char_set_punctuation The characters @code{!"#%&'()*,-./:;?@@[\\]_@{@}} -@end defvar +@end defvr -@defvar char-set:symbol +@defvr {Scheme Variable} char-set:symbol +@defvrx {C Variable} scm_char_set_symbol The characters @code{$+<=>^`|~}. -@end defvar +@end defvr -@defvar char-set:hex-digit +@defvr {Scheme Variable} char-set:hex-digit +@defvrx {C Variable} scm_char_set_hex_digit The hexadecimal digits @code{0123456789abcdefABCDEF}. -@end defvar +@end defvr -@defvar char-set:ascii +@defvr {Scheme Variable} char-set:ascii +@defvrx {C Variable} scm_char_set_ascii All ASCII characters. -@end defvar +@end defvr -@defvar char-set:empty +@defvr {Scheme Variable} char-set:empty +@defvrx {C Variable} scm_char_set_empty The empty character set. -@end defvar +@end defvr -@defvar char-set:full +@defvr {Scheme Variable} char-set:full +@defvrx {C Variable} scm_char_set_full This character set contains all possible characters. -@end defvar +@end defvr @node Strings @subsection Strings @@ -2373,6 +2394,8 @@ strings created by this procedure are called @dfn{mutation sharing substrings} since the substring and the original string share modifications to each other. +Guile provides all procedures of SRFI-13 and a few more. + @menu * String Syntax:: Read syntax for strings. * String Predicates:: Testing strings for certain properties. @@ -4301,6 +4324,10 @@ Return @code{#t} if @var{obj} is a symbol, otherwise return @code{#f}. @end deffn +@deftypefn {C Function} int scm_is_symbol (SCM val) +Equivalent to @code{scm_is_true (scm_symbol_p (val))}. +@end deftypefn + Once you know that you have a symbol, you can obtain its name as a string by calling @code{symbol->string}. Note that Guile differs by default from R5RS on the details of @code{symbol->string} as regards From cad4775f01ee223e0ae3e61b7d732b2d217d81e6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Aug 2004 14:59:44 +0000 Subject: [PATCH 093/100] *** empty log message *** --- ANNOUNCE | 61 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 ANNOUNCE diff --git a/ANNOUNCE b/ANNOUNCE new file mode 100644 index 000000000..83d622b00 --- /dev/null +++ b/ANNOUNCE @@ -0,0 +1,61 @@ +We are pleased to announce the release of Guile 1.7.1. This is a +'technology preview' for the upcoming Guile 1.8. + +This version is guaranteed to contain serious bugs, and the publically +visible interface will almost certainly change before 1.8 is released. +The 1.7 releases might be termed "selected snapshots". + +We are releasing it anyway to start testing the new features, and to +get feedback about how difficult or tedious it is to switch from Guile +1.6 to this series. + +Ideally, you should be able to just link your program with Guile 1.7.1 +instead of with Guile 1.6.x. You will get many warnings about +deprecated features, but your program should nevertheless run +correctly. If you find that this is not the case (which is quite +likely) please do not change your program yet. Instead, report the +problem to . + +The shared library major versions have been bumped compared to the 1.6 +series, but they will not be bumped on binary incompatible changes +within the 1.7 series. + + +The NEWS file is quite long. Here are the most spectacular entries in +a condensed form: + + Changes since the 1.6.x series: + + - Guile is now licensed with the GNU Lesser General Public License. + + - The manual is now licensed with the GNU Free Documentation License. + + - We now use GNU MP for bignums. + + - We now use native POSIX threads for real concurrent threads. + + - There is now support for copy-on-write substrings and + mutation-sharing substrings. + + - We now have exact rationals, such as 1/3. + + - A new family of functions for converting between C values and + Scheme values has been added that is future-proof and thread-safe. + + - The INUM macros like SCM_MAKINUM have been deprecated. + + - The macros SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_LENGTH, + SCM_SYMBOL_CHARS, and SCM_SYMBOL_LENGTH have been deprecated. + + - There is a new way to deal with non-local exits and re-entries in + C code, which is nicer than scm_internal_dynamic_wind. + + - There are new malloc-like functions that work better than + scm_must_malloc, etc. + +and most importantly + + - call-with-current-continuation is now also available under the name + call/cc. + +See NEWS and the manual for more details. From 16eefe8daadd00206ecade32c85cc7e5864795b8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Aug 2004 15:08:44 +0000 Subject: [PATCH 094/100] Bumped all versions for the 1.7.1 release. Added LIBGUILE_*_MAJOR variables for inclusion in the names of shared libraries such as "libguile-srfi-srfi-1-v-MAJOR.la". Removed LIBQTHREADS_*. --- GUILE-VERSION | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index cf322506f..71d9b5185 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -2,7 +2,7 @@ GUILE_MAJOR_VERSION=1 GUILE_MINOR_VERSION=7 -GUILE_MICRO_VERSION=0 +GUILE_MICRO_VERSION=1 GUILE_EFFECTIVE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION} GUILE_VERSION=${GUILE_EFFECTIVE_VERSION}.${GUILE_MICRO_VERSION} @@ -21,27 +21,31 @@ PACKAGE=guile # See libtool info pages for more information on how and when to # change these. -LIBQTHREADS_INTERFACE_CURRENT=15 -LIBQTHREADS_INTERFACE_REVISION=0 -LIBQTHREADS_INTERFACE_AGE=0 -LIBQTHREADS_INTERFACE="${LIBQTHREADS_INTERFACE_CURRENT}:${LIBQTHREADS_INTERFACE_REVISION}:${LIBQTHREADS_INTERFACE_AGE}" - -LIBGUILE_INTERFACE_CURRENT=15 +LIBGUILE_INTERFACE_CURRENT=16 LIBGUILE_INTERFACE_REVISION=0 LIBGUILE_INTERFACE_AGE=0 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" -LIBGUILE_SRFI_SRFI_1_INTERFACE_CURRENT=1 +# NOTE: Until 1.8, you must edit each corresponding .scm file (the one +# that dynamic-links the relevant lib) if you change the versioning +# information here to make sure the dynamic-link explicitly loads the +# right shared lib version. This requirement should go away before +# 1.8 -- see TODO. + +LIBGUILE_SRFI_SRFI_1_MAJOR=2 +LIBGUILE_SRFI_SRFI_1_INTERFACE_CURRENT=2 LIBGUILE_SRFI_SRFI_1_INTERFACE_REVISION=0 LIBGUILE_SRFI_SRFI_1_INTERFACE_AGE=0 LIBGUILE_SRFI_SRFI_1_INTERFACE="${LIBGUILE_SRFI_SRFI_1_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_1_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_1_INTERFACE_AGE}" -LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT=1 +LIBGUILE_SRFI_SRFI_4_MAJOR=2 +LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT=2 LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION=0 LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE=0 LIBGUILE_SRFI_SRFI_4_INTERFACE="${LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE}" -LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT=1 +LIBGUILE_SRFI_SRFI_13_14_MAJOR=2 +LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT=2 LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION=0 LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE=0 LIBGUILE_SRFI_SRFI_13_14_INTERFACE="${LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE}" From b8b9ec6845c7e3c0680083f77aa81114ea8b50db Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Aug 2004 15:09:36 +0000 Subject: [PATCH 095/100] * GUILE-VERSION: Bumped all versions for the 1.7.1 release. Added LIBGUILE_*_MAJOR variables for inclusion in the names of shared libraries such as "libguile-srfi-srfi-1-v-MAJOR.la". Removed LIBQTHREADS_*. * configure.in: Updated for the new set of variables defined in GUILE-VERSION. --- configure.in | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/configure.in b/configure.in index fe30c6efb..3b369187a 100644 --- a/configure.in +++ b/configure.in @@ -1143,26 +1143,24 @@ AC_SUBST(GUILE_VERSION) ####################################################################### # library versioning -AC_SUBST(LIBQTHREADS_INTERFACE_CURRENT) -AC_SUBST(LIBQTHREADS_INTERFACE_REVISION) -AC_SUBST(LIBQTHREADS_INTERFACE_AGE) -AC_SUBST(LIBQTHREADS_INTERFACE) - AC_SUBST(LIBGUILE_INTERFACE_CURRENT) AC_SUBST(LIBGUILE_INTERFACE_REVISION) AC_SUBST(LIBGUILE_INTERFACE_AGE) AC_SUBST(LIBGUILE_INTERFACE) +AC_SUBST(LIBGUILE_SRFI_SRFI_1_MAJOR) AC_SUBST(LIBGUILE_SRFI_SRFI_1_INTERFACE_CURRENT) AC_SUBST(LIBGUILE_SRFI_SRFI_1_INTERFACE_REVISION) AC_SUBST(LIBGUILE_SRFI_SRFI_1_INTERFACE_AGE) AC_SUBST(LIBGUILE_SRFI_SRFI_1_INTERFACE) +AC_SUBST(LIBGUILE_SRFI_SRFI_4_MAJOR) AC_SUBST(LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT) AC_SUBST(LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION) AC_SUBST(LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE) AC_SUBST(LIBGUILE_SRFI_SRFI_4_INTERFACE) +AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_MAJOR) AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT) AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION) AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE) From 6fcf60d3d535339e940d1c82e8c23c50a923abfa Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Aug 2004 15:10:24 +0000 Subject: [PATCH 096/100] Bumped version number of libguile-ltdl to 2. --- libguile-ltdl/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile-ltdl/Makefile.am b/libguile-ltdl/Makefile.am index 46b613568..0793f33ab 100644 --- a/libguile-ltdl/Makefile.am +++ b/libguile-ltdl/Makefile.am @@ -41,4 +41,4 @@ lib_LTLIBRARIES = libguile-ltdl.la libguile_ltdl_la_SOURCES = guile-ltdl.c #libguile_ltdl_la_DEPENDENCIES = libguile_ltdl_la_LIBADD = ${LIBADD_DL} -libguile_ltdl_la_LDFLAGS = -version-info 1:0:0 -export-dynamic -no-undefined +libguile_ltdl_la_LDFLAGS = -version-info 2:0:0 -export-dynamic -no-undefined From bd453596caa87c1786b188adb37dfb4585a2909d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Aug 2004 15:13:05 +0000 Subject: [PATCH 097/100] * Makefile.am: Added appropriate @LIBGUILE_*_MAJOR@ substitutions to the library names. * srfi-1.scm, srfi-4.scm: Use the new library names with load-extension. --- srfi/Makefile.am | 28 +++++++++++++--------------- srfi/srfi-1.scm | 2 +- srfi/srfi-4.scm | 2 +- 3 files changed, 15 insertions(+), 17 deletions(-) diff --git a/srfi/Makefile.am b/srfi/Makefile.am index a219d7bd6..29c46131a 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -33,26 +33,24 @@ srfiincludedir = $(pkgincludedir)/srfi # These headers are visible as srfiinclude_HEADERS = srfi-1.h srfi-4.h srfi-13.h srfi-14.h -lib_LTLIBRARIES = libguile-srfi-srfi-1.la \ - libguile-srfi-srfi-4.la \ - libguile-srfi-srfi-13-14.la +lib_LTLIBRARIES = \ + libguile-srfi-srfi-1-v-@LIBGUILE_SRFI_SRFI_1_MAJOR@.la \ + libguile-srfi-srfi-4-v-@LIBGUILE_SRFI_SRFI_4_MAJOR@.la \ + libguile-srfi-srfi-13-14-v-@LIBGUILE_SRFI_SRFI_13_14_MAJOR@.la BUILT_SOURCES = srfi-1.x srfi-4.x srfi-13.x srfi-14.x -libguile_srfi_srfi_1_la_SOURCES = srfi-1.x srfi-1.c -libguile_srfi_srfi_1_la_LIBADD = ../libguile/libguile.la -libguile_srfi_srfi_1_la_LDFLAGS = -no-undefined -export-dynamic \ - -version-info @LIBGUILE_SRFI_SRFI_1_INTERFACE@ +libguile_srfi_srfi_1_v_@LIBGUILE_SRFI_SRFI_1_MAJOR@_la_SOURCES = srfi-1.x srfi-1.c +libguile_srfi_srfi_1_v_@LIBGUILE_SRFI_SRFI_1_MAJOR@_la_LIBADD = ../libguile/libguile.la +libguile_srfi_srfi_1_v_@LIBGUILE_SRFI_SRFI_1_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_1_INTERFACE@ -libguile_srfi_srfi_4_la_SOURCES = srfi-4.x srfi-4.c -libguile_srfi_srfi_4_la_LIBADD = ../libguile/libguile.la -libguile_srfi_srfi_4_la_LDFLAGS = -no-undefined -export-dynamic \ - -version-info @LIBGUILE_SRFI_SRFI_4_INTERFACE@ +libguile_srfi_srfi_4_v_@LIBGUILE_SRFI_SRFI_4_MAJOR@_la_SOURCES = srfi-4.x srfi-4.c +libguile_srfi_srfi_4_v_@LIBGUILE_SRFI_SRFI_4_MAJOR@_la_LIBADD = ../libguile/libguile.la +libguile_srfi_srfi_4_v_@LIBGUILE_SRFI_SRFI_4_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_4_INTERFACE@ -libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c -libguile_srfi_srfi_13_14_la_LIBADD = ../libguile/libguile.la -libguile_srfi_srfi_13_14_la_LDFLAGS = -no-undefined -export-dynamic \ - -version-info @LIBGUILE_SRFI_SRFI_13_14_INTERFACE@ +libguile_srfi_srfi_13_14_v_@LIBGUILE_SRFI_SRFI_13_14_MAJOR@_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c +libguile_srfi_srfi_13_14_v_@LIBGUILE_SRFI_SRFI_13_14_MAJOR@_la_LIBADD = ../libguile/libguile.la +libguile_srfi_srfi_13_14_v_@LIBGUILE_SRFI_SRFI_13_14_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_13_14_INTERFACE@ srfidir = $(datadir)/guile/$(GUILE_EFFECTIVE_VERSION)/srfi srfi_DATA = srfi-1.scm \ diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index c3b8d719f..28ddb3043 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -222,7 +222,7 @@ ;; Load the compiled primitives from the shared library. ;; -(load-extension "libguile-srfi-srfi-1" "scm_init_srfi_1") +(load-extension "libguile-srfi-srfi-1-v-2" "scm_init_srfi_1") ;;; Constructors diff --git a/srfi/srfi-4.scm b/srfi/srfi-4.scm index 62650fe96..715b555c4 100644 --- a/srfi/srfi-4.scm +++ b/srfi/srfi-4.scm @@ -76,7 +76,7 @@ ;; Load the compiled primitives from the shared library. ;; -(load-extension "libguile-srfi-srfi-4" "scm_init_srfi_4") +(load-extension "libguile-srfi-srfi-4-v-2" "scm_init_srfi_4") ;; Reader extension for #f32() and #f64() vectors. From e5ab7101aaf9934ab03e5e95b7b08402c2a92ebf Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Aug 2004 15:16:10 +0000 Subject: [PATCH 098/100] * LIBGUILEREADLINE-VERSION: Bumped versions for the 1.7.1 release. Added LIBGUILEREADLINE_MAJOR variable for inclusion in the name of the shared library. * configure.in: AC_SUBST it. * Makefile.am: Substitute it into name of library. --- guile-readline/LIBGUILEREADLINE-VERSION | 3 ++- guile-readline/Makefile.am | 9 ++++----- guile-readline/configure.in | 1 + 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/guile-readline/LIBGUILEREADLINE-VERSION b/guile-readline/LIBGUILEREADLINE-VERSION index ecab91095..02f8493a4 100644 --- a/guile-readline/LIBGUILEREADLINE-VERSION +++ b/guile-readline/LIBGUILEREADLINE-VERSION @@ -7,7 +7,8 @@ # source this file from configure.in. Later we may automate more of # this. -LIBGUILEREADLINE_INTERFACE_CURRENT=10 +LIBGUILEREADLINE_MAJOR=16 +LIBGUILEREADLINE_INTERFACE_CURRENT=16 LIBGUILEREADLINE_INTERFACE_REVISION=0 LIBGUILEREADLINE_INTERFACE_AGE=0 LIBGUILEREADLINE_INTERFACE="${LIBGUILEREADLINE_INTERFACE_CURRENT}:${LIBGUILEREADLINE_INTERFACE_REVISION}:${LIBGUILEREADLINE_INTERFACE_AGE}" diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am index c3f9cd332..6b62dfb0a 100644 --- a/guile-readline/Makefile.am +++ b/guile-readline/Makefile.am @@ -30,12 +30,11 @@ INCLUDES = -I.. -I$(srcdir)/.. GUILE_SNARF = ../libguile/guile-snarf -lib_LTLIBRARIES = libguilereadline.la +lib_LTLIBRARIES = libguilereadline-v-@LIBGUILEREADLINE_MAJOR@.la -libguilereadline_la_SOURCES = readline.c -libguilereadline_la_LIBADD = ../libguile/libguile.la -libguilereadline_la_LDFLAGS = -version-info @LIBGUILEREADLINE_INTERFACE@ \ - -export-dynamic -no-undefined +libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_SOURCES = readline.c +libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LIBADD = ../libguile/libguile.la +libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LDFLAGS = -version-info @LIBGUILEREADLINE_INTERFACE@ -export-dynamic -no-undefined BUILT_SOURCES = readline.x diff --git a/guile-readline/configure.in b/guile-readline/configure.in index 18cbe8d47..1f0a08cd4 100644 --- a/guile-readline/configure.in +++ b/guile-readline/configure.in @@ -132,6 +132,7 @@ fi AC_CHECK_FUNCS(strdup) . $srcdir/LIBGUILEREADLINE-VERSION +AC_SUBST(LIBGUILEREADLINE_MAJOR) AC_SUBST(LIBGUILEREADLINE_INTERFACE_CURRENT) AC_SUBST(LIBGUILEREADLINE_INTERFACE_REVISION) AC_SUBST(LIBGUILEREADLINE_INTERFACE_AGE) From 51fab002a8fd542da204703af521319711565390 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Aug 2004 15:16:21 +0000 Subject: [PATCH 099/100] *** empty log message *** --- ChangeLog | 9 ++++ guile-readline/ChangeLog | 8 +++ libguile-ltdl/ChangeLog | 108 --------------------------------------- srfi/ChangeLog | 7 +++ 4 files changed, 24 insertions(+), 108 deletions(-) diff --git a/ChangeLog b/ChangeLog index 39bf86d0d..94b5cc32d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2004-08-26 Marius Vollmer + + * GUILE-VERSION: Bumped all versions for the 1.7.1 release. Added + LIBGUILE_*_MAJOR variables for inclusion in the names of shared + libraries such as "libguile-srfi-srfi-1-v-MAJOR.la". Removed + LIBQTHREADS_*. + * configure.in: Updated for the new set of variables defined in + GUILE-VERSION. + 2004-08-25 Marius Vollmer * libguile.h: Include srfi-13.h and srfi-14.h, do not include diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 045ec2816..4c24216ed 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,11 @@ +2004-08-26 Marius Vollmer + + * LIBGUILEREADLINE-VERSION: Bumped versions for the 1.7.1 release. + Added LIBGUILEREADLINE_MAJOR variable for inclusion in the name of + the shared library. + * configure.in: AC_SUBST it. + * Makefile.am: Substitute it into name of library. + 2004-08-19 Marius Vollmer * readline.c: Avoid the use of discouraged or diff --git a/libguile-ltdl/ChangeLog b/libguile-ltdl/ChangeLog index 6c19c2366..e69de29bb 100644 --- a/libguile-ltdl/ChangeLog +++ b/libguile-ltdl/ChangeLog @@ -1,108 +0,0 @@ -2003-05-29 Stefan Jahn - - * raw-ltdl.c: Some more modifications for mingw32 platforms. - -2003-03-24 Marius Vollmer - - * raw-ltdl.c: Include instead of - . - -2002-10-27 Gary Houston - - * upstream/Makefile.am (ltdl.h.diff, ltdl.c.diff): add $(srcdir) - first file in diff commands. - -2002-10-25 Marius Vollmer - - * upstream/ltdl.c: New copy from libtool 1.4.3. - * raw-ltdl.c: Merged in changes from libtool 1.4.3. - -2002-10-11 Marius Vollmer - - * upstream/Makefile.am (ltdl.h.diff, ltdl.c.diff): Look for - raw-ltdl.h and raw-ltdl.c in "$(srcdir)/..". This is needed for - VPATH builds. - - * Makefile.am (INCLUDES): Also look for includes in "." and - "$(srcdir)". This is needed for VPATH builds. - (EXTRA_DIST): Also distribute EXTRA_HEADERS. - -2002-10-09 Rob Browning - - * upstream/Makefile.am (ltdl.h.diff): remove - SCM_INSERTED_DLSYMLIST_STRUCT_DECL during diff computation. - (ltdl.c.diff): remove SCM_INSERTED_DLSYMLIST_STRUCT_DECL during - diff computation. - - * raw-ltdl.h: add SCM_INSERTED_DLSYMLIST_STRUCT_DECL so we can - insert our own struct name here. - - * guile-ltdl.h: add scm_lt_dlsymlist typedef. - (scm_lt_dlpreload_default): new function. Replaces - scm_lt_dlset_preloaded_symbols which depended on global that - libtool automagically defines in binaries, not libs. - - * guile-ltdl.c (scm_lt_dlpreload_default): new function. Replaces - scm_lt_dlset_preloaded_symbols which depended on global that - libtool automagically defines in binaries, not libs. Now the call - in guile.c has to pass us that magic value. - (SCM_INSERTED_DLSYMLIST_STRUCT_DECL): used to add a struct name in - the lt_dlsymlist typedef -- we use such a crazy name so we can - remove this in the upstream diff computation. - -2002-10-05 Marius Vollmer - - * upstream/Makefile.am (ltdl.h.diff, ltdl.c.diff): Create them in - '.' not in 'upstream' since we are already in upstream. - -2002-10-04 Rob Browning - - * COPYING.LIB: moved from ../libltdl. - - * ChangeLog: moved from ../libltdl. - - * README: moved from ../libltdl. - - * Makefile.am: build new libguile-ltdl. - - * upstream/Makefile.am: new file. - - * upstream/ltdl.c: upstream source. - - * upstream/ltdl.h: upstream source. - - * guile-ltdl.h: main header file for guile's internal - libguile-ltdl. - - * guile-ltdl.c: main source file for libguile-ltdl -- #includes - raw-ltdl.c and raw-ldtl.h directly. See README. - - * raw-ltdl.h: guile's modified version of the upstream ltdl.h. - - * raw-ltdl.c: guile's modified version of the upstream ltdl.c. - (memcpy): coerce ptrs to (char *) before copying characters - through them -- I can't recall for sure, but I believe this was - causing an overrun error at times. - (realloc): Remove custom realloc. (#define rpl_realloc realloc) - and comment out later code for custom realloc. You can't define - your own malloc unless you know enough about the malloc in use to - be able to tell how big the src ptr is. The disabled code - incorrectly used the *destination* ptr to decide how much to copy. - This sometimes results in out-of-bound accesses which cause - segfaults. This is a quick hack for now; we may want something - cleaner later. - (tryall_dlopen_module): check to be sure (dirname_len > 0) before - testing first character against '/'. - (try_dlopen): check for feof(file) in read loop -- otherwise - infloop? - (scm_lt_dlopenext): remove unused variable file_found. - (LT_EOS_CHAR): moved here from guile-ltdl.h. - -2002-10-04 Marius Vollmer - - * raw-ltdl.c: Renamed all exported functions and variables to have a - "scm_lt_" prefix. - (try_dlopen): Set newhandle to null when try_all_dlopen failed. - (scm_lt_dlopenext): Reverse test of "file_not_found()". - Previously, we would stop searching when the file wasn't found - yet, while we should continue in that case. diff --git a/srfi/ChangeLog b/srfi/ChangeLog index a35dfdfd7..30c62f840 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,10 @@ +2004-08-26 Marius Vollmer + + * Makefile.am: Added appropriate @LIBGUILE_*_MAJOR@ substitutions + to the library names. + * srfi-1.scm, srfi-4.scm: Use the new library names with + load-extension. + 2004-08-25 Marius Vollmer SRFI-13 and SRFI-14 have been moved into the core. From 0e33f862345b2fc072b9bc10e59c0677f61da3ee Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 26 Aug 2004 15:16:56 +0000 Subject: [PATCH 100/100] * LIBGUILEREADLINE-VERSION: Bumped versions for the 1.7.1 release. Added LIBGUILEREADLINE_MAJOR variable for inclusion in the name of the shared library. * configure.in: AC_SUBST it. * Makefile.am: Substitute it into name of library. * ice-9/readline.scm: Use new name with load-extension. --- guile-readline/ice-9/readline.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index 1f61a8a98..ad40dcba2 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -35,7 +35,7 @@ ;;; but only when it isn't already present. (if (not (provided? 'readline)) - (load-extension "libguilereadline" "scm_init_readline")) + (load-extension "libguilereadline-v-16" "scm_init_readline")) (if (not (provided? 'readline)) (scm-error 'misc-error