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

This set of patches separates the representation of the cxr family

Browse source 
of functions (car, cdr etc.) from the dsubr family of functions
	(i. e. functions that take a double precision floating point
	argument).  Further, the algorithm for handling the cxr function
	is improved.

	* eval.c (SCM_CEVAL, SCM_APPLY, scm_trampoline_1), numbers.c
	(scm_asinh, scm_acosh, scm_atanh, scm_truncate, scm_round, floor,
	ceil, sqrt, fabs, exp, log, sin, cos, tan, asin, acos, atan, sinh,
	cosh, tanh), objects.c (scm_class_of), procprop.c
	(scm_i_procedure_arity), ramap.c (scm_array_map_x), tags.h
	(scm_tc7_dsubr, scm_tcs_subrs): Introduce scm_tc7_dsubr as new
	typecode for the dsubr family of functions.

	* ramap.c (ramap_cxr, ramap_dsubr): Renamed ramap_cxr to
	ramap_dsubr.

	* eval.c (SCM_CEVAL, SCM_APPLY, call_cxr_1), pairs.c
	(scm_init_pairs): Make use of the (now usable) second cell element
	of a scm_tc7_cxr function to implement the cxr family of functions
	more efficiently.
This commit is contained in:
Dirk Herrmann 2003-06-01 13:58:42 +00:00
parent e757438dc9
commit 14b18ed6f5
8 changed files with 174 additions and 128 deletions
Download patch file Download diff file Expand all files Collapse all files

24
libguile/ChangeLog
View file

@ -1,3 +1,27 @@
2003-06-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
This set of patches separates the representation of the cxr family
of functions (car, cdr etc.) from the dsubr family of functions
(i. e. functions that take a double precision floating point
argument). Further, the algorithm for handling the cxr function
is improved.
* eval.c (SCM_CEVAL, SCM_APPLY, scm_trampoline_1), numbers.c
(scm_asinh, scm_acosh, scm_atanh, scm_truncate, scm_round, floor,
ceil, sqrt, fabs, exp, log, sin, cos, tan, asin, acos, atan, sinh,
cosh, tanh), objects.c (scm_class_of), procprop.c
(scm_i_procedure_arity), ramap.c (scm_array_map_x), tags.h
(scm_tc7_dsubr, scm_tcs_subrs): Introduce scm_tc7_dsubr as new
typecode for the dsubr family of functions.
* ramap.c (ramap_cxr, ramap_dsubr): Renamed ramap_cxr to
ramap_dsubr.
* eval.c (SCM_CEVAL, SCM_APPLY, call_cxr_1), pairs.c
(scm_init_pairs): Make use of the (now usable) second cell element
of a scm_tc7_cxr function to implement the cxr family of functions
more efficiently.
2003-05-31 Dirk Herrmann <D.Herrmann@tu-bs.de> 2003-05-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
* eval.c (SCM_CEVAL, SCM_APPLY, scm_trampoline_0, * eval.c (SCM_CEVAL, SCM_APPLY, scm_trampoline_0,

126
libguile/eval.c
View file

@ -2885,6 +2885,7 @@ evapply: /* inputs: x, proc */
case scm_tc7_subr_1: case scm_tc7_subr_1:
case scm_tc7_subr_2: case scm_tc7_subr_2:
case scm_tc7_subr_2o: case scm_tc7_subr_2o:
case scm_tc7_dsubr:
case scm_tc7_cxr: case scm_tc7_cxr:
case scm_tc7_subr_3: case scm_tc7_subr_3:
case scm_tc7_lsubr_2: case scm_tc7_lsubr_2:
@ -2921,33 +2922,31 @@ evapply: /* inputs: x, proc */
case scm_tc7_subr_1: case scm_tc7_subr_1:
case scm_tc7_subr_1o: case scm_tc7_subr_1o:
RETURN (SCM_SUBRF (proc) (arg1)); RETURN (SCM_SUBRF (proc) (arg1));
case scm_tc7_dsubr:
if (SCM_INUMP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
}
else if (SCM_REALP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
}
else if (SCM_BIGP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
case scm_tc7_cxr: case scm_tc7_cxr:
if (SCM_SUBRF (proc))
{
if (SCM_INUMP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
}
else if (SCM_REALP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
}
else if (SCM_BIGP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
}
proc = SCM_SNAME (proc);
{ {
char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc);
while ('c' != *--chrs) do
{ {
SCM_ASSERT (SCM_CONSP (arg1), SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1,
arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1);
} pattern >>= 2;
} while (pattern);
RETURN (arg1); RETURN (arg1);
} }
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
@ -3119,6 +3118,7 @@ evapply: /* inputs: x, proc */
else else
goto badfun; goto badfun;
case scm_tc7_subr_0: case scm_tc7_subr_0:
case scm_tc7_dsubr:
case scm_tc7_cxr: case scm_tc7_cxr:
case scm_tc7_subr_1o: case scm_tc7_subr_1o:
case scm_tc7_subr_1: case scm_tc7_subr_1:
@ -3317,6 +3317,7 @@ evapply: /* inputs: x, proc */
case scm_tc7_subr_1o: case scm_tc7_subr_1o:
case scm_tc7_subr_2o: case scm_tc7_subr_2o:
case scm_tc7_subr_0: case scm_tc7_subr_0:
case scm_tc7_dsubr:
case scm_tc7_cxr: case scm_tc7_cxr:
case scm_tc7_subr_1: case scm_tc7_subr_1:
scm_wrong_num_args (proc); scm_wrong_num_args (proc);
@ -3602,34 +3603,34 @@ tail:
scm_wrong_num_args (proc); scm_wrong_num_args (proc);
else else
RETURN (SCM_SUBRF (proc) (arg1)); RETURN (SCM_SUBRF (proc) (arg1));
case scm_tc7_dsubr:
if (SCM_UNBNDP (arg1) || !SCM_NULLP (args))
scm_wrong_num_args (proc);
if (SCM_INUMP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
}
else if (SCM_REALP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
}
else if (SCM_BIGP (arg1))
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
case scm_tc7_cxr: case scm_tc7_cxr:
if (SCM_UNBNDP (arg1) || !SCM_NULLP (args)) if (SCM_UNBNDP (arg1) || !SCM_NULLP (args))
scm_wrong_num_args (proc); scm_wrong_num_args (proc);
if (SCM_SUBRF (proc))
{
if (SCM_INUMP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
}
else if (SCM_REALP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
}
else if (SCM_BIGP (arg1))
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
}
proc = SCM_SNAME (proc);
{ {
char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc);
while ('c' != *--chrs) do
{ {
SCM_ASSERT (SCM_CONSP (arg1), SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1,
arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1);
} pattern >>= 2;
RETURN (arg1); } while (pattern);
RETURN (arg1);
} }
case scm_tc7_subr_3: case scm_tc7_subr_3:
if (SCM_NULLP (args) if (SCM_NULLP (args)
@ -3951,17 +3952,15 @@ call_dsubr_1 (SCM proc, SCM arg1)
static SCM static SCM
call_cxr_1 (SCM proc, SCM arg1) call_cxr_1 (SCM proc, SCM arg1)
{ {
proc = SCM_SNAME (proc); unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc);
{ do
char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; {
while ('c' != *--chrs) SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1,
{ SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
SCM_ASSERT (SCM_CONSP (arg1), arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1);
arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); pattern >>= 2;
arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); } while (pattern);
} return arg1;
return (arg1);
}
} }
static SCM static SCM
@ -3990,11 +3989,10 @@ scm_trampoline_1 (SCM proc)
return call_subr2o_1; return call_subr2o_1;
case scm_tc7_lsubr: case scm_tc7_lsubr:
return call_lsubr_1; return call_lsubr_1;
case scm_tc7_dsubr:
return call_dsubr_1;
case scm_tc7_cxr: case scm_tc7_cxr:
if (SCM_SUBRF (proc)) return call_cxr_1;
return call_dsubr_1;
else
return call_cxr_1;
case scm_tcs_closures: case scm_tcs_closures:
{ {
SCM formals = SCM_CLOSURE_FORMALS (proc); SCM formals = SCM_CLOSURE_FORMALS (proc);

42
libguile/numbers.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc. /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc.
* *
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide. * and Bellcore. See scm_divide.
@ -3613,7 +3613,7 @@ scm_divide (SCM x, SCM y)
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh, g_asinh); SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_dsubr, (SCM (*)()) scm_asinh, g_asinh);
/* "Return the inverse hyperbolic sine of @var{x}." /* "Return the inverse hyperbolic sine of @var{x}."
*/ */
double double
@ -3623,7 +3623,7 @@ scm_asinh (double x)
} }
SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh, g_acosh); SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_dsubr, (SCM (*)()) scm_acosh, g_acosh);
/* "Return the inverse hyperbolic cosine of @var{x}." /* "Return the inverse hyperbolic cosine of @var{x}."
*/ */
double double
@ -3633,7 +3633,7 @@ scm_acosh (double x)
} }
SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh, g_atanh); SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) scm_atanh, g_atanh);
/* "Return the inverse hyperbolic tangent of @var{x}." /* "Return the inverse hyperbolic tangent of @var{x}."
*/ */
double double
@ -3643,7 +3643,7 @@ scm_atanh (double x)
} }
SCM_GPROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate, g_truncate); SCM_GPROC1 (s_truncate, "truncate", scm_tc7_dsubr, (SCM (*)()) scm_truncate, g_truncate);
/* "Round the inexact number @var{x} towards zero." /* "Round the inexact number @var{x} towards zero."
*/ */
double double
@ -3655,7 +3655,7 @@ scm_truncate (double x)
} }
SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round, g_round); SCM_GPROC1 (s_round, "round", scm_tc7_dsubr, (SCM (*)()) scm_round, g_round);
/* "Round the inexact number @var{x}. If @var{x} is halfway between two\n" /* "Round the inexact number @var{x}. If @var{x} is halfway between two\n"
* "numbers, round towards even." * "numbers, round towards even."
*/ */
@ -3670,49 +3670,49 @@ scm_round (double x)
} }
SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor); SCM_GPROC1 (s_i_floor, "floor", scm_tc7_dsubr, (SCM (*)()) floor, g_i_floor);
/* "Round the number @var{x} towards minus infinity." /* "Round the number @var{x} towards minus infinity."
*/ */
SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil, g_i_ceil); SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_dsubr, (SCM (*)()) ceil, g_i_ceil);
/* "Round the number @var{x} towards infinity." /* "Round the number @var{x} towards infinity."
*/ */
SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt, g_i_sqrt); SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_dsubr, (SCM (*)()) sqrt, g_i_sqrt);
/* "Return the square root of the real number @var{x}." /* "Return the square root of the real number @var{x}."
*/ */
SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs, g_i_abs); SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_dsubr, (SCM (*)()) fabs, g_i_abs);
/* "Return the absolute value of the real number @var{x}." /* "Return the absolute value of the real number @var{x}."
*/ */
SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp, g_i_exp); SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_dsubr, (SCM (*)()) exp, g_i_exp);
/* "Return the @var{x}th power of e." /* "Return the @var{x}th power of e."
*/ */
SCM_GPROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log, g_i_log); SCM_GPROC1 (s_i_log, "$log", scm_tc7_dsubr, (SCM (*)()) log, g_i_log);
/* "Return the natural logarithm of the real number @var{x}." /* "Return the natural logarithm of the real number @var{x}."
*/ */
SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin, g_i_sin); SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_dsubr, (SCM (*)()) sin, g_i_sin);
/* "Return the sine of the real number @var{x}." /* "Return the sine of the real number @var{x}."
*/ */
SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)()) cos, g_i_cos); SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_dsubr, (SCM (*)()) cos, g_i_cos);
/* "Return the cosine of the real number @var{x}." /* "Return the cosine of the real number @var{x}."
*/ */
SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)()) tan, g_i_tan); SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_dsubr, (SCM (*)()) tan, g_i_tan);
/* "Return the tangent of the real number @var{x}." /* "Return the tangent of the real number @var{x}."
*/ */
SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)()) asin, g_i_asin); SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_dsubr, (SCM (*)()) asin, g_i_asin);
/* "Return the arc sine of the real number @var{x}." /* "Return the arc sine of the real number @var{x}."
*/ */
SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)()) acos, g_i_acos); SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_dsubr, (SCM (*)()) acos, g_i_acos);
/* "Return the arc cosine of the real number @var{x}." /* "Return the arc cosine of the real number @var{x}."
*/ */
SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)()) atan, g_i_atan); SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_dsubr, (SCM (*)()) atan, g_i_atan);
/* "Return the arc tangent of the real number @var{x}." /* "Return the arc tangent of the real number @var{x}."
*/ */
SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)()) sinh, g_i_sinh); SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_dsubr, (SCM (*)()) sinh, g_i_sinh);
/* "Return the hyperbolic sine of the real number @var{x}." /* "Return the hyperbolic sine of the real number @var{x}."
*/ */
SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)()) cosh, g_i_cosh); SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_dsubr, (SCM (*)()) cosh, g_i_cosh);
/* "Return the hyperbolic cosine of the real number @var{x}." /* "Return the hyperbolic cosine of the real number @var{x}."
*/ */
SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)()) tanh, g_i_tanh); SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_dsubr, (SCM (*)()) tanh, g_i_tanh);
/* "Return the hyperbolic tangent of the real number @var{x}." /* "Return the hyperbolic tangent of the real number @var{x}."
*/ */

1
libguile/objects.c
View file

@ -112,6 +112,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc7_asubr: case scm_tc7_asubr:
case scm_tc7_subr_0: case scm_tc7_subr_0:
case scm_tc7_subr_1: case scm_tc7_subr_1:
case scm_tc7_dsubr:
case scm_tc7_cxr: case scm_tc7_cxr:
case scm_tc7_subr_3: case scm_tc7_subr_3:
case scm_tc7_subr_2: case scm_tc7_subr_2:

82
libguile/pairs.c
View file

@ -106,39 +106,50 @@ SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0,
static const char * cxrs[] = /* Every cxr-pattern is made up of pairs of bits, starting with the two least
* significant bits. If in a pair of bits the least significant of the two
* bits is 0, this means CDR, otherwise CAR. The most significant bits of the
* two bits is only needed to indicate when cxr-ing is ready. This is the
* case, when all remaining pairs of bits equal 00. */
typedef struct {
const char *name;
unsigned char pattern;
} t_cxr;
static const t_cxr cxrs[] =
{ {
"car", {"cdr", 0x02}, /* 00000010 */
"cdr", {"car", 0x03}, /* 00000011 */
"caar", {"cddr", 0x0a}, /* 00001010 */
"cadr", {"cdar", 0x0b}, /* 00001011 */
"cdar", {"cadr", 0x0e}, /* 00001110 */
"cddr", {"caar", 0x0f}, /* 00001111 */
"caaar", {"cdddr", 0x2a}, /* 00101010 */
"caadr", {"cddar", 0x2b}, /* 00101011 */
"cadar", {"cdadr", 0x2e}, /* 00101110 */
"caddr", {"cdaar", 0x2f}, /* 00101111 */
"cdaar", {"caddr", 0x3a}, /* 00111010 */
"cdadr", {"cadar", 0x3b}, /* 00111011 */
"cddar", {"caadr", 0x3e}, /* 00111110 */
"cdddr", {"caaar", 0x3f}, /* 00111111 */
"caaaar", {"cddddr", 0xaa}, /* 10101010 */
"caaadr", {"cdddar", 0xab}, /* 10101011 */
"caadar", {"cddadr", 0xae}, /* 10101110 */
"caaddr", {"cddaar", 0xaf}, /* 10101111 */
"cadaar", {"cdaddr", 0xba}, /* 10111010 */
"cadadr", {"cdadar", 0xbb}, /* 10111011 */
"caddar", {"cdaadr", 0xbe}, /* 10111110 */
"cadddr", {"cdaaar", 0xbf}, /* 10111111 */
"cdaaar", {"cadddr", 0xea}, /* 11101010 */
"cdaadr", {"caddar", 0xeb}, /* 11101011 */
"cdadar", {"cadadr", 0xee}, /* 11101110 */
"cdaddr", {"cadaar", 0xef}, /* 11101111 */
"cddaar", {"caaddr", 0xfa}, /* 11111010 */
"cddadr", {"caadar", 0xfb}, /* 11111011 */
"cdddar", {"caaadr", 0xfe}, /* 11111110 */
"cddddr", {"caaaar", 0xff}, /* 11111111 */
0 {0, 0}
}; };
@ -148,8 +159,11 @@ scm_init_pairs ()
{ {
unsigned int subnr = 0; unsigned int subnr = 0;
for (subnr = 0; cxrs [subnr]; subnr++) for (subnr = 0; cxrs[subnr].name; subnr++)
scm_c_define_subr (cxrs [subnr], scm_tc7_cxr, NULL); {
SCM (*pattern) () = (SCM (*) ()) (scm_t_bits) cxrs[subnr].pattern;
scm_c_define_subr (cxrs[subnr].name, scm_tc7_cxr, pattern);
}
#include "libguile/pairs.x" #include "libguile/pairs.x"
} }

1
libguile/procprop.c
View file

@ -52,6 +52,7 @@ scm_i_procedure_arity (SCM proc)
case scm_tc7_subr_2o: case scm_tc7_subr_2o:
o = 1; o = 1;
case scm_tc7_subr_1: case scm_tc7_subr_1:
case scm_tc7_dsubr:
case scm_tc7_cxr: case scm_tc7_cxr:
a += 1; a += 1;
break; break;

8
libguile/ramap.c
View file

@ -1247,7 +1247,7 @@ ramap (SCM ra0, SCM proc, SCM ras)
static int static int
ramap_cxr (SCM ra0, SCM proc, SCM ras) ramap_dsubr (SCM ra0, SCM proc, SCM ras)
{ {
SCM ra1 = SCM_CAR (ras); SCM ra1 = SCM_CAR (ras);
SCM e1 = SCM_UNDEFINED; SCM e1 = SCM_UNDEFINED;
@ -1514,10 +1514,8 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
case scm_tc7_subr_2o: case scm_tc7_subr_2o:
scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME); scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
case scm_tc7_cxr: case scm_tc7_dsubr:
if (!SCM_SUBRF (proc)) scm_ramapc (ramap_dsubr, proc, ra0, lra, FUNC_NAME);
goto gencase;
scm_ramapc (ramap_cxr, proc, ra0, lra, FUNC_NAME);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
{ {

18
libguile/tags.h
View file

@ -319,7 +319,7 @@ typedef unsigned long scm_t_bits;
#define scm_tc7_ivect 79 #define scm_tc7_ivect 79
#endif #endif
/* free 61 */ #define scm_tc7_dsubr 61
#define scm_tc7_cclo 63 #define scm_tc7_cclo 63
#define scm_tc7_rpsubr 69 #define scm_tc7_rpsubr 69
#define scm_tc7_subr_0 85 #define scm_tc7_subr_0 85
@ -497,9 +497,19 @@ SCM_API char *scm_isymnames[]; /* defined in print.c */
/* For subrs /* For subrs
*/ */
#define scm_tcs_subrs scm_tc7_asubr:case scm_tc7_subr_0:case scm_tc7_subr_1:case scm_tc7_cxr:\ #define scm_tcs_subrs \
case scm_tc7_subr_3:case scm_tc7_subr_2:case scm_tc7_rpsubr:case scm_tc7_subr_1o:\ scm_tc7_asubr:\
case scm_tc7_subr_2o:case scm_tc7_lsubr_2:case scm_tc7_lsubr case scm_tc7_subr_0:\
case scm_tc7_subr_1:\
case scm_tc7_dsubr:\
case scm_tc7_cxr:\
case scm_tc7_subr_3:\
case scm_tc7_subr_2:\
case scm_tc7_rpsubr:\
case scm_tc7_subr_1o:\
case scm_tc7_subr_2o:\
case scm_tc7_lsubr_2:\
case scm_tc7_lsubr