diff options
-rw-r--r-- | libguile/array-map.c | 4 | ||||
-rw-r--r-- | libguile/chars.c | 274 | ||||
-rw-r--r-- | libguile/eq.c | 144 | ||||
-rw-r--r-- | libguile/goops.c | 1 | ||||
-rw-r--r-- | libguile/numbers.c | 157 | ||||
-rw-r--r-- | libguile/procprop.c | 3 | ||||
-rw-r--r-- | libguile/procs.c | 2 | ||||
-rw-r--r-- | libguile/strorder.c | 232 | ||||
-rw-r--r-- | libguile/tags.h | 3 | ||||
-rw-r--r-- | libguile/vm.c | 10 | ||||
-rw-r--r-- | test-suite/tests/numbers.test | 4 |
11 files changed, 646 insertions, 188 deletions
diff --git a/libguile/array-map.c b/libguile/array-map.c index 75bc490d5..747747a96 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -942,8 +942,10 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, return SCM_BOOL_T; while (!scm_is_null (rest)) - { if (scm_is_false (scm_array_equal_p (ra0, scm_car (rest)))) + { if (scm_is_false (scm_array_equal_p (ra0, ra1))) return SCM_BOOL_F; + ra0 = ra1; + ra1 = scm_car (rest); rest = scm_cdr (rest); } return scm_array_equal_p (ra0, ra1); diff --git a/libguile/chars.c b/libguile/chars.c index 59ac6f412..68e6dc192 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -43,11 +43,28 @@ SCM_DEFINE (scm_char_p, "char?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return @code{#t} if the Unicode code point of @var{x} is equal to the\n" - "code point of @var{y}, else @code{#f}.\n") -#define FUNC_NAME s_scm_char_eq_p +SCM_DEFINE (scm_i_char_eq_p, "char=?", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} if the Unicode code point of @var{x} is equal to the\n" + "code point of @var{y}, else @code{#f}.\n") +#define FUNC_NAME s_scm_i_char_eq_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_char_eq_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_char_eq_p (x, y); +} +#undef FUNC_NAME + +SCM scm_char_eq_p (SCM x, SCM y) +#define FUNC_NAME s_scm_i_char_eq_p { SCM_VALIDATE_CHAR (1, x); SCM_VALIDATE_CHAR (2, y); @@ -56,11 +73,28 @@ SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr, #undef FUNC_NAME -SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return @code{#t} iff the code point of @var{x} is less than the code\n" - "point of @var{y}, else @code{#f}.") -#define FUNC_NAME s_scm_char_less_p +SCM_DEFINE (scm_i_char_less_p, "char<?", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} iff the code point of @var{x} is less than the code\n" + "point of @var{y}, else @code{#f}.") +#define FUNC_NAME s_scm_i_char_less_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_char_less_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_char_less_p (x, y); +} +#undef FUNC_NAME + +SCM scm_char_less_p (SCM x, SCM y) +#define FUNC_NAME s_scm_i_char_less_p { SCM_VALIDATE_CHAR (1, x); SCM_VALIDATE_CHAR (2, y); @@ -68,11 +102,28 @@ SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr, } #undef FUNC_NAME -SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return @code{#t} if the Unicode code point of @var{x} is less than or\n" - "equal to the code point of @var{y}, else @code{#f}.") -#define FUNC_NAME s_scm_char_leq_p +SCM_DEFINE (scm_i_char_leq_p, "char<=?", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} if the Unicode code point of @var{x} is less than or\n" + "equal to the code point of @var{y}, else @code{#f}.") +#define FUNC_NAME s_scm_i_char_leq_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_char_leq_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_char_leq_p (x, y); +} +#undef FUNC_NAME + +SCM scm_char_leq_p (SCM x, SCM y) +#define FUNC_NAME s_scm_i_char_leq_p { SCM_VALIDATE_CHAR (1, x); SCM_VALIDATE_CHAR (2, y); @@ -80,11 +131,28 @@ SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr, } #undef FUNC_NAME -SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return @code{#t} if the Unicode code point of @var{x} is greater than\n" - "the code point of @var{y}, else @code{#f}.") -#define FUNC_NAME s_scm_char_gr_p +SCM_DEFINE (scm_i_char_gr_p, "char>?", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} if the Unicode code point of @var{x} is greater than\n" + "the code point of @var{y}, else @code{#f}.") +#define FUNC_NAME s_scm_i_char_gr_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_char_gr_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_char_gr_p (x, y); +} +#undef FUNC_NAME + +SCM scm_char_gr_p (SCM x, SCM y) +#define FUNC_NAME s_scm_i_char_gr_p { SCM_VALIDATE_CHAR (1, x); SCM_VALIDATE_CHAR (2, y); @@ -92,11 +160,28 @@ SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr, } #undef FUNC_NAME -SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return @code{#t} if the Unicode code point of @var{x} is greater than\n" - "or equal to the code point of @var{y}, else @code{#f}.") -#define FUNC_NAME s_scm_char_geq_p +SCM_DEFINE (scm_i_char_geq_p, "char>=?", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} if the Unicode code point of @var{x} is greater than\n" + "or equal to the code point of @var{y}, else @code{#f}.") +#define FUNC_NAME s_scm_i_char_geq_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_char_geq_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_char_geq_p (x, y); +} +#undef FUNC_NAME + +SCM scm_char_geq_p (SCM x, SCM y) +#define FUNC_NAME s_scm_i_char_geq_p { SCM_VALIDATE_CHAR (1, x); SCM_VALIDATE_CHAR (2, y); @@ -111,11 +196,28 @@ SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr, implementation would be to use that table and make a char-foldcase function. */ -SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n" - "the same as the case-folded code point of @var{y}, else @code{#f}.") -#define FUNC_NAME s_scm_char_ci_eq_p +SCM_DEFINE (scm_i_char_ci_eq_p, "char-ci=?", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n" + "the same as the case-folded code point of @var{y}, else @code{#f}.") +#define FUNC_NAME s_scm_i_char_ci_eq_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_char_ci_eq_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_char_ci_eq_p (x, y); +} +#undef FUNC_NAME + +SCM scm_char_ci_eq_p (SCM x, SCM y) +#define FUNC_NAME s_scm_i_char_ci_eq_p { SCM_VALIDATE_CHAR (1, x); SCM_VALIDATE_CHAR (2, y); @@ -123,11 +225,28 @@ SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, } #undef FUNC_NAME -SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n" - "less than the case-folded code point of @var{y}, else @code{#f}.") -#define FUNC_NAME s_scm_char_ci_less_p +SCM_DEFINE (scm_i_char_ci_less_p, "char-ci<?", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n" + "less than the case-folded code point of @var{y}, else @code{#f}.") +#define FUNC_NAME s_scm_i_char_ci_less_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_char_ci_less_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_char_ci_less_p (x, y); +} +#undef FUNC_NAME + +SCM scm_char_ci_less_p (SCM x, SCM y) +#define FUNC_NAME s_scm_i_char_ci_less_p { SCM_VALIDATE_CHAR (1, x); SCM_VALIDATE_CHAR (2, y); @@ -135,12 +254,29 @@ SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr, } #undef FUNC_NAME -SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return @code{#t} iff the case-folded Unicodd code point of @var{x} is\n" - "less than or equal to the case-folded code point of @var{y}, else\n" - "@code{#f}") -#define FUNC_NAME s_scm_char_ci_leq_p +SCM_DEFINE (scm_i_char_ci_leq_p, "char-ci<=?", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} iff the case-folded Unicodd code point of @var{x} is\n" + "less than or equal to the case-folded code point of @var{y}, else\n" + "@code{#f}") +#define FUNC_NAME s_scm_i_char_ci_leq_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_char_ci_leq_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_char_ci_leq_p (x, y); +} +#undef FUNC_NAME + +SCM scm_char_ci_leq_p (SCM x, SCM y) +#define FUNC_NAME s_scm_i_char_ci_leq_p { SCM_VALIDATE_CHAR (1, x); SCM_VALIDATE_CHAR (2, y); @@ -148,11 +284,28 @@ SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr, } #undef FUNC_NAME -SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return @code{#t} iff the case-folded code point of @var{x} is greater\n" - "than the case-folded code point of @var{y}, else @code{#f}.") -#define FUNC_NAME s_scm_char_ci_gr_p +SCM_DEFINE (scm_i_char_ci_gr_p, "char-ci>?", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} iff the case-folded code point of @var{x} is greater\n" + "than the case-folded code point of @var{y}, else @code{#f}.") +#define FUNC_NAME s_scm_i_char_ci_gr_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_char_ci_gr_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_char_ci_gr_p (x, y); +} +#undef FUNC_NAME + +SCM scm_char_ci_gr_p (SCM x, SCM y) +#define FUNC_NAME s_scm_i_char_ci_gr_p { SCM_VALIDATE_CHAR (1, x); SCM_VALIDATE_CHAR (2, y); @@ -160,12 +313,29 @@ SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, } #undef FUNC_NAME -SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return @code{#t} iff the case-folded Unicode code point of @var{x} is\n" - "greater than or equal to the case-folded code point of @var{y}, else\n" - "@code{#f}.") -#define FUNC_NAME s_scm_char_ci_geq_p +SCM_DEFINE (scm_i_char_ci_geq_p, "char-ci>=?", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} iff the case-folded Unicode code point of @var{x} is\n" + "greater than or equal to the case-folded code point of @var{y}, else\n" + "@code{#f}.") +#define FUNC_NAME s_scm_i_char_ci_geq_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_char_ci_geq_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_char_ci_geq_p (x, y); +} +#undef FUNC_NAME + +SCM scm_char_ci_geq_p (SCM x, SCM y) +#define FUNC_NAME s_scm_i_char_ci_geq_p { SCM_VALIDATE_CHAR (1, x); SCM_VALIDATE_CHAR (2, y); diff --git a/libguile/eq.c b/libguile/eq.c index 6cb9bc275..422f1a53d 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -47,8 +47,8 @@ #endif -SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr, - (SCM x, SCM y), +SCM_DEFINE (scm_i_eq_p, "eq?", 0, 2, 1, + (SCM x, SCM y, SCM rest), "Return @code{#t} if @var{x} and @var{y} are the same object,\n" "except for numbers and characters. For example,\n" "\n" @@ -87,12 +87,28 @@ SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr, "(define x (string->symbol \"foo\"))\n" "(eq? x 'foo) @result{} #t\n" "@end example") -#define FUNC_NAME s_scm_eq_p +#define FUNC_NAME s_scm_i_eq_p { + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (scm_is_pair (rest)) + { + if (!scm_is_eq (x, y)) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } return scm_from_bool (scm_is_eq (x, y)); } #undef FUNC_NAME +SCM +scm_eq_p (SCM x, SCM y) +{ + return scm_from_bool (scm_is_eq (x, y)); +} + /* We compare doubles in a special way for 'eqv?' to be able to distinguish plus and minus zero and to identify NaNs. */ @@ -104,8 +120,8 @@ real_eqv (double x, double y) } #include <stdio.h> -SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, - (SCM x, SCM y), +SCM_DEFINE (scm_i_eqv_p, "eqv?", 0, 2, 1, + (SCM x, SCM y, SCM rest), "Return @code{#t} if @var{x} and @var{y} are the same object, or\n" "for characters and numbers the same value.\n" "\n" @@ -122,7 +138,24 @@ SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, "(eqv? 3 (+ 1 2)) @result{} #t\n" "(eqv? 1 1.0) @result{} #f\n" "@end example") -#define FUNC_NAME s_scm_eqv_p +#define FUNC_NAME s_scm_i_eqv_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (!scm_is_true (scm_eqv_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_eqv_p (x, y); +} +#undef FUNC_NAME + +SCM scm_eqv_p (SCM x, SCM y) +#define FUNC_NAME s_scm_i_eqv_p { if (scm_is_eq (x, y)) return SCM_BOOL_T; @@ -178,44 +211,63 @@ SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, #undef FUNC_NAME -SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, - (SCM x, SCM y), - "Return @code{#t} if @var{x} and @var{y} are the same type, and\n" - "their contents or value are equal.\n" - "\n" - "For a pair, string, vector or array, @code{equal?} compares the\n" - "contents, and does so using using the same @code{equal?}\n" - "recursively, so a deep structure can be traversed.\n" - "\n" - "@example\n" - "(equal? (list 1 2 3) (list 1 2 3)) @result{} #t\n" - "(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f\n" - "@end example\n" - "\n" - "For other objects, @code{equal?} compares as per @code{eqv?},\n" - "which means characters and numbers are compared by type and\n" - "value (and like @code{eqv?}, exact and inexact numbers are not\n" - "@code{equal?}, even if their value is the same).\n" - "\n" - "@example\n" - "(equal? 3 (+ 1 2)) @result{} #t\n" - "(equal? 1 1.0) @result{} #f\n" - "@end example\n" - "\n" - "Hash tables are currently only compared as per @code{eq?}, so\n" - "two different tables are not @code{equal?}, even if their\n" - "contents are the same.\n" - "\n" - "@code{equal?} does not support circular data structures, it may\n" - "go into an infinite loop if asked to compare two circular lists\n" - "or similar.\n" - "\n" - "New application-defined object types (Smobs) have an\n" - "@code{equalp} handler which is called by @code{equal?}. This\n" - "lets an application traverse the contents or control what is\n" - "considered @code{equal?} for two such objects. If there's no\n" - "handler, the default is to just compare as per @code{eq?}.") -#define FUNC_NAME s_scm_equal_p +SCM scm_i_equal_p (SCM, SCM, SCM); +SCM_PRIMITIVE_GENERIC (scm_i_equal_p, "equal?", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} if @var{x} and @var{y} are the same type, and\n" + "their contents or value are equal.\n" + "\n" + "For a pair, string, vector or array, @code{equal?} compares the\n" + "contents, and does so using using the same @code{equal?}\n" + "recursively, so a deep structure can be traversed.\n" + "\n" + "@example\n" + "(equal? (list 1 2 3) (list 1 2 3)) @result{} #t\n" + "(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f\n" + "@end example\n" + "\n" + "For other objects, @code{equal?} compares as per @code{eqv?},\n" + "which means characters and numbers are compared by type and\n" + "value (and like @code{eqv?}, exact and inexact numbers are not\n" + "@code{equal?}, even if their value is the same).\n" + "\n" + "@example\n" + "(equal? 3 (+ 1 2)) @result{} #t\n" + "(equal? 1 1.0) @result{} #f\n" + "@end example\n" + "\n" + "Hash tables are currently only compared as per @code{eq?}, so\n" + "two different tables are not @code{equal?}, even if their\n" + "contents are the same.\n" + "\n" + "@code{equal?} does not support circular data structures, it may\n" + "go into an infinite loop if asked to compare two circular lists\n" + "or similar.\n" + "\n" + "New application-defined object types (Smobs) have an\n" + "@code{equalp} handler which is called by @code{equal?}. This\n" + "lets an application traverse the contents or control what is\n" + "considered @code{equal?} for two such objects. If there's no\n" + "handler, the default is to just compare as per @code{eq?}.") +#define FUNC_NAME s_scm_i_equal_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (!scm_is_true (scm_equal_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = SCM_CDR (rest); + } + return scm_equal_p (x, y); +} +#undef FUNC_NAME + +SCM +scm_equal_p (SCM x, SCM y) +#define FUNC_NAME s_scm_i_equal_p { SCM_CHECK_STACK; tailrecurse: @@ -306,8 +358,8 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, return SCM_BOOL_F; generic_equal: - if (SCM_UNPACK (g_scm_equal_p)) - return scm_call_generic_2 (g_scm_equal_p, x, y); + if (SCM_UNPACK (g_scm_i_equal_p)) + return scm_call_generic_2 (g_scm_i_equal_p, x, y); else return SCM_BOOL_F; } diff --git a/libguile/goops.c b/libguile/goops.c index 5c12f51a4..4fa5ef3a3 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -226,7 +226,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return scm_class_fraction; } case scm_tc7_cxr: - case scm_tc7_rpsubr: case scm_tc7_gsubr: if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x)) return scm_class_primitive_generic; diff --git a/libguile/numbers.c b/libguile/numbers.c index 6583103df..b61b3a765 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3331,8 +3331,25 @@ SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0, #undef FUNC_NAME -SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p); -/* "Return @code{#t} if all parameters are numerically equal." */ +SCM scm_i_num_eq_p (SCM, SCM, SCM); +SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} if all parameters are numerically equal.") +#define FUNC_NAME s_scm_i_num_eq_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_num_eq_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_num_eq_p (x, y); +} +#undef FUNC_NAME SCM scm_num_eq_p (SCM x, SCM y) { @@ -3375,7 +3392,7 @@ scm_num_eq_p (SCM x, SCM y) else if (SCM_FRACTIONP (y)) return SCM_BOOL_F; else - SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); + SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p); } else if (SCM_BIGP (x)) { @@ -3410,7 +3427,7 @@ scm_num_eq_p (SCM x, SCM y) else if (SCM_FRACTIONP (y)) return SCM_BOOL_F; else - SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); + SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p); } else if (SCM_REALP (x)) { @@ -3448,7 +3465,7 @@ scm_num_eq_p (SCM x, SCM y) goto again; } else - SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); + SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p); } else if (SCM_COMPLEXP (x)) { @@ -3486,7 +3503,7 @@ scm_num_eq_p (SCM x, SCM y) goto again; } else - SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); + SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p); } else if (SCM_FRACTIONP (x)) { @@ -3520,10 +3537,10 @@ scm_num_eq_p (SCM x, SCM y) else if (SCM_FRACTIONP (y)) return scm_i_fraction_equalp (x, y); else - SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); + SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p); } else - SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p); + SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1, s_scm_i_num_eq_p); } @@ -3533,10 +3550,26 @@ scm_num_eq_p (SCM x, SCM y) mpq_cmp. flonum/frac compares likewise, but with the slight complication of the float exponent to take into account. */ -SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p); -/* "Return @code{#t} if the list of parameters is monotonically\n" - * "increasing." - */ +SCM scm_i_num_less_p (SCM, SCM, SCM); +SCM_PRIMITIVE_GENERIC (scm_i_num_less_p, "<", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} if the list of parameters is monotonically\n" + "increasing.") +#define FUNC_NAME s_scm_i_num_less_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_less_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_less_p (x, y); +} +#undef FUNC_NAME SCM scm_less_p (SCM x, SCM y) { @@ -3566,7 +3599,7 @@ scm_less_p (SCM x, SCM y) goto again; } else - SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); + SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p); } else if (SCM_BIGP (x)) { @@ -3594,7 +3627,7 @@ scm_less_p (SCM x, SCM y) else if (SCM_FRACTIONP (y)) goto int_frac; else - SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); + SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p); } else if (SCM_REALP (x)) { @@ -3622,7 +3655,7 @@ scm_less_p (SCM x, SCM y) goto again; } else - SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); + SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p); } else if (SCM_FRACTIONP (x)) { @@ -3655,43 +3688,75 @@ scm_less_p (SCM x, SCM y) goto again; } else - SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); + SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p); } else - SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p); + SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARG1, s_scm_i_num_less_p); } -SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p); -/* "Return @code{#t} if the list of parameters is monotonically\n" - * "decreasing." - */ -#define FUNC_NAME s_scm_gr_p +SCM scm_i_num_gr_p (SCM, SCM, SCM); +SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p, ">", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} if the list of parameters is monotonically\n" + "decreasing.") +#define FUNC_NAME s_scm_i_num_gr_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_gr_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_gr_p (x, y); +} +#undef FUNC_NAME +#define FUNC_NAME s_scm_i_num_gr_p SCM scm_gr_p (SCM x, SCM y) { if (!SCM_NUMBERP (x)) - SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME); + SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME); else if (!SCM_NUMBERP (y)) - SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME); + SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME); else return scm_less_p (y, x); } #undef FUNC_NAME -SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p); -/* "Return @code{#t} if the list of parameters is monotonically\n" - * "non-decreasing." - */ -#define FUNC_NAME s_scm_leq_p +SCM scm_i_num_leq_p (SCM, SCM, SCM); +SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p, "<=", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} if the list of parameters is monotonically\n" + "non-decreasing.") +#define FUNC_NAME s_scm_i_num_leq_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_leq_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_leq_p (x, y); +} +#undef FUNC_NAME +#define FUNC_NAME s_scm_i_num_leq_p SCM scm_leq_p (SCM x, SCM y) { if (!SCM_NUMBERP (x)) - SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME); + SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME); else if (!SCM_NUMBERP (y)) - SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME); + SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME); else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y))) return SCM_BOOL_F; else @@ -3700,18 +3765,34 @@ scm_leq_p (SCM x, SCM y) #undef FUNC_NAME -SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p); -/* "Return @code{#t} if the list of parameters is monotonically\n" - * "non-increasing." - */ -#define FUNC_NAME s_scm_geq_p +SCM scm_i_num_geq_p (SCM, SCM, SCM); +SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p, ">=", 0, 2, 1, + (SCM x, SCM y, SCM rest), + "Return @code{#t} if the list of parameters is monotonically\n" + "non-increasing.") +#define FUNC_NAME s_scm_i_num_geq_p +{ + if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (scm_geq_p (x, y))) + return SCM_BOOL_F; + x = y; + y = scm_car (rest); + rest = scm_cdr (rest); + } + return scm_geq_p (x, y); +} +#undef FUNC_NAME +#define FUNC_NAME s_scm_i_num_geq_p SCM scm_geq_p (SCM x, SCM y) { if (!SCM_NUMBERP (x)) - SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME); + SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME); else if (!SCM_NUMBERP (y)) - SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME); + SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME); else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y))) return SCM_BOOL_F; else diff --git a/libguile/procprop.c b/libguile/procprop.c index b74c6775d..96b82ae12 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -56,9 +56,6 @@ scm_i_procedure_arity (SCM proc) case scm_tc7_cxr: a += 1; break; - case scm_tc7_rpsubr: - r = 1; - break; case scm_tc7_program: if (scm_i_program_arity (proc, &a, &o, &r)) break; diff --git a/libguile/procs.c b/libguile/procs.c index 36ee34d48..1d1be06c4 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -135,8 +135,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, { case scm_tcs_closures: return scm_from_bool (SCM_CLOSURE_NUM_REQUIRED_ARGS (obj) == 0); - case scm_tc7_rpsubr: - return SCM_BOOL_T; case scm_tc7_gsubr: return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0); case scm_tc7_program: diff --git a/libguile/strorder.c b/libguile/strorder.c index e0a218389..0338c65d4 100644 --- a/libguile/strorder.c +++ b/libguile/strorder.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008, 2009 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 @@ -42,8 +42,8 @@ srfi13_cmp (SCM s1, SCM s2, SCM (*cmp) (SCM, SCM, SCM, SCM, SCM, SCM)) return SCM_BOOL_F; } -SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, - (SCM s1, SCM s2), +SCM_DEFINE (scm_i_string_equal_p, "string=?", 0, 2, 1, + (SCM s1, SCM s2, SCM rest), "Lexicographic equality predicate; return @code{#t} if the two\n" "strings are the same length and contain the same characters in\n" "the same positions, otherwise return @code{#f}.\n" @@ -52,103 +52,273 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr, "letters as though they were the same character, but\n" "@code{string=?} treats upper and lower case as distinct\n" "characters.") -#define FUNC_NAME s_scm_string_equal_p +#define FUNC_NAME s_scm_i_string_equal_p +{ + if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (srfi13_cmp (s1, s2, scm_string_eq))) + return SCM_BOOL_F; + s1 = s2; + s2 = scm_car (rest); + rest = scm_cdr (rest); + } + return srfi13_cmp (s1, s2, scm_string_eq); +} +#undef FUNC_NAME + +SCM scm_string_equal_p (SCM s1, SCM s2) +#define FUNC_NAME s_scm_i_string_equal_p { 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), +SCM_DEFINE (scm_i_string_ci_equal_p, "string-ci=?", 0, 2, 1, + (SCM s1, SCM s2, SCM rest), "Case-insensitive string equality predicate; return @code{#t} if\n" "the two strings are the same length and their component\n" "characters match (ignoring case) at each position; otherwise\n" "return @code{#f}.") -#define FUNC_NAME s_scm_string_ci_equal_p +#define FUNC_NAME s_scm_i_string_ci_equal_p { + if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_eq))) + return SCM_BOOL_F; + s1 = s2; + s2 = scm_car (rest); + rest = scm_cdr (rest); + } return srfi13_cmp (s1, s2, scm_string_ci_eq); } #undef FUNC_NAME -SCM_DEFINE1 (scm_string_less_p, "string<?", scm_tc7_rpsubr, - (SCM s1, SCM s2), +SCM scm_string_ci_equal_p (SCM s1, SCM s2) +#define FUNC_NAME s_scm_i_string_ci_equal_p +{ + return srfi13_cmp (s1, s2, scm_string_ci_eq); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_i_string_less_p, "string<?", 0, 2, 1, + (SCM s1, SCM s2, SCM rest), "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n" "is lexicographically less than @var{s2}.") -#define FUNC_NAME s_scm_string_less_p +#define FUNC_NAME s_scm_i_string_less_p +{ + if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (srfi13_cmp (s1, s2, scm_string_lt))) + return SCM_BOOL_F; + s1 = s2; + s2 = scm_car (rest); + rest = scm_cdr (rest); + } + return srfi13_cmp (s1, s2, scm_string_lt); +} +#undef FUNC_NAME + +SCM scm_string_less_p (SCM s1, SCM s2) +#define FUNC_NAME s_scm_i_string_less_p { return srfi13_cmp (s1, s2, scm_string_lt); } #undef FUNC_NAME -SCM_DEFINE1 (scm_string_leq_p, "string<=?", scm_tc7_rpsubr, - (SCM s1, SCM s2), +SCM_DEFINE (scm_i_string_leq_p, "string<=?", 0, 2, 1, + (SCM s1, SCM s2, SCM rest), "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n" "is lexicographically less than or equal to @var{s2}.") -#define FUNC_NAME s_scm_string_leq_p +#define FUNC_NAME s_scm_i_string_leq_p { + if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (srfi13_cmp (s1, s2, scm_string_le))) + return SCM_BOOL_F; + s1 = s2; + s2 = scm_car (rest); + rest = scm_cdr (rest); + } return srfi13_cmp (s1, s2, scm_string_le); } #undef FUNC_NAME -SCM_DEFINE1 (scm_string_gr_p, "string>?", scm_tc7_rpsubr, - (SCM s1, SCM s2), +SCM scm_string_leq_p (SCM s1, SCM s2) +#define FUNC_NAME s_scm_i_string_leq_p +{ + return srfi13_cmp (s1, s2, scm_string_le); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_i_string_gr_p, "string>?", 0, 2, 1, + (SCM s1, SCM s2, SCM rest), "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n" "is lexicographically greater than @var{s2}.") -#define FUNC_NAME s_scm_string_gr_p +#define FUNC_NAME s_scm_i_string_gr_p +{ + if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (srfi13_cmp (s1, s2, scm_string_gt))) + return SCM_BOOL_F; + s1 = s2; + s2 = scm_car (rest); + rest = scm_cdr (rest); + } + return srfi13_cmp (s1, s2, scm_string_gt); +} +#undef FUNC_NAME + +SCM scm_string_gr_p (SCM s1, SCM s2) +#define FUNC_NAME s_scm_i_string_gr_p { 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), +SCM_DEFINE (scm_i_string_geq_p, "string>=?", 0, 2, 1, + (SCM s1, SCM s2, SCM rest), "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 +#define FUNC_NAME s_scm_i_string_geq_p +{ + if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ge))) + return SCM_BOOL_F; + s1 = s2; + s2 = scm_car (rest); + rest = scm_cdr (rest); + } + return srfi13_cmp (s1, s2, scm_string_ge); +} +#undef FUNC_NAME + +SCM scm_string_geq_p (SCM s1, SCM s2) +#define FUNC_NAME s_scm_i_string_geq_p { return srfi13_cmp (s1, s2, scm_string_ge); } #undef FUNC_NAME -SCM_DEFINE1 (scm_string_ci_less_p, "string-ci<?", scm_tc7_rpsubr, - (SCM s1, SCM s2), +SCM_DEFINE (scm_i_string_ci_less_p, "string-ci<?", 0, 2, 1, + (SCM s1, SCM s2, SCM rest), "Case insensitive lexicographic ordering predicate; return\n" "@code{#t} if @var{s1} is lexicographically less than @var{s2}\n" "regardless of case.") -#define FUNC_NAME s_scm_string_ci_less_p +#define FUNC_NAME s_scm_i_string_ci_less_p { + if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_lt))) + return SCM_BOOL_F; + s1 = s2; + s2 = scm_car (rest); + rest = scm_cdr (rest); + } return srfi13_cmp (s1, s2, scm_string_ci_lt); } #undef FUNC_NAME -SCM_DEFINE1 (scm_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr, - (SCM s1, SCM s2), +SCM scm_string_ci_less_p (SCM s1, SCM s2) +#define FUNC_NAME s_scm_i_string_ci_less_p +{ + return srfi13_cmp (s1, s2, scm_string_ci_lt); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_i_string_ci_leq_p, "string-ci<=?", 0, 2, 1, + (SCM s1, SCM s2, SCM rest), "Case insensitive lexicographic ordering predicate; return\n" "@code{#t} if @var{s1} is lexicographically less than or equal\n" "to @var{s2} regardless of case.") -#define FUNC_NAME s_scm_string_ci_leq_p +#define FUNC_NAME s_scm_i_string_ci_leq_p +{ + if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_le))) + return SCM_BOOL_F; + s1 = s2; + s2 = scm_car (rest); + rest = scm_cdr (rest); + } + return srfi13_cmp (s1, s2, scm_string_ci_le); +} +#undef FUNC_NAME + +SCM scm_string_ci_leq_p (SCM s1, SCM s2) +#define FUNC_NAME s_scm_i_string_ci_leq_p { return srfi13_cmp (s1, s2, scm_string_ci_le); } #undef FUNC_NAME -SCM_DEFINE1 (scm_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr, - (SCM s1, SCM s2), +SCM_DEFINE (scm_i_string_ci_gr_p, "string-ci>?", 0, 2, 1, + (SCM s1, SCM s2, SCM rest), "Case insensitive lexicographic ordering predicate; return\n" "@code{#t} if @var{s1} is lexicographically greater than\n" "@var{s2} regardless of case.") -#define FUNC_NAME s_scm_string_ci_gr_p +#define FUNC_NAME s_scm_i_string_ci_gr_p { + if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_gt))) + return SCM_BOOL_F; + s1 = s2; + s2 = scm_car (rest); + rest = scm_cdr (rest); + } 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), +SCM scm_string_ci_gr_p (SCM s1, SCM s2) +#define FUNC_NAME s_scm_i_string_ci_gr_p +{ + return srfi13_cmp (s1, s2, scm_string_ci_gt); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_i_string_ci_geq_p, "string-ci>=?", 0, 2, 1, + (SCM s1, SCM s2, SCM rest), "Case insensitive lexicographic ordering predicate; return\n" "@code{#t} if @var{s1} is lexicographically greater than or\n" "equal to @var{s2} regardless of case.") -#define FUNC_NAME s_scm_string_ci_geq_p +#define FUNC_NAME s_scm_i_string_ci_geq_p +{ + if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2)) + return SCM_BOOL_T; + while (!scm_is_null (rest)) + { + if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_ge))) + return SCM_BOOL_F; + s1 = s2; + s2 = scm_car (rest); + rest = scm_cdr (rest); + } + return srfi13_cmp (s1, s2, scm_string_ci_ge); +} +#undef FUNC_NAME + +SCM scm_string_ci_geq_p (SCM s1, SCM s2) +#define FUNC_NAME s_scm_i_string_ci_geq_p { return srfi13_cmp (s1, s2, scm_string_ci_ge); } diff --git a/libguile/tags.h b/libguile/tags.h index a64156d64..aee2d5802 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -427,7 +427,7 @@ typedef scm_t_uintptr scm_t_bits; #define scm_tc7_unused_17 61 #define scm_tc7_gsubr 63 -#define scm_tc7_rpsubr 69 +#define scm_tc7_unused_19 69 #define scm_tc7_program 79 #define scm_tc7_unused_9 85 #define scm_tc7_unused_10 87 @@ -676,7 +676,6 @@ enum scm_tc8_tags */ #define scm_tcs_subrs \ scm_tc7_cxr:\ - case scm_tc7_rpsubr:\ case scm_tc7_gsubr diff --git a/libguile/vm.c b/libguile/vm.c index 689359e18..ca6d747a3 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -280,16 +280,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int headroom) case scm_tc7_cxr: if (nargs != 1) scm_wrong_num_args (proc); return scm_i_chase_pairs (args[0], (scm_t_bits) SCM_SUBRF (proc)); - case scm_tc7_rpsubr: - { - int idx = 0; - while (nargs-- > 1) - { idx++; - if (scm_is_false (SCM_SUBRF (proc) (args[idx-1], args[idx]))) - return SCM_BOOL_F; - } - return SCM_BOOL_T; - } case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badproc; diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index e4cec16ca..0c75d7159 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1589,7 +1589,7 @@ ;;; (with-test-prefix "=" - (expect-fail (documented? =)) + (pass-if (documented? =)) (pass-if (= 0 0)) (pass-if (= 7 7)) (pass-if (= -7 -7)) @@ -1673,7 +1673,7 @@ (with-test-prefix "<" - (expect-fail "documented?" + (pass-if "documented?" (documented? <)) (with-test-prefix "(< 0 n)" |