summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/array-map.c4
-rw-r--r--libguile/chars.c274
-rw-r--r--libguile/eq.c144
-rw-r--r--libguile/goops.c1
-rw-r--r--libguile/numbers.c157
-rw-r--r--libguile/procprop.c3
-rw-r--r--libguile/procs.c2
-rw-r--r--libguile/strorder.c232
-rw-r--r--libguile/tags.h3
-rw-r--r--libguile/vm.c10
-rw-r--r--test-suite/tests/numbers.test4
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)"