From 22647fef9fb2806fd29474702edbb1187e82fa87 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 12 Jul 2001 23:28:53 +0000 Subject: [PATCH 01/11] *** empty log message *** --- ice-9/ChangeLog | 14 ++++++++++++++ srfi/ChangeLog | 5 +++++ test-suite/ChangeLog | 4 ++++ 3 files changed, 23 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index ed434d630..ea0fc5b95 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,17 @@ +2001-07-13 Marius Vollmer + + * safe-r5rs.scm: Use `re-export' instead of `export' for + re-exported core bindings. Do not re-export `numerator', + `denominator' and `rationalize' since Guile does not have them. + Continue to use `export' for `null-environment'. + + * null.scm: Use `re-export' instead of `export' for re-exported + core bindings. Do not export `unquote' and `unquote-splicing' + since there aren't definitions for them. + + * boot-9.scm (compile-interface-spec): Bug fix: the keyword + argument is "renamer" not "rename". + 2001-07-09 Rob Browning * boot-9.scm: Fixed the sense of the error message when read-eval? diff --git a/srfi/ChangeLog b/srfi/ChangeLog index dc6ee8cf0..16861e10b 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2001-07-13 Marius Vollmer + + * srfi-2.scm (and-let*): Use `re-export-syntax' instead of + `export-syntax'. + 2001-07-11 Gary Houston * srfi-14.c (s_scm_char_set_eq): bug fix: (char-set=) should diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 12be6b2e2..e1baec7d3 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-07-13 Marius Vollmer + + * tests/import.test: New file. + 2001-06-30 Dirk Herrmann * tests/goops.test: Started with some real tests. From 61897afe9a5950c5369c954c685d52d7d8aad7ce Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 14 Jul 2001 09:40:10 +0000 Subject: [PATCH 02/11] Re-add authorship info. --- scripts/PROGRAM | 2 ++ scripts/display-commentary | 2 ++ scripts/doc-snarf | 2 ++ scripts/generate-autoload | 2 ++ scripts/punify | 2 ++ scripts/read-scheme-source | 2 ++ scripts/snarf-check-and-output-texi | 2 ++ scripts/use2dot | 2 ++ 8 files changed, 16 insertions(+) diff --git a/scripts/PROGRAM b/scripts/PROGRAM index 74a4f3cff..3511ccdfc 100755 --- a/scripts/PROGRAM +++ b/scripts/PROGRAM @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: J.R.Hacker + ;;; Commentary: ;; Usage: PROGRAM [ARGS] diff --git a/scripts/display-commentary b/scripts/display-commentary index 4d1b17f0a..1eeb842d8 100755 --- a/scripts/display-commentary +++ b/scripts/display-commentary @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: display-commentary FILE1 FILE2 ... diff --git a/scripts/doc-snarf b/scripts/doc-snarf index 6279c9c68..941682e78 100755 --- a/scripts/doc-snarf +++ b/scripts/doc-snarf @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Martin Grabmueller + ;;; Commentary: ;; Usage: doc-snarf FILE diff --git a/scripts/generate-autoload b/scripts/generate-autoload index d1e5ba3b9..eef2b88c5 100755 --- a/scripts/generate-autoload +++ b/scripts/generate-autoload @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: generate-autoload [OPTIONS] FILE1 FILE2 ... diff --git a/scripts/punify b/scripts/punify index 8101550f2..1cc318fb6 100755 --- a/scripts/punify +++ b/scripts/punify @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: punify FILE1 FILE2 ... diff --git a/scripts/read-scheme-source b/scripts/read-scheme-source index 6a82938e4..48e96058a 100755 --- a/scripts/read-scheme-source +++ b/scripts/read-scheme-source @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: read-scheme-source FILE1 FILE2 ... diff --git a/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi index b61e77d34..e3c84f540 100755 --- a/scripts/snarf-check-and-output-texi +++ b/scripts/snarf-check-and-output-texi @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Michael Livshin + ;;; Code: (define-module (scripts snarf-check-and-output-texi) diff --git a/scripts/use2dot b/scripts/use2dot index b52276a38..d2cb64695 100755 --- a/scripts/use2dot +++ b/scripts/use2dot @@ -22,6 +22,8 @@ exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;; Boston, MA 02111-1307 USA +;;; Author: Thien-Thi Nguyen + ;;; Commentary: ;; Usage: use2dot [OPTIONS] [FILE ...] From 08576c585e0b47c4bba12b6eec582934c00e743f Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 14 Jul 2001 09:40:59 +0000 Subject: [PATCH 03/11] *** empty log message *** --- scripts/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index a4f4f8195..257fdad91 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,9 @@ +2001-07-14 Thien-Thi Nguyen + + * PROGRAM, display-commentary, doc-snarf, generate-autoload, + punify, read-scheme-source, snarf-check-and-output-texi, use2dot: + Re-add authorship info. + 2001-07-12 Michael Livshin * snarf-check-and-output-texi (do-argpos): complain to the stderr, From 4be5d9762537a44720e31e135f084080f51df18b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Sat, 14 Jul 2001 11:11:48 +0000 Subject: [PATCH 04/11] * examples/modules/main: Use :renamer for specifying renaming procedure. --- examples/ChangeLog | 4 ++++ examples/modules/main | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/examples/ChangeLog b/examples/ChangeLog index 99e51f89c..d7a556d59 100644 --- a/examples/ChangeLog +++ b/examples/ChangeLog @@ -1,3 +1,7 @@ +2001-07-14 Martin Grabmueller + + * modules/main: Use :renamer for specifying renaming procedure. + 2001-07-10 Thien-Thi Nguyen * scripts/hello (display-version, display-help): Fix comment; nfc. diff --git a/examples/modules/main b/examples/modules/main index 603ea10f1..e4cc71dc7 100644 --- a/examples/modules/main +++ b/examples/modules/main @@ -22,7 +22,7 @@ ;; Module 1 is imported completely, too, but the procedure names are ;; prefixed with the module name. ;; - :use-module ((module-1) :rename (symbol-prefix-proc 'module-1:)) + :use-module ((module-1) :renamer (symbol-prefix-proc 'module-1:)) ;; From module 2, only the procedure `braz' is imported, so that the ;; procedures `foo' and `bar' also exported by that module don't From 396f36cdbfe40800a6aeacbdf3ceca7ddbd1a962 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 15 Jul 2001 15:16:31 +0000 Subject: [PATCH 05/11] * srfi-14.c (scm_char_set_hash): recognise 0 instead of #f in the opt arg to give default bound, as in final spec. don't allow negative bounds. --- srfi/ChangeLog | 6 ++++++ srfi/srfi-14.c | 14 ++++++++++---- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 16861e10b..9a75116cc 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2001-07-15 Gary Houston + + * srfi-14.c (scm_char_set_hash): recognise 0 instead of #f in the + opt arg to give default bound, as in final spec. don't allow + negative bounds. + 2001-07-13 Marius Vollmer * srfi-2.scm (and-let*): Use `re-export-syntax' instead of diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index b18cb1251..e3fbbcc1e 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -178,20 +178,26 @@ SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1, SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, (SCM cs, SCM bound), "Compute a hash value for the character set @var{cs}. If\n" - "@var{bound} is given and not @code{#f}, it restricts the\n" + "@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 int default_bnd = 871; int bnd; long * p; unsigned val = 0; int k; SCM_VALIDATE_SMOB (1, cs, charset); - if (SCM_UNBNDP (bound) || SCM_FALSEP (bound)) - bnd = 871; + + if (SCM_UNBNDP (bound)) + bnd = default_bnd; else - SCM_VALIDATE_INUM_COPY (2, bound, bnd); + { + SCM_VALIDATE_INUM_MIN_COPY (2, bound, 0, bnd); + if (bnd == 0) + bnd = default_bnd; + } p = (long *) SCM_SMOB_DATA (cs); for (k = 0; k < SCM_CHARSET_SIZE - 1; k++) From b87f5a839490236ce76deb873e81cdec9a477269 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Sun, 15 Jul 2001 18:54:28 +0000 Subject: [PATCH 06/11] (scm_char_set_hash): bug fix: was overrunning the buffer and calculating based on garbage. (scm_char_set_eq, scm_char_set_leq): fix argument number in error reporting: wasn't incremented due to macro coding. (scm_char_set): report argument number in error reporting: was hard coded to 1. remove a couple of local variables. --- srfi/ChangeLog | 6 ++++++ srfi/srfi-14.c | 21 +++++++++++---------- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 9a75116cc..8b467df17 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -3,6 +3,12 @@ * srfi-14.c (scm_char_set_hash): recognise 0 instead of #f in the opt arg to give default bound, as in final spec. don't allow negative bounds. + (scm_char_set_hash): bug fix: was overrunning the buffer and + calculating based on garbage. + (scm_char_set_eq, scm_char_set_leq): fix argument number in error + reporting: wasn't incremented due to macro coding. + (scm_char_set): report argument number in error reporting: was + hard coded to 1. remove a couple of local variables. 2001-07-13 Marius Vollmer diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index e3fbbcc1e..685ee89bc 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -126,7 +126,8 @@ SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, SCM csi = SCM_CAR (char_sets); long *csi_data; - SCM_VALIDATE_SMOB (argnum++, csi, charset); + SCM_VALIDATE_SMOB (argnum, csi, charset); + argnum++; csi_data = (long *) SCM_SMOB_DATA (csi); if (cs1_data == NULL) cs1_data = csi_data; @@ -155,7 +156,8 @@ SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1, SCM csi = SCM_CAR (char_sets); long *csi_data; - SCM_VALIDATE_SMOB (argnum++, csi, charset); + SCM_VALIDATE_SMOB (argnum, csi, charset); + argnum++; csi_data = (long *) SCM_SMOB_DATA (csi); if (prev_data) { @@ -200,7 +202,7 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, } p = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < SCM_CHARSET_SIZE - 1; k++) + for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) { val = p[k] ^ val; } @@ -458,21 +460,20 @@ SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1, "Return a character set containing all given characters.") #define FUNC_NAME s_scm_char_set { - SCM cs, ls; + SCM cs; long * p; + int argnum = 1; SCM_VALIDATE_REST_ARGUMENT (rest); - ls = rest; cs = make_char_set (FUNC_NAME); p = (long *) SCM_SMOB_DATA (cs); - while (!SCM_NULLP (ls)) + while (!SCM_NULLP (rest)) { - SCM chr = SCM_CAR (ls); int c; - SCM_VALIDATE_CHAR_COPY (1, chr, c); - ls = SCM_CDR (ls); - + SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c); + argnum++; + rest = SCM_CDR (rest); p[c / sizeof (long)] |= 1 << (c % sizeof (long)); } return cs; From 5a1a7950e69b75974d64e2382913f045087a4900 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 15 Jul 2001 21:50:23 +0000 Subject: [PATCH 07/11] Remove onerous authorship-info deletion clause. --- HACKING | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/HACKING b/HACKING index ddec624c8..12ed66312 100644 --- a/HACKING +++ b/HACKING @@ -287,7 +287,7 @@ and I'll take care of the administrivia. Put the contributions aside until we have the necessary papers. Once you accept a contribution, be sure to keep the files AUTHORS and -THANKS uptodate. Feel free to remove authorship info from source files. +THANKS uptodate. - When you make substantial changes to a file, add the current year to the list of years in the copyright notice at the top of the file. From 8f2ecec52e812ee6dd90c184d4502d10a920e939 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 15 Jul 2001 21:52:25 +0000 Subject: [PATCH 08/11] *** empty log message *** --- ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog b/ChangeLog index 88b76cccf..3af3aa9cd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2001-07-15 Thien-Thi Nguyen + + * HACKING: Remove onerous authorship-info deletion clause. + 2001-07-13 Keisuke Nishida * autogen.sh: Call libtoolize with --force. From 63bcad1964527df2d658035766467b2f782fb043 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 16 Jul 2001 10:22:38 +0000 Subject: [PATCH 09/11] * Minor changes. --- libguile/ChangeLog | 10 + libguile/fports.c | 2 +- libguile/num2integral.i.c | 4 +- libguile/symbols-deprecated.c | 635 ---------------------------------- libguile/vectors.c | 2 - 5 files changed, 13 insertions(+), 640 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a78276fbb..b1663b21f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2001-07-16 Dirk Herrmann + + * fports.c (fport_print): Don't use SCM_C[AD]R for non pairs. + + * num2integral.i.c (INTEGRAL2NUM, INTEGRAL2BIG): Fix signedness. + + * symbols-deprecated.c (scm_gentemp): Simplify vector test. + + * vectors.c (scm_vector_p): Eliminate redundant IMP test. + 2001-07-12 Michael Livshin * strings.c (s_scm_string): fix arg position in assert. diff --git a/libguile/fports.c b/libguile/fports.c index 8ccfeab70..9466214b2 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -515,7 +515,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); scm_putc (' ', port); - scm_intprint (SCM_UNPACK (SCM_CDR (exp)), 16, port); + scm_intprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port); } scm_putc ('>', port); return 1; diff --git a/libguile/num2integral.i.c b/libguile/num2integral.i.c index f273eef89..e0982bac3 100644 --- a/libguile/num2integral.i.c +++ b/libguile/num2integral.i.c @@ -92,7 +92,7 @@ INTEGRAL2NUM (ITYPE n) SCM_POSFIXABLE (n) #endif ) - return SCM_MAKINUM ((long) n); + return SCM_MAKINUM ((scm_t_signed_bits) n); #ifdef SCM_BIGDIG return INTEGRAL2BIG (n); @@ -108,7 +108,7 @@ INTEGRAL2BIG (ITYPE n) { SCM res; int neg_p; - int n_digits; + unsigned int n_digits; size_t i; SCM_BIGDIG *digits; diff --git a/libguile/symbols-deprecated.c b/libguile/symbols-deprecated.c index 6157966f0..e69de29bb 100644 --- a/libguile/symbols-deprecated.c +++ b/libguile/symbols-deprecated.c @@ -1,635 +0,0 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - - - - -#include "libguile/_scm.h" -#include "libguile/chars.h" -#include "libguile/eval.h" -#include "libguile/hash.h" -#include "libguile/smob.h" -#include "libguile/variable.h" -#include "libguile/alist.h" -#include "libguile/fluids.h" -#include "libguile/strings.h" -#include "libguile/vectors.h" -#include "libguile/hashtab.h" -#include "libguile/weaks.h" -#include "libguile/modules.h" -#include "libguile/deprecation.h" - -#include "libguile/validate.h" -#include "libguile/symbols.h" - -#ifdef HAVE_STRING_H -#include -#endif - - - -#if SCM_ENABLE_VCELLS - -/* scm_sym2ovcell - * looks up the symbol in an arbitrary obarray. - */ - -SCM -scm_sym2ovcell_soft (SCM sym, SCM obarray) -{ - SCM lsym, z; - size_t hash = SCM_SYMBOL_HASH (sym) % SCM_VECTOR_LENGTH (obarray); - - scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. " - "Use hashtables instead."); - - SCM_REDEFER_INTS; - for (lsym = SCM_VELTS (obarray)[hash]; - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - z = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (z), sym)) - { - SCM_REALLOW_INTS; - return z; - } - } - SCM_REALLOW_INTS; - return SCM_BOOL_F; -} - - -SCM -scm_sym2ovcell (SCM sym, SCM obarray) -#define FUNC_NAME "scm_sym2ovcell" -{ - SCM answer; - - scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. " - "Use hashtables instead."); - - answer = scm_sym2ovcell_soft (sym, obarray); - if (!SCM_FALSEP (answer)) - return answer; - SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym)); - return SCM_UNSPECIFIED; /* not reached */ -} -#undef FUNC_NAME - - -/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. - - OBARRAY should be a vector of lists, indexed by the name's hash - value, modulo OBARRAY's length. Each list has the form - ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the - value associated with that symbol (in the current module? in the - system module?) - - To "intern" a symbol means: if OBARRAY already contains a symbol by - that name, return its (SYMBOL . VALUE) pair; otherwise, create a - new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the - appropriate list of the OBARRAY, and return the pair. - - If softness is non-zero, don't create a symbol if it isn't already - in OBARRAY; instead, just return #f. - - If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and - return (SYMBOL . SCM_UNDEFINED). */ - - -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); - size_t hash; - SCM lsym; - - scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. " - "Use hashtables instead."); - - if (SCM_FALSEP (obarray)) - { - if (softness) - return SCM_BOOL_F; - else - return scm_cons (symbol, SCM_UNDEFINED); - } - - hash = raw_hash % SCM_VECTOR_LENGTH (obarray); - - for (lsym = SCM_VELTS (obarray)[hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) - { - SCM a = SCM_CAR (lsym); - SCM z = SCM_CAR (a); - if (SCM_EQ_P (z, symbol)) - return a; - } - - if (softness) - { - return SCM_BOOL_F; - } - else - { - SCM cell = scm_cons (symbol, SCM_UNDEFINED); - SCM slot = SCM_VELTS (obarray) [hash]; - - SCM_VELTS (obarray) [hash] = scm_cons (cell, slot); - - return cell; - } -} - - -SCM -scm_intern_obarray (const char *name,size_t len,SCM obarray) -{ - scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. " - "Use hashtables instead."); - - return scm_intern_obarray_soft (name, len, obarray, 0); -} - - -SCM -scm_intern (const char *name,size_t len) -{ - scm_c_issue_deprecation_warning ("`scm_intern' is deprecated. " - "Use scm_c_define or scm_c_lookup instead."); - - { - SCM symbol = scm_mem2symbol (name, len); - SCM var = scm_sym2var (symbol, SCM_BOOL_F, SCM_BOOL_T); - SCM vcell = SCM_VARVCELL (var); - SCM_SETCAR (vcell, symbol); - return vcell; - } -} - - -SCM -scm_intern0 (const char * name) -{ - scm_c_issue_deprecation_warning ("`scm_intern0' is deprecated. " - "Use scm_define or scm_lookup instead."); - - return scm_intern (name, strlen (name)); -} - -/* Intern the symbol named NAME in scm_symhash, and give it the value - VAL. NAME is null-terminated. Use the current top_level lookup - closure to give NAME its value. - */ -SCM -scm_sysintern (const char *name, SCM val) -{ - SCM var; - - scm_c_issue_deprecation_warning ("`scm_sysintern' is deprecated. " - "Use `scm_define' instead."); - - var = scm_c_define (name, val); - return SCM_VARVCELL (var); -} - -SCM -scm_sysintern0 (const char *name) -{ - SCM var; - SCM symbol; - - scm_c_issue_deprecation_warning ("`scm_sysintern0' is deprecated. " - "Use `scm_define' instead."); - - symbol = scm_str2symbol (name); - var = scm_sym2var (symbol, scm_current_module_lookup_closure (), SCM_BOOL_T); - if (var == SCM_BOOL_F) - scm_misc_error ("sysintern0", "can't define variable", symbol); - return SCM_VARVCELL (var); -} - -/* Lookup the value of the symbol named by the nul-terminated string - NAME in the current module. */ -SCM -scm_symbol_value0 (const char *name) -{ - scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. " - "Use `scm_lookup' instead."); - - return scm_variable_ref (scm_c_lookup (name)); -} - -SCM -scm_sym2vcell (SCM sym, SCM thunk, SCM definep) -{ - SCM var; - - scm_c_issue_deprecation_warning("`scm_sym2vcell' is deprecated. " - "Use `scm_define' or `scm_lookup' instead."); - - var = scm_sym2var (sym, thunk, definep); - if (var == SCM_BOOL_F) - return SCM_BOOL_F; - return SCM_VARVCELL (var); -} - -SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, - (SCM o, SCM s, SCM softp), - "Intern a new symbol in @var{obarray}, a symbol table, with name\n" - "@var{string}.\n\n" - "If @var{obarray} is @code{#f}, use the default system symbol table. If\n" - "@var{obarray} is @code{#t}, the symbol should not be interned in any\n" - "symbol table; merely return the pair (@var{symbol}\n" - ". @var{#}).\n\n" - "The @var{soft?} argument determines whether new symbol table entries\n" - "should be created when the specified symbol is not already present in\n" - "@var{obarray}. If @var{soft?} is specified and is a true value, then\n" - "new entries should not be added for symbols not already present in the\n" - "table; instead, simply return @code{#f}.") -#define FUNC_NAME s_scm_string_to_obarray_symbol -{ - SCM vcell; - SCM answer; - int softness; - - SCM_VALIDATE_STRING (2, s); - SCM_ASSERT (SCM_BOOLP (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME); - - scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. " - "Use hashtables instead."); - - softness = (!SCM_UNBNDP (softp) && !SCM_FALSEP(softp)); - /* iron out some screwy calling conventions */ - if (SCM_FALSEP (o)) - { - /* nothing interesting to do here. */ - return scm_string_to_symbol (s); - } - else if (SCM_EQ_P (o, SCM_BOOL_T)) - o = SCM_BOOL_F; - - vcell = scm_intern_obarray_soft (SCM_STRING_CHARS(s), - SCM_STRING_LENGTH (s), - o, - softness); - if (SCM_FALSEP (vcell)) - return vcell; - answer = SCM_CAR (vcell); - return answer; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0, - (SCM o, SCM s), - "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n" - "unspecified initial value. The symbol table is not modified if a symbol\n" - "with this name is already present.") -#define FUNC_NAME s_scm_intern_symbol -{ - size_t hval; - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - return SCM_UNSPECIFIED; - - scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_VECTOR (1,o); - hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); - /* If the symbol is already interned, simply return. */ - SCM_REDEFER_INTS; - { - SCM lsym; - SCM sym; - for (lsym = SCM_VELTS (o)[hval]; - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (sym), s)) - { - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; - } - } - SCM_VELTS (o)[hval] = - scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]); - } - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0, - (SCM o, SCM s), - "Remove the symbol with name @var{string} from @var{obarray}. This\n" - "function returns @code{#t} if the symbol was present and @code{#f}\n" - "otherwise.") -#define FUNC_NAME s_scm_unintern_symbol -{ - size_t hval; - - scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - return SCM_BOOL_F; - SCM_VALIDATE_VECTOR (1,o); - hval = SCM_SYMBOL_HASH (s) % SCM_VECTOR_LENGTH (o); - SCM_DEFER_INTS; - { - SCM lsym_follow; - SCM lsym; - SCM sym; - for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F; - SCM_NIMP (lsym); - lsym_follow = lsym, lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (SCM_EQ_P (SCM_CAR (sym), s)) - { - /* Found the symbol to unintern. */ - if (SCM_FALSEP (lsym_follow)) - SCM_VELTS(o)[hval] = lsym; - else - SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); - SCM_ALLOW_INTS; - return SCM_BOOL_T; - } - } - } - SCM_ALLOW_INTS; - return SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0, - (SCM o, SCM s), - "Look up in @var{obarray} the symbol whose name is @var{string}, and\n" - "return the value to which it is bound. If @var{obarray} is @code{#f},\n" - "use the global symbol table. If @var{string} is not interned in\n" - "@var{obarray}, an error is signalled.") -#define FUNC_NAME s_scm_symbol_binding -{ - SCM vcell; - - scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - return scm_variable_ref (scm_lookup (s)); - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell (s, o); - return SCM_CDR(vcell); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0, - (SCM o, SCM s), - "Return @code{#t} if @var{obarray} contains a symbol with name\n" - "@var{string}, and @code{#f} otherwise.") -#define FUNC_NAME s_scm_symbol_interned_p -{ - SCM vcell; - - scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - { - SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); - if (var != SCM_BOOL_F) - return SCM_BOOL_T; - return SCM_BOOL_F; - } - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell_soft (s, o); - return (SCM_NIMP(vcell) - ? SCM_BOOL_T - : SCM_BOOL_F); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0, - (SCM o, SCM s), - "Return @code{#t} if @var{obarray} contains a symbol with name\n" - "@var{string} bound to a defined value. This differs from\n" - "@var{symbol-interned?} in that the mere mention of a symbol\n" - "usually causes it to be interned; @code{symbol-bound?}\n" - "determines whether a symbol has been given any meaningful\n" - "value.") -#define FUNC_NAME s_scm_symbol_bound_p -{ - SCM vcell; - - scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. " - "Use hashtables instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - { - SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F); - if (SCM_DEFVARIABLEP (var)) - return SCM_BOOL_T; - return SCM_BOOL_F; - } - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell_soft (s, o); - return SCM_BOOL (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0, - (SCM o, SCM s, SCM v), - "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n" - "it to @var{value}. An error is signalled if @var{string} is not present\n" - "in @var{obarray}.") -#define FUNC_NAME s_scm_symbol_set_x -{ - SCM vcell; - - scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. " - "Use the module system instead."); - - SCM_VALIDATE_SYMBOL (2,s); - if (SCM_FALSEP (o)) - { - scm_define (s, v); - return SCM_UNSPECIFIED; - } - SCM_VALIDATE_VECTOR (1,o); - vcell = scm_sym2ovcell (s, o); - SCM_SETCDR (vcell, v); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -#if 0 - -static void -copy_and_prune_obarray (SCM from, SCM to) -{ - int i; - int length = SCM_VECTOR_LENGTH (from); - for (i = 0; i < length; ++i) - { - SCM head = SCM_VELTS (from)[i]; /* GC protection */ - SCM ls = head; - SCM res = SCM_EOL; - SCM *lloc = &res; - while (SCM_NIMP (ls)) - { - if (!SCM_UNBNDP (SCM_CDAR (ls))) - { - *lloc = scm_cons (SCM_CAR (ls), SCM_EOL); - lloc = SCM_CDRLOC (*lloc); - } - ls = SCM_CDR (ls); - } - SCM_VELTS (to)[i] = res; - } -} - - -SCM_DEFINE (scm_builtin_bindings, "builtin-bindings", 0, 0, 0, - (), - "Create and return a copy of the global symbol table, removing all\n" - "unbound symbols.") -#define FUNC_NAME s_scm_builtin_bindings -{ - int length = SCM_VECTOR_LENGTH (scm_symhash); - SCM obarray = scm_c_make_hash_table (length); - - scm_issue_deprecation_warning ("`builtin-bindings' is deprecated. " - "Use the module system instead."); - - copy_and_prune_obarray (scm_symhash, obarray); - return obarray; -} -#undef FUNC_NAME - -#endif - -#define MAX_PREFIX_LENGTH 30 - -static int gentemp_counter; - -SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, - (SCM prefix, SCM obarray), - "Create a new symbol with a name unique in an obarray.\n" - "The name is constructed from an optional string @var{prefix}\n" - "and a counter value. The default prefix is @code{t}. The\n" - "@var{obarray} is specified as a second optional argument.\n" - "Default is the system obarray where all normal symbols are\n" - "interned. The counter is increased by 1 at each\n" - "call. There is no provision for resetting the counter.") -#define FUNC_NAME s_scm_gentemp -{ - char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; - char *name = buf; - int len, n_digits; - - scm_c_issue_deprecation_warning ("`gentemp' is deprecated. " - "Use `gensym' instead."); - - if (SCM_UNBNDP (prefix)) - { - name[0] = 't'; - len = 1; - } - else - { - SCM_VALIDATE_STRING (1, prefix); - len = SCM_STRING_LENGTH (prefix); - if (len > MAX_PREFIX_LENGTH) - name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); - strncpy (name, SCM_STRING_CHARS (prefix), len); - } - - if (SCM_UNBNDP (obarray)) - return scm_gensym (prefix); - else - SCM_ASSERT ((SCM_VECTORP (obarray) || SCM_WVECTP (obarray)), - obarray, - SCM_ARG2, - FUNC_NAME); - do - n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]); - while (!SCM_FALSEP (scm_intern_obarray_soft (name, - len + n_digits, - obarray, - 1))); - { - SCM vcell = scm_intern_obarray_soft (name, - len + n_digits, - obarray, - 0); - if (name != buf) - scm_must_free (name); - return SCM_CAR (vcell); - } -} -#undef FUNC_NAME - -void -scm_init_symbols_deprecated () -{ - gentemp_counter = 0; -#ifndef SCM_MAGIC_SNARFER -#include "libguile/symbols-deprecated.x" -#endif -} - -#endif /* SCM_ENABLE_VCELLS */ - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/vectors.c b/libguile/vectors.c index 8280b113e..1cc666a99 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -140,8 +140,6 @@ SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_vector_p { - if (SCM_IMP (obj)) - return SCM_BOOL_F; return SCM_BOOL (SCM_VECTORP (obj)); } #undef FUNC_NAME From cebf3d62d915cb73ca5cc6b99e3fa006c4d0a15a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 16 Jul 2001 15:47:02 +0000 Subject: [PATCH 10/11] * srfi-14.c: Allocate correct memory size for charsets (32 bytes), use this value for initializing and comparing charsets. (scm_char_set_hash): Use ``better'' hash algorithm which produces more values. --- srfi/ChangeLog | 7 +++++++ srfi/srfi-14.c | 12 +++++++----- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 8b467df17..8c2f2c936 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,10 @@ +2001-07-16 Martin Grabmueller + + * srfi-14.c: Allocate correct memory size for charsets (32 bytes), + use this value for initializing and comparing charsets. + (scm_char_set_hash): Use ``better'' hash algorithm which produces + more values. + 2001-07-15 Gary Houston * srfi-14.c (scm_char_set_hash): recognise 0 instead of #f in the diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 685ee89bc..878349158 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -94,8 +94,8 @@ make_char_set (const char * func_name) { long * p; - p = scm_must_malloc (SCM_CHARSET_SIZE, func_name); - memset (p, 0, SCM_CHARSET_SIZE); + p = scm_must_malloc (SCM_CHARSET_SIZE / sizeof (char), func_name); + memset (p, 0, SCM_CHARSET_SIZE / sizeof (char)); SCM_RETURN_NEWSMOB (scm_tc16_charset, p); } @@ -131,7 +131,8 @@ SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, csi_data = (long *) SCM_SMOB_DATA (csi); if (cs1_data == NULL) cs1_data = csi_data; - else if (memcmp (cs1_data, csi_data, SCM_CHARSET_SIZE) != 0) + else if (memcmp (cs1_data, csi_data, + SCM_CHARSET_SIZE / sizeof (char)) != 0) return SCM_BOOL_F; char_sets = SCM_CDR (char_sets); } @@ -204,7 +205,8 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, p = (long *) SCM_SMOB_DATA (cs); for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++) { - val = p[k] ^ val; + if (p[k] != 0) + val = p[k] + (val << 1); } return SCM_MAKINUM (val % bnd); } @@ -1368,7 +1370,7 @@ scm_c_init_srfi_14 (void) if (!initialized) { scm_tc16_charset = scm_make_smob_type ("character-set", - SCM_CHARSET_SIZE * sizeof (long)); + SCM_CHARSET_SIZE / sizeof (char)); scm_set_smob_free (scm_tc16_charset, charset_free); scm_set_smob_print (scm_tc16_charset, charset_print); initialized = 1; From 072ad0fe6b41339ffde847232c04bc3fa497de78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Grabm=C3=BCller?= Date: Mon, 16 Jul 2001 18:49:10 +0000 Subject: [PATCH 11/11] * tests/srfi-14.test: New file. --- test-suite/ChangeLog | 4 + test-suite/tests/srfi-14.test | 188 ++++++++++++++++++++++++++++++++++ 2 files changed, 192 insertions(+) create mode 100644 test-suite/tests/srfi-14.test diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index e1baec7d3..b54a5df3a 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2001-07-16 Martin Grabmueller + + * tests/srfi-14.test: New file. + 2001-07-13 Marius Vollmer * tests/import.test: New file. diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test new file mode 100644 index 000000000..bd927c0bb --- /dev/null +++ b/test-suite/tests/srfi-14.test @@ -0,0 +1,188 @@ +;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions. -*- scheme -*- +;;;; Martin Grabmueller, 2001-07-16 +;;;; +;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (srfi srfi-14)) + +(define exception:invalid-char-set-cursor + (cons 'misc-error "^invalid character set cursor")) + +(define exception:non-char-return + (cons 'misc-error "returned non-char")) + +(with-test-prefix "char-set?" + + (pass-if "success on empty set" + (char-set? (char-set))) + + (pass-if "success on non-empty set" + (char-set? char-set:printing)) + + (pass-if "failure on empty set" + (not (char-set? #t)))) + + +(with-test-prefix "char-set=" + (pass-if "success, no arg" + (char-set=)) + + (pass-if "success, one arg" + (char-set= char-set:lower-case)) + + (pass-if "success, two args" + (char-set= char-set:upper-case char-set:upper-case)) + + (pass-if "failure, first empty" + (not (char-set= (char-set) (char-set #\a)))) + + (pass-if "failure, second empty" + (not (char-set= (char-set #\a) (char-set)))) + + (pass-if "success, more args" + (char-set= char-set:blank char-set:blank char-set:blank))) + +(with-test-prefix "char-set<=" + (pass-if "success, no arg" + (char-set<=)) + + (pass-if "success, one arg" + (char-set<= char-set:lower-case)) + + (pass-if "success, two args" + (char-set<= char-set:upper-case char-set:upper-case)) + + (pass-if "success, first empty" + (char-set<= (char-set) (char-set #\a))) + + (pass-if "failure, second empty" + (not (char-set<= (char-set #\a) (char-set)))) + + (pass-if "success, more args, equal" + (char-set<= char-set:blank char-set:blank char-set:blank)) + + (pass-if "success, more args, not equal" + (char-set<= char-set:blank + (char-set-adjoin char-set:blank #\F) + (char-set-adjoin char-set:blank #\F #\o)))) + +(with-test-prefix "char-set-hash" + (pass-if "empty set, bound" + (let ((h (char-set-hash char-set:empty 31))) + (and h (number? h) (exact? h) (>= h 0) (< h 31)))) + + (pass-if "empty set, no bound" + (let ((h (char-set-hash char-set:empty))) + (and h (number? h) (exact? h) (>= h 0)))) + + (pass-if "full set, bound" + (let ((h (char-set-hash char-set:full 31))) + (and h (number? h) (exact? h) (>= h 0) (< h 31)))) + + (pass-if "full set, no bound" + (let ((h (char-set-hash char-set:full))) + (and h (number? h) (exact? h) (>= h 0)))) + + (pass-if "other set, bound" + (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r) 31))) + (and h (number? h) (exact? h) (>= h 0) (< h 31)))) + + (pass-if "other set, no bound" + (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r)))) + (and h (number? h) (exact? h) (>= h 0))))) + + +(with-test-prefix "char-set cursor" + + (pass-if-exception "invalid character cursor" + exception:invalid-char-set-cursor + (let* ((cs (char-set #\B #\r #\a #\z)) + (cc (char-set-cursor cs))) + (char-set-ref cs 1000))) + + (pass-if "success" + (let* ((cs (char-set #\B #\r #\a #\z)) + (cc (char-set-cursor cs))) + (char? (char-set-ref cs cc)))) + + (pass-if "end of set fails" + (let* ((cs (char-set #\a)) + (cc (char-set-cursor cs))) + (not (end-of-char-set? cc)))) + + (pass-if "end of set succeeds, empty set" + (let* ((cs (char-set)) + (cc (char-set-cursor cs))) + (end-of-char-set? cc))) + + (pass-if "end of set succeeds, non-empty set" + (let* ((cs (char-set #\a)) + (cc (char-set-cursor cs)) + (cc (char-set-cursor-next cs cc))) + (end-of-char-set? cc)))) + +(with-test-prefix "char-set-fold" + + (pass-if "count members" + (= (char-set-fold (lambda (c n) (+ n 1)) 0 (char-set #\a #\b)) 2)) + + (pass-if "copy set" + (= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c)) + (char-set) (char-set #\a #\b))) 2))) + +(with-test-prefix "char-set-unfold" + + (pass-if "create char set" + (char-set= char-set:full + (char-set-unfold (lambda (s) (= s 256)) integer->char + (lambda (s) (+ s 1)) 0))) + (pass-if "create char set (base set)" + (char-set= char-set:full + (char-set-unfold (lambda (s) (= s 256)) integer->char + (lambda (s) (+ s 1)) 0 char-set:empty)))) + +(with-test-prefix "char-set-unfold!" + + (pass-if "create char set" + (char-set= char-set:full + (char-set-unfold! (lambda (s) (= s 256)) integer->char + (lambda (s) (+ s 1)) 0 + (char-set-copy char-set:empty)))) + + (pass-if "create char set" + (char-set= char-set:full + (char-set-unfold! (lambda (s) (= s 32)) integer->char + (lambda (s) (+ s 1)) 0 + (char-set-copy char-set:full))))) + + +(with-test-prefix "char-set-for-each" + + (pass-if "copy char set" + (= (char-set-size (let ((cs (char-set))) + (char-set-for-each + (lambda (c) (char-set-adjoin! cs c)) + (char-set #\a #\b)) + cs)) + 2))) + +(with-test-prefix "char-set-map" + + (pass-if "upper case char set" + (char-set= (char-set-map char-upcase char-set:lower-case) + char-set:upper-case)))