[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-92-g8a1
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-92-g8a1f4f9 |
|
Date: |
Fri, 04 Dec 2009 12:05:10 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=8a1f4f98e121c4ba90eb992203713cf493d45c71
The branch, master has been updated
via 8a1f4f98e121c4ba90eb992203713cf493d45c71 (commit)
via 31d845b4bc4bf50f32492c17dc43c9ccea779acb (commit)
from bf5a05f2a01fee23f5622d1429dc32f4850f98b5 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 8a1f4f98e121c4ba90eb992203713cf493d45c71
Author: Andy Wingo <address@hidden>
Date: Fri Dec 4 13:05:00 2009 +0100
remove rpsubrs
* 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.
commit 31d845b4bc4bf50f32492c17dc43c9ccea779acb
Author: Andy Wingo <address@hidden>
Date: Thu Dec 3 17:05:14 2009 +0100
remove asubrs
* libguile/tags.h (scm_tcs_subrs, scm_tc7_asubr): Remove definitions.
* 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 cases for asubrs.
* libguile/array-map.c: Gut all of the optimizations, because there are
no more asubrs, soon won't be rpsubrs, and all of this should happen
on the Scheme level, ideally.
-----------------------------------------------------------------------
Summary of changes:
libguile/array-map.c | 230 +++--------------------------------
libguile/chars.c | 274 +++++++++++++++++++++++++++++++++--------
libguile/eq.c | 144 +++++++++++++++-------
libguile/goops.c | 2 -
libguile/numbers.c | 157 ++++++++++++++++++------
libguile/procprop.c | 4 -
libguile/procs.c | 3 -
libguile/strorder.c | 232 ++++++++++++++++++++++++++++++-----
libguile/tags.h | 8 +-
libguile/vm.c | 20 ---
test-suite/tests/numbers.test | 4 +-
11 files changed, 662 insertions(+), 416 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 7200998..747747a 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -44,39 +44,6 @@
#include "libguile/array-map.h"
-typedef struct
-{
- char *name;
- SCM sproc;
- int (*vproc) ();
-} ra_iproc;
-
-
-/* These tables are a kluge that will not scale well when more
- * vectorized subrs are added. It is tempting to steal some bits from
- * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
- * offset into a table of vectorized subrs.
- */
-
-static ra_iproc ra_rpsubrs[] =
-{
- {"=", SCM_UNDEFINED, scm_ra_eqp},
- {"<", SCM_UNDEFINED, scm_ra_lessp},
- {"<=", SCM_UNDEFINED, scm_ra_leqp},
- {">", SCM_UNDEFINED, scm_ra_grp},
- {">=", SCM_UNDEFINED, scm_ra_greqp},
- {0, 0, 0}
-};
-
-static ra_iproc ra_asubrs[] =
-{
- {"+", SCM_UNDEFINED, scm_ra_sum},
- {"-", SCM_UNDEFINED, scm_ra_difference},
- {"*", SCM_UNDEFINED, scm_ra_product},
- {"/", SCM_UNDEFINED, scm_ra_divide},
- {0, 0, 0}
-};
-
/* The WHAT argument for `scm_gc_malloc ()' et al. */
static const char indices_gc_hint[] = "array-indices";
@@ -697,81 +664,6 @@ ramap (SCM ra0, SCM proc, SCM ras)
}
-static int
-ramap_rp (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1), i2 =
SCM_I_ARRAY_BASE (ra2);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- ra2 = SCM_I_ARRAY_V (ra2);
-
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (scm_is_true (scm_c_bitvector_ref (ra0, i0)))
- if (scm_is_false (SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2))))
- scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F);
-
- return 1;
-}
-
-
-
-static int
-ramap_2o (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras);
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- ras = SCM_CDR (ras);
- if (scm_is_null (ras))
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), SCM_UNDEFINED));
- }
- else
- {
- SCM ra2 = SCM_CAR (ras);
- unsigned long i2 = SCM_I_ARRAY_BASE (ra2);
- long inc2 = SCM_I_ARRAY_DIMS (ra2)->inc;
- ra2 = SCM_I_ARRAY_V (ra2);
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2)));
- }
- return 1;
-}
-
-
-
-static int
-ramap_a (SCM ra0, SCM proc, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (scm_is_null (ras))
- for (; n-- > 0; i0 += inc0)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), SCM_UNDEFINED));
- else
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), GVREF (ra1, i1)));
- }
- return 1;
-}
-
-
SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1,
scm_array_map_x);
SCM_SYMBOL (sym_b, "b");
@@ -790,83 +682,8 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
SCM_VALIDATE_PROC (2, proc);
SCM_VALIDATE_REST_ARGUMENT (lra);
- switch (SCM_TYP7 (proc))
- {
- default:
- gencase:
- scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_rpsubr:
- {
- ra_iproc *p;
- if (!scm_is_typed_array (ra0, sym_b))
- goto gencase;
- scm_array_fill_x (ra0, SCM_BOOL_T);
- for (p = ra_rpsubrs; p->name; p++)
- if (scm_is_eq (proc, p->sproc))
- {
- while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
- {
- scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
- lra = SCM_CDR (lra);
- }
- return SCM_UNSPECIFIED;
- }
- while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
- {
- scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME);
- lra = SCM_CDR (lra);
- }
- return SCM_UNSPECIFIED;
- }
- case scm_tc7_asubr:
- if (scm_is_null (lra))
- {
- SCM fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
- scm_array_fill_x (ra0, fill);
- }
- else
- {
- SCM tail, ra1 = SCM_CAR (lra);
- SCM v0 = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_V (ra0) : ra0);
- ra_iproc *p;
- /* Check to see if order might matter.
- This might be an argument for a separate
- SERIAL-ARRAY-MAP! */
- if (scm_is_eq (v0, ra1)
- || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
- if (!scm_is_eq (ra0, ra1)
- || (SCM_I_ARRAYP(ra0) && !SCM_I_ARRAY_CONTP(ra0)))
- goto gencase;
- for (tail = SCM_CDR (lra); !scm_is_null (tail); tail = SCM_CDR (tail))
- {
- ra1 = SCM_CAR (tail);
- if (scm_is_eq (v0, ra1)
- || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V
(ra1))))
- goto gencase;
- }
- for (p = ra_asubrs; p->name; p++)
- if (scm_is_eq (proc, p->sproc))
- {
- if (!scm_is_eq (ra0, SCM_CAR (lra)))
- scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons
(SCM_CAR (lra), SCM_EOL), FUNC_NAME);
- lra = SCM_CDR (lra);
- while (1)
- {
- scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
- if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
- return SCM_UNSPECIFIED;
- lra = SCM_CDR (lra);
- }
- }
- scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
- lra = SCM_CDR (lra);
- if (SCM_NIMP (lra))
- for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
- scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME);
- }
- return SCM_UNSPECIFIED;
- }
+ scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1111,23 +928,29 @@ scm_raequal (SCM ra0, SCM ra1)
return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
}
-#if 0
-/* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
-SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr,
- (SCM ra0, SCM ra1),
+SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
+ (SCM ra0, SCM ra1, SCM rest),
"Return @code{#t} iff all arguments are arrays with the same\n"
"shape, the same type, and have corresponding elements which are\n"
"either @code{equal?} or @code{array-equal?}. This function\n"
"differs from @code{equal?} in that a one dimensional shared\n"
"array may be @var{array-equal?} but not @var{equal?} to a\n"
"vector or uniform vector.")
-#define FUNC_NAME s_scm_array_equal_p
-{
+#define FUNC_NAME s_scm_i_array_equal_p
+{
+ if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
+ return SCM_BOOL_T;
+
+ while (!scm_is_null (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);
}
#undef FUNC_NAME
-#endif
-
-static char s_array_equal_p[] = "array-equal?";
SCM
@@ -1139,28 +962,9 @@ scm_array_equal_p (SCM ra0, SCM ra1)
}
-static void
-init_raprocs (ra_iproc *subra)
-{
- for (; subra->name; subra++)
- {
- SCM sym = scm_from_locale_symbol (subra->name);
- SCM var =
- scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
- if (var != SCM_BOOL_F)
- subra->sproc = SCM_VARIABLE_REF (var);
- else
- subra->sproc = SCM_BOOL_F;
- }
-}
-
-
void
scm_init_array_map (void)
{
- init_raprocs (ra_rpsubrs);
- init_raprocs (ra_asubrs);
- scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
#include "libguile/array-map.x"
scm_add_feature (s_scm_array_for_each);
diff --git a/libguile/chars.c b/libguile/chars.c
index 59ac6f4..68e6dc1 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 6cb9bc2..422f1a5 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 7ce5b31..4fa5ef3 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -225,9 +225,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc16_fraction:
return scm_class_fraction;
}
- case scm_tc7_asubr:
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 6583103..b61b3a7 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 a92d31c..96b82ae 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -56,10 +56,6 @@ scm_i_procedure_arity (SCM proc)
case scm_tc7_cxr:
a += 1;
break;
- case scm_tc7_asubr:
- 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 6fda200..1d1be06 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -135,9 +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:
- case scm_tc7_asubr:
- 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 e0a2183..0338c65 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 2a9fc4b..aee2d58 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -427,14 +427,14 @@ 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
#define scm_tc7_cxr 93
#define scm_tc7_unused_11 95
#define scm_tc7_unused_12 101
-#define scm_tc7_asubr 103
+#define scm_tc7_unused_18 103
#define scm_tc7_unused_13 109
#define scm_tc7_unused_14 111
#define scm_tc7_unused_15 117
@@ -675,9 +675,7 @@ enum scm_tc8_tags
/* For subrs
*/
#define scm_tcs_subrs \
- scm_tc7_asubr:\
- case scm_tc7_cxr:\
- case scm_tc7_rpsubr:\
+ scm_tc7_cxr:\
case scm_tc7_gsubr
diff --git a/libguile/vm.c b/libguile/vm.c
index fdfae00..ca6d747 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -280,26 +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_asubr:
- if (nargs < 2)
- return SCM_SUBRF (proc) (args[0], SCM_UNDEFINED);
- {
- SCM x = args[0];
- int idx = 1;
- while (nargs-- > 1)
- x = SCM_SUBRF (proc) (x, args[idx++]);
- return x;
- }
- 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 e4cec16..0c75d71 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)"
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-5-92-g8a1f4f9,
Andy Wingo <=