From 685c0d7116658bcefa6404224832480e1e6cba92 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 30 Jun 2000 10:46:35 +0000 Subject: [PATCH] * Eliminated use of SCM_ASSERT to check for range errors. * Fix some error reporting code in list.c * Added some test cases. --- doc/ChangeLog | 4 + doc/data-rep.texi | 7 +- libguile/ChangeLog | 33 +++++++ libguile/__scm.h | 1 - libguile/error.c | 2 - libguile/hashtab.c | 18 ++-- libguile/hooks.c | 3 +- libguile/list.c | 88 ++++++++++------- libguile/strings.c | 20 ++-- libguile/unif.c | 26 ++--- libguile/vectors.c | 26 ++--- test-suite/ChangeLog | 5 + test-suite/tests/list.test | 195 +++++++++++++++++++++++++++++++++++++ 13 files changed, 339 insertions(+), 89 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 9b7bd4617..bdde435c4 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,7 @@ +2000-06-30 Dirk Herrmann + + * data-rep.tex: Removed documentation for SCM_OUTOFRANGE. + 2000-06-20 Mikael Djurfeldt * data-rep.texi: Center discussion around the standard interface diff --git a/doc/data-rep.texi b/doc/data-rep.texi index d515d3afe..407a79656 100644 --- a/doc/data-rep.texi +++ b/doc/data-rep.texi @@ -46,7 +46,7 @@ by the Free Software Foundation. @sp 10 @comment The title is printed in a large font. @title Data Representation in Guile -@subtitle $Id: data-rep.texi,v 1.11 2000-06-20 03:22:56 mdj Exp $ +@subtitle $Id: data-rep.texi,v 1.12 2000-06-30 10:46:33 dirk Exp $ @subtitle For use with Guile @value{VERSION} @author Jim Blandy @author Free Software Foundation @@ -1077,11 +1077,6 @@ naming the function. Usually, Guile catches these errors before ever invoking the subr, so we don't run into these problems. @end deftypefn -@deftypefn Macro int SCM_OUTOFRANGE -Signal an error complaining that @var{obj} is ``out of range'' for -@var{subr}. -@end deftypefn - @node Defining New Types (Smobs), , How Guile does it, Top @section Defining New Types (Smobs) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 31cd6ea3f..daeabdc4b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,36 @@ +2000-06-30 Dirk Herrmann + + * __scm.h (SCM_OUTOFRANGE): Removed. + + * error.c (scm_wta): Removed sick dispatch code for range + errors. (More sick dispatches still to be removed.) + + * hashtab.c (scm_hash_fn_get_handle, scm_hash_fn_create_handle_x, + scm_hash_fn_remove_x): Eliminate redundant test for if unsigned + value is non-negative. Use scm_out_of_range to signal range + errors. + + * hooks.c (make_hook), unif.c (scm_aind): Use scm_out_of_range to + signal range errors. + + * list.c (scm_list_ref, scm_list_set_x, scm_list_cdr_set_x): Fix + error reporting (now uses original input parameter to report wrong + type argument errors). Use SCM_OUT_OF_RANGE to report range + errors and SCM_WRONG_TYPE_ARG to report type errors. + + * strings.c (scm_substring): Make range checks for negative + values explicit (former behaviour relied on an implicit + conversion from signed to unsigned). Don't use SCM_ASSERT for + range checks. + + * unif.c (scm_aind, scm_transpose_array, scm_bit_set_star_x, + scm_bit_count_star): Use scm_out_of_range to signal range + errors. + + * unif.c (scm_transpose_array, scm_bit_position), vectors.c + (scm_vector_ref, scm_vector_set_x, scm_vector_move_left_x, + scm_vector_move_right_x): Use SCM_ASSERT_RANGE to check ranges. + 2000-06-30 Dirk Herrmann * validate.h (SCM_VALIDATE_INUM_MIN_COPY, diff --git a/libguile/__scm.h b/libguile/__scm.h index 13eaa82c9..f1aa50afb 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -554,7 +554,6 @@ extern SCM scm_apply_generic (SCM gf, SCM args); /* SCM_WNA must follow the last SCM_ARGn in sequence. */ #define SCM_WNA 8 -#define SCM_OUTOFRANGE 10 #endif /* SCM_MAGIC_SNARFER */ diff --git a/libguile/error.c b/libguile/error.c index 88e6fc030..067b3cdb1 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -316,8 +316,6 @@ scm_wta (SCM arg, const char *pos, const char *s_subr) scm_wrong_type_arg (s_subr, 7, arg); case SCM_WNA: scm_wrong_num_args (arg); - case SCM_OUTOFRANGE: - scm_out_of_range (s_subr, arg); default: /* this shouldn't happen. */ scm_misc_error (s_subr, "Unknown error", SCM_EOL); diff --git a/libguile/hashtab.c b/libguile/hashtab.c index f8e20e8de..6b169c6e3 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -66,10 +66,8 @@ scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_ if (SCM_LENGTH (table) == 0) return SCM_EOL; k = hash_fn (obj, SCM_LENGTH (table), closure); - SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)), - scm_ulong2num (k), - SCM_OUTOFRANGE, - "hash_fn_get_handle"); + if (k >= SCM_LENGTH (table)) + scm_out_of_range ("hash_fn_get_handle", scm_ulong2num (k)); h = assoc_fn (obj, SCM_VELTS (table)[k], closure); return h; } @@ -87,10 +85,8 @@ scm_hash_fn_create_handle_x (SCM table,SCM obj,SCM init,unsigned int (*hash_fn)( if (SCM_LENGTH (table) == 0) return SCM_EOL; k = hash_fn (obj, SCM_LENGTH (table), closure); - SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)), - scm_ulong2num (k), - SCM_OUTOFRANGE, - "hash_fn_create_handle_x"); + if (k >= SCM_LENGTH (table)) + scm_out_of_range ("hash_fn_create_handle_x", scm_ulong2num (k)); SCM_REDEFER_INTS; it = assoc_fn (obj, SCM_VELTS (table)[k], closure); if (SCM_NIMP (it)) @@ -154,10 +150,8 @@ scm_hash_fn_remove_x (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn if (SCM_LENGTH (table) == 0) return SCM_EOL; k = hash_fn (obj, SCM_LENGTH (table), closure); - SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)), - scm_ulong2num (k), - SCM_OUTOFRANGE, - "hash_fn_remove_x"); + if (k >= SCM_LENGTH (table)) + scm_out_of_range ("hash_fn_remove_x", scm_ulong2num (k)); h = assoc_fn (obj, SCM_VELTS (table)[k], closure); SCM_VELTS(table)[k] = delete_fn (h, SCM_VELTS(table)[k]); return h; diff --git a/libguile/hooks.c b/libguile/hooks.c index 862b55a96..712debd87 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -164,7 +164,8 @@ make_hook (SCM n_args, const char *subr) { SCM_ASSERT (SCM_INUMP (n_args), n_args, SCM_ARGn, subr); n = SCM_INUM (n_args); - SCM_ASSERT (n >= 0 && n <= 16, n_args, SCM_OUTOFRANGE, subr); + if (n < 0 || n > 16) + scm_out_of_range (subr, n_args); } SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_EOL); } diff --git a/libguile/list.c b/libguile/list.c index 25aac038f..cabdba417 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -346,44 +346,55 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, } #undef FUNC_NAME - + /* indexing lists by element number */ SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0, - (SCM lst, SCM k), - "Return the Kth element from list LST.") + (SCM list, SCM k), + "Return the Kth element from LIST.") #define FUNC_NAME s_scm_list_ref { - register long i; + SCM lst = list; + unsigned long int i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); - while (i-- > 0) { - SCM_ASRTGO(SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } - erout: - SCM_ASSERT(SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME); - return SCM_CAR(lst); + while (SCM_CONSP (lst)) { + if (i == 0) + return SCM_CAR (lst); + else { + --i; + lst = SCM_CDR (lst); + } + }; + if (SCM_NULLP (lst)) + SCM_OUT_OF_RANGE (2, k); + else + SCM_WRONG_TYPE_ARG (1, list); } #undef FUNC_NAME + SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0, - (SCM lst, SCM k, SCM val), - "Set the @var{k}th element of @var{lst} to @var{val}.") + (SCM list, SCM k, SCM val), + "Set the @var{k}th element of @var{list} to @var{val}.") #define FUNC_NAME s_scm_list_set_x { - register long i; + SCM lst = list; + unsigned long int i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); - while (i-- > 0) { - SCM_ASRTGO(SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } - erout: - SCM_ASSERT(SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME); - SCM_SETCAR (lst, val); - return val; + while (SCM_CONSP (lst)) { + if (i == 0) { + SCM_SETCAR (lst, val); + return val; + } else { + --i; + lst = SCM_CDR (lst); + } + }; + if (SCM_NULLP (lst)) + SCM_OUT_OF_RANGE (2, k); + else + SCM_WRONG_TYPE_ARG (1, list); } #undef FUNC_NAME @@ -411,21 +422,26 @@ SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0, SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, - (SCM lst, SCM k, SCM val), - "Set the @var{k}th cdr of @var{lst} to @var{val}.") + (SCM list, SCM k, SCM val), + "Set the @var{k}th cdr of @var{list} to @var{val}.") #define FUNC_NAME s_scm_list_cdr_set_x { - register long i; + SCM lst = list; + unsigned long int i; SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); - while (i-- > 0) { - SCM_ASRTGO(SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } -erout: - SCM_ASSERT(SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME); - SCM_SETCDR (lst, val); - return val; + while (SCM_CONSP (lst)) { + if (i == 0) { + SCM_SETCDR (lst, val); + return val; + } else { + --i; + lst = SCM_CDR (lst); + } + }; + if (SCM_NULLP (lst)) + SCM_OUT_OF_RANGE (2, k); + else + SCM_WRONG_TYPE_ARG (1, list); } #undef FUNC_NAME diff --git a/libguile/strings.c b/libguile/strings.c index a20607df9..44ae6215c 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -278,7 +278,6 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, #undef FUNC_NAME - SCM_DEFINE (scm_substring, "substring", 2, 1, 0, (SCM str, SCM start, SCM end), "Returns a newly allocated string formed from the characters\n" @@ -288,18 +287,23 @@ SCM_DEFINE (scm_substring, "substring", 2, 1, 0, "0 <= START <= END <= (string-length STR).") #define FUNC_NAME s_scm_substring { - long l; + long int from; + long int to; + SCM_VALIDATE_ROSTRING (1,str); - SCM_VALIDATE_INUM (2,start); + SCM_VALIDATE_INUM (2, start); SCM_VALIDATE_INUM_DEF (3,end,SCM_ROLENGTH(str)); - SCM_ASSERT_RANGE (2,start,SCM_INUM (start) <= SCM_ROLENGTH (str)); - SCM_ASSERT_RANGE (2,end,SCM_INUM (end) <= SCM_ROLENGTH (str)); - l = SCM_INUM (end)-SCM_INUM (start); - SCM_ASSERT (l >= 0, SCM_MAKINUM (l), SCM_OUTOFRANGE, FUNC_NAME); - return scm_makfromstr (&SCM_ROCHARS (str)[SCM_INUM (start)], (scm_sizet)l, 0); + + from = SCM_INUM (start); + SCM_ASSERT_RANGE (2, start, 0 <= from && from <= SCM_ROLENGTH (str)); + to = SCM_INUM (end); + SCM_ASSERT_RANGE (3, end, from <= to && to <= SCM_ROLENGTH (str)); + + return scm_makfromstr (&SCM_ROCHARS (str)[from], (scm_sizet) (to - from), 0); } #undef FUNC_NAME + SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, (SCM args), "Returns a newly allocated string whose characters form the\n" diff --git a/libguile/unif.c b/libguile/unif.c index 19f7acea1..cc029157d 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -480,7 +480,8 @@ scm_aind (SCM ra, SCM args, const char *what) args = SCM_CDR (args); SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, what); j = SCM_INUM (ind); - SCM_ASSERT (j >= (s->lbnd) && j <= (s->ubnd), ind, SCM_OUTOFRANGE, what); + if (j < s->lbnd || j > s->ubnd) + scm_out_of_range (what, ind); pos += (j - s->lbnd) * (s->inc); k--; s++; @@ -831,8 +832,8 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2, FUNC_NAME); - SCM_ASSERT (SCM_EQ_P (SCM_INUM0, SCM_CAR (args)), SCM_CAR (args), SCM_OUTOFRANGE, - FUNC_NAME); + SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), + SCM_EQ_P (SCM_INUM0, SCM_CAR (args))); return ra; case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (ra), badarg); @@ -846,8 +847,8 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, SCM_ASSERT (SCM_INUMP (ve[k]), ve[k], (SCM_ARG2 + k), FUNC_NAME); i = SCM_INUM (ve[k]); - SCM_ASSERT (i >= 0 && i < SCM_ARRAY_NDIM (ra), ve[k], - SCM_OUTOFRANGE, FUNC_NAME); + if (i < 0 || i >= SCM_ARRAY_NDIM (ra)) + scm_out_of_range (FUNC_NAME, ve[k]); if (ndim < i) ndim = i; } @@ -1770,8 +1771,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, register unsigned long w; SCM_VALIDATE_NIM (2,v); SCM_VALIDATE_INUM_COPY (3,k,pos); - SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0), - k, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT_RANGE (3, k, (pos <= SCM_LENGTH (v)) && (pos >= 0)); if (pos == SCM_LENGTH (v)) return SCM_BOOL_F; switch SCM_TYP7 (v) @@ -1856,14 +1856,16 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, for (i = SCM_LENGTH (kv); i;) { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); + if (k >= vlen) + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); SCM_BITVEC_CLR(v,k); } else if (SCM_EQ_P (obj, SCM_BOOL_T)) for (i = SCM_LENGTH (kv); i;) { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); + if (k >= vlen) + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); SCM_BITVEC_SET(v,k); } else @@ -1920,7 +1922,8 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, for (i = SCM_LENGTH (kv); i;) { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); + if (k >= vlen) + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); if (!SCM_BITVEC_REF(v,k)) count++; } @@ -1928,7 +1931,8 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, for (i = SCM_LENGTH (kv); i;) { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); + if (k >= vlen) + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k)); if (SCM_BITVEC_REF (v,k)) count++; } diff --git a/libguile/vectors.c b/libguile/vectors.c index 2ffe1302d..1c59b96c1 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -200,15 +200,16 @@ SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref); SCM scm_vector_ref (SCM v, SCM k) +#define FUNC_NAME s_vector_ref { SCM_GASSERT2 (SCM_VECTORP (v), g_vector_ref, v, k, SCM_ARG1, s_vector_ref); SCM_GASSERT2 (SCM_INUMP (k), g_vector_ref, v, k, SCM_ARG2, s_vector_ref); - SCM_ASSERT (SCM_INUM (k) < SCM_LENGTH (v) && SCM_INUM (k) >= 0, - k, SCM_OUTOFRANGE, s_vector_ref); + SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_LENGTH (v) && SCM_INUM (k) >= 0); return SCM_VELTS (v)[(long) SCM_INUM (k)]; } +#undef FUNC_NAME SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x); @@ -233,6 +234,7 @@ The value returned by @samp{vector-set!} is unspecified. SCM scm_vector_set_x (SCM v, SCM k, SCM obj) +#define FUNC_NAME s_vector_set_x { SCM_GASSERTn (SCM_VECTORP (v), g_vector_set_x, SCM_LIST3 (v, k, obj), @@ -240,11 +242,11 @@ scm_vector_set_x (SCM v, SCM k, SCM obj) SCM_GASSERTn (SCM_INUMP (k), g_vector_set_x, SCM_LIST3 (v, k, obj), SCM_ARG2, s_vector_set_x); - SCM_ASSERT ((SCM_INUM (k) < SCM_LENGTH (v)) && (SCM_INUM (k) >= 0), - k, SCM_OUTOFRANGE, s_vector_set_x); + SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_LENGTH (v) && SCM_INUM (k) >= 0); SCM_VELTS(v)[(long) SCM_INUM(k)] = obj; return SCM_UNSPECIFIED; } +#undef FUNC_NAME SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, @@ -342,10 +344,10 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, SCM_VALIDATE_INUM_COPY (3,end1,e); SCM_VALIDATE_VECTOR (4,vec2); SCM_VALIDATE_INUM_COPY (5,start2,j); - SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, FUNC_NAME); - SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, FUNC_NAME); - SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, FUNC_NAME); - SCM_ASSERT (e-i+j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT_RANGE (2, start1, i <= SCM_LENGTH (vec1) && i >= 0); + SCM_ASSERT_RANGE (5, start2, j <= SCM_LENGTH (vec2) && j >= 0); + SCM_ASSERT_RANGE (3, end1, e <= SCM_LENGTH (vec1) && e >= 0); + SCM_ASSERT_RANGE (5, start2, e-i+j <= SCM_LENGTH (vec2)); while (i= 0, start1, SCM_OUTOFRANGE, FUNC_NAME); - SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, FUNC_NAME); - SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT_RANGE (2, start1, i <= SCM_LENGTH (vec1) && i >= 0); + SCM_ASSERT_RANGE (5, start2, j <= SCM_LENGTH (vec2) && j >= 0); + SCM_ASSERT_RANGE (3, end1, e <= SCM_LENGTH (vec1) && e >= 0); j = e - i + j; - SCM_ASSERT (j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, FUNC_NAME); + SCM_ASSERT_RANGE (5, start2, j <= SCM_LENGTH (vec2)); while (i < e) SCM_VELTS (vec2)[--j] = SCM_VELTS (vec1)[--e]; return SCM_UNSPECIFIED; diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index a6b768eab..9bcf4fe21 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2000-06-30 Dirk Herrmann + + * tests/list.test: Added tests for list-ref, list-set! and + list-cdr-set! + 2000-06-21 Dirk Herrmann * tests/common-list.test: Added. diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test index c3546a638..99e9b3fec 100644 --- a/test-suite/tests/list.test +++ b/test-suite/tests/list.test @@ -451,9 +451,138 @@ ;;; list-ref +(with-test-prefix "list-ref" + + ;; Is documentation available? + + (pass-if "documented?" (object-documentation list-ref)) + + (with-test-prefix "argument error" + + (with-test-prefix "non list argument" + #t) + + (with-test-prefix "improper list argument" + #t) + + (with-test-prefix "non integer index" + #t) + + (with-test-prefix "index out of range" + + (with-test-prefix "empty list" + + (pass-if "index 0" + (catch 'out-of-range + (lambda () + (list-ref '() 0) + #f) + (lambda (key . args) + #t))) + + (pass-if "index > 0" + (catch 'out-of-range + (lambda () + (list-ref '() 1) + #f) + (lambda (key . args) + #t))) + + (pass-if "index < 0" + (catch 'out-of-range + (lambda () + (list-ref '() -1) + #f) + (lambda (key . args) + #t)))) + + (with-test-prefix "non-empty list" + + (pass-if "index > length" + (catch 'out-of-range + (lambda () + (list-ref '(1) 1) + #f) + (lambda (key . args) + #t))) + + (pass-if "index < 0" + (catch 'out-of-range + (lambda () + (list-ref '(1) -1) + #f) + (lambda (key . args) + #t))))))) + ;;; list-set! +(with-test-prefix "list-set!" + + ;; Is documentation available? + + (pass-if "documented?" (object-documentation list-set!)) + + (with-test-prefix "argument error" + + (with-test-prefix "non list argument" + #t) + + (with-test-prefix "improper list argument" + #t) + + (with-test-prefix "read-only list argument" + #t) + + (with-test-prefix "non integer index" + #t) + + (with-test-prefix "index out of range" + + (with-test-prefix "empty list" + + (pass-if "index 0" + (catch 'out-of-range + (lambda () + (list-set! (list) 0 #t) + #f) + (lambda (key . args) + #t))) + + (pass-if "index > 0" + (catch 'out-of-range + (lambda () + (list-set! (list) 1 #t) + #f) + (lambda (key . args) + #t))) + + (pass-if "index < 0" + (catch 'out-of-range + (lambda () + (list-set! (list) -1 #t) + #f) + (lambda (key . args) + #t)))) + + (with-test-prefix "non-empty list" + + (pass-if "index > length" + (catch 'out-of-range + (lambda () + (list-set! (list 1) 1 #t) + #f) + (lambda (key . args) + #t))) + + (pass-if "index < 0" + (catch 'out-of-range + (lambda () + (list-set! (list 1) -1 #t) + #f) + (lambda (key . args) + #t))))))) + ;;; list-cdr-ref @@ -463,6 +592,72 @@ ;;; list-cdr-set! +(with-test-prefix "list-cdr-set!" + + ;; Is documentation available? + + (pass-if "documented?" (object-documentation list-cdr-set!)) + + (with-test-prefix "argument error" + + (with-test-prefix "non list argument" + #t) + + (with-test-prefix "improper list argument" + #t) + + (with-test-prefix "read-only list argument" + #t) + + (with-test-prefix "non integer index" + #t) + + (with-test-prefix "index out of range" + + (with-test-prefix "empty list" + + (pass-if "index 0" + (catch 'out-of-range + (lambda () + (list-cdr-set! (list) 0 #t) + #f) + (lambda (key . args) + #t))) + + (pass-if "index > 0" + (catch 'out-of-range + (lambda () + (list-cdr-set! (list) 1 #t) + #f) + (lambda (key . args) + #t))) + + (pass-if "index < 0" + (catch 'out-of-range + (lambda () + (list-cdr-set! (list) -1 #t) + #f) + (lambda (key . args) + #t)))) + + (with-test-prefix "non-empty list" + + (pass-if "index > length" + (catch 'out-of-range + (lambda () + (list-cdr-set! (list 1) 1 #t) + #f) + (lambda (key . args) + #t))) + + (pass-if "index < 0" + (catch 'out-of-range + (lambda () + (list-cdr-set! (list 1) -1 #t) + #f) + (lambda (key . args) + #t))))))) + ;;; list-head -- 2.20.1