mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 08:10:17 +02:00
Code Activity

remove rpsubrs

Browse source 
* libguile/tags.h: Remove rpsubrs (I chose to interpret the terse name
  as "recursive predicate subrs"). Just use gsubrs with rest arguments,
  or do a fold yourself.

* libguile/array-map.c (scm_i_array_equal_p): Do the comparison in
  order, why not.

* libguile/chars.c:
* libguile/eq.c:
* libguile/numbers.c:
* libguile/strorder.c: Add 0,2,1 gsubr wrappers for rpsubrs like eq?, <,
  etc.

* libguile/goops.c (scm_class_of)
* libguile/procprop.c (scm_i_procedure_arity)
* libguile/procs.c (scm_thunk_p)
* libguile/vm.c (apply_foreign): Remove rpsubr cases.

* test-suite/tests/numbers.test ("=", "<"): Turn a couple xfails into
  passes.
This commit is contained in:
Andy Wingo 2009-12-04 13:05:00 +01:00
parent 31d845b4bc
commit 8a1f4f98e1
11 changed files with 646 additions and 188 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/array-map.c
View file

@ -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);

230
libguile/chars.c
View file

@ -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),
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_char_eq_p
#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),
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_char_less_p
#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),
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_char_leq_p
#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),
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_char_gr_p
#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),
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_char_geq_p
#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),
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_char_ci_eq_p
#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),
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_char_ci_less_p
#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),
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_char_ci_leq_p
#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),
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_char_ci_gr_p
#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),
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_char_ci_geq_p
#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);

74
libguile/eq.c
View file

@ -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,8 +211,9 @@ 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),
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"
@ -215,7 +249,25 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
"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
#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;
}

1
libguile/goops.c
View file

@ -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;

157
libguile/numbers.c
View file

@ -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

3
libguile/procprop.c
View file

@ -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;

2
libguile/procs.c
View file

@ -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:

232
libguile/strorder.c
View file

@ -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 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_DEFINE1 (scm_string_less_p, "string<?", scm_tc7_rpsubr,
(SCM s1, SCM s2),
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 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_DEFINE1 (scm_string_gr_p, "string>?", scm_tc7_rpsubr,
(SCM s1, SCM s2),
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 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_DEFINE1 (scm_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr,
(SCM s1, SCM s2),
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 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_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr,
(SCM s1, SCM s2),
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);
}

3
libguile/tags.h
View file

@ -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

10
libguile/vm.c
View file

@ -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;

4
test-suite/tests/numbers.test
View file

@ -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)"