mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 22:31:12 +02:00
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.
This commit is contained in:
parent
e757438dc9
commit
14b18ed6f5
8 changed files with 174 additions and 128 deletions
|
@ -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>
|
||||
|
||||
* eval.c (SCM_CEVAL, SCM_APPLY, scm_trampoline_0,
|
||||
|
|
126
libguile/eval.c
126
libguile/eval.c
|
@ -2885,6 +2885,7 @@ evapply: /* inputs: x, proc */
|
|||
case scm_tc7_subr_1:
|
||||
case scm_tc7_subr_2:
|
||||
case scm_tc7_subr_2o:
|
||||
case scm_tc7_dsubr:
|
||||
case scm_tc7_cxr:
|
||||
case scm_tc7_subr_3:
|
||||
case scm_tc7_lsubr_2:
|
||||
|
@ -2921,33 +2922,31 @@ evapply: /* inputs: x, proc */
|
|||
case scm_tc7_subr_1:
|
||||
case scm_tc7_subr_1o:
|
||||
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:
|
||||
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;
|
||||
while ('c' != *--chrs)
|
||||
{
|
||||
SCM_ASSERT (SCM_CONSP (arg1),
|
||||
arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
|
||||
arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
|
||||
}
|
||||
unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc);
|
||||
do
|
||||
{
|
||||
SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1,
|
||||
SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
|
||||
arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1);
|
||||
pattern >>= 2;
|
||||
} while (pattern);
|
||||
RETURN (arg1);
|
||||
}
|
||||
case scm_tc7_rpsubr:
|
||||
|
@ -3119,6 +3118,7 @@ evapply: /* inputs: x, proc */
|
|||
else
|
||||
goto badfun;
|
||||
case scm_tc7_subr_0:
|
||||
case scm_tc7_dsubr:
|
||||
case scm_tc7_cxr:
|
||||
case scm_tc7_subr_1o:
|
||||
case scm_tc7_subr_1:
|
||||
|
@ -3317,6 +3317,7 @@ evapply: /* inputs: x, proc */
|
|||
case scm_tc7_subr_1o:
|
||||
case scm_tc7_subr_2o:
|
||||
case scm_tc7_subr_0:
|
||||
case scm_tc7_dsubr:
|
||||
case scm_tc7_cxr:
|
||||
case scm_tc7_subr_1:
|
||||
scm_wrong_num_args (proc);
|
||||
|
@ -3602,34 +3603,34 @@ tail:
|
|||
scm_wrong_num_args (proc);
|
||||
else
|
||||
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:
|
||||
if (SCM_UNBNDP (arg1) || !SCM_NULLP (args))
|
||||
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;
|
||||
while ('c' != *--chrs)
|
||||
{
|
||||
SCM_ASSERT (SCM_CONSP (arg1),
|
||||
arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
|
||||
arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
|
||||
}
|
||||
RETURN (arg1);
|
||||
unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc);
|
||||
do
|
||||
{
|
||||
SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1,
|
||||
SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
|
||||
arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1);
|
||||
pattern >>= 2;
|
||||
} while (pattern);
|
||||
RETURN (arg1);
|
||||
}
|
||||
case scm_tc7_subr_3:
|
||||
if (SCM_NULLP (args)
|
||||
|
@ -3951,17 +3952,15 @@ call_dsubr_1 (SCM proc, SCM arg1)
|
|||
static SCM
|
||||
call_cxr_1 (SCM proc, SCM arg1)
|
||||
{
|
||||
proc = SCM_SNAME (proc);
|
||||
{
|
||||
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 (proc));
|
||||
arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
|
||||
}
|
||||
return (arg1);
|
||||
}
|
||||
unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc);
|
||||
do
|
||||
{
|
||||
SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1,
|
||||
SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
|
||||
arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1);
|
||||
pattern >>= 2;
|
||||
} while (pattern);
|
||||
return arg1;
|
||||
}
|
||||
|
||||
static SCM
|
||||
|
@ -3990,11 +3989,10 @@ scm_trampoline_1 (SCM proc)
|
|||
return call_subr2o_1;
|
||||
case scm_tc7_lsubr:
|
||||
return call_lsubr_1;
|
||||
case scm_tc7_dsubr:
|
||||
return call_dsubr_1;
|
||||
case scm_tc7_cxr:
|
||||
if (SCM_SUBRF (proc))
|
||||
return call_dsubr_1;
|
||||
else
|
||||
return call_cxr_1;
|
||||
return call_cxr_1;
|
||||
case scm_tcs_closures:
|
||||
{
|
||||
SCM formals = SCM_CLOSURE_FORMALS (proc);
|
||||
|
|
|
@ -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
|
||||
* and Bellcore. See scm_divide.
|
||||
|
@ -3613,7 +3613,7 @@ scm_divide (SCM x, SCM y)
|
|||
}
|
||||
#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}."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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."
|
||||
*/
|
||||
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"
|
||||
* "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."
|
||||
*/
|
||||
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."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
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}."
|
||||
*/
|
||||
|
||||
|
|
|
@ -112,6 +112,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
|
|||
case scm_tc7_asubr:
|
||||
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:
|
||||
|
|
|
@ -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",
|
||||
"caar",
|
||||
"cadr",
|
||||
"cdar",
|
||||
"cddr",
|
||||
"caaar",
|
||||
"caadr",
|
||||
"cadar",
|
||||
"caddr",
|
||||
"cdaar",
|
||||
"cdadr",
|
||||
"cddar",
|
||||
"cdddr",
|
||||
"caaaar",
|
||||
"caaadr",
|
||||
"caadar",
|
||||
"caaddr",
|
||||
"cadaar",
|
||||
"cadadr",
|
||||
"caddar",
|
||||
"cadddr",
|
||||
"cdaaar",
|
||||
"cdaadr",
|
||||
"cdadar",
|
||||
"cdaddr",
|
||||
"cddaar",
|
||||
"cddadr",
|
||||
"cdddar",
|
||||
"cddddr",
|
||||
0
|
||||
{"cdr", 0x02}, /* 00000010 */
|
||||
{"car", 0x03}, /* 00000011 */
|
||||
{"cddr", 0x0a}, /* 00001010 */
|
||||
{"cdar", 0x0b}, /* 00001011 */
|
||||
{"cadr", 0x0e}, /* 00001110 */
|
||||
{"caar", 0x0f}, /* 00001111 */
|
||||
{"cdddr", 0x2a}, /* 00101010 */
|
||||
{"cddar", 0x2b}, /* 00101011 */
|
||||
{"cdadr", 0x2e}, /* 00101110 */
|
||||
{"cdaar", 0x2f}, /* 00101111 */
|
||||
{"caddr", 0x3a}, /* 00111010 */
|
||||
{"cadar", 0x3b}, /* 00111011 */
|
||||
{"caadr", 0x3e}, /* 00111110 */
|
||||
{"caaar", 0x3f}, /* 00111111 */
|
||||
{"cddddr", 0xaa}, /* 10101010 */
|
||||
{"cdddar", 0xab}, /* 10101011 */
|
||||
{"cddadr", 0xae}, /* 10101110 */
|
||||
{"cddaar", 0xaf}, /* 10101111 */
|
||||
{"cdaddr", 0xba}, /* 10111010 */
|
||||
{"cdadar", 0xbb}, /* 10111011 */
|
||||
{"cdaadr", 0xbe}, /* 10111110 */
|
||||
{"cdaaar", 0xbf}, /* 10111111 */
|
||||
{"cadddr", 0xea}, /* 11101010 */
|
||||
{"caddar", 0xeb}, /* 11101011 */
|
||||
{"cadadr", 0xee}, /* 11101110 */
|
||||
{"cadaar", 0xef}, /* 11101111 */
|
||||
{"caaddr", 0xfa}, /* 11111010 */
|
||||
{"caadar", 0xfb}, /* 11111011 */
|
||||
{"caaadr", 0xfe}, /* 11111110 */
|
||||
{"caaaar", 0xff}, /* 11111111 */
|
||||
{0, 0}
|
||||
};
|
||||
|
||||
|
||||
|
@ -148,8 +159,11 @@ scm_init_pairs ()
|
|||
{
|
||||
unsigned int subnr = 0;
|
||||
|
||||
for (subnr = 0; cxrs [subnr]; subnr++)
|
||||
scm_c_define_subr (cxrs [subnr], scm_tc7_cxr, NULL);
|
||||
for (subnr = 0; cxrs[subnr].name; subnr++)
|
||||
{
|
||||
SCM (*pattern) () = (SCM (*) ()) (scm_t_bits) cxrs[subnr].pattern;
|
||||
scm_c_define_subr (cxrs[subnr].name, scm_tc7_cxr, pattern);
|
||||
}
|
||||
|
||||
#include "libguile/pairs.x"
|
||||
}
|
||||
|
|
|
@ -52,6 +52,7 @@ scm_i_procedure_arity (SCM proc)
|
|||
case scm_tc7_subr_2o:
|
||||
o = 1;
|
||||
case scm_tc7_subr_1:
|
||||
case scm_tc7_dsubr:
|
||||
case scm_tc7_cxr:
|
||||
a += 1;
|
||||
break;
|
||||
|
|
|
@ -1247,7 +1247,7 @@ ramap (SCM ra0, SCM proc, SCM ras)
|
|||
|
||||
|
||||
static int
|
||||
ramap_cxr (SCM ra0, SCM proc, SCM ras)
|
||||
ramap_dsubr (SCM ra0, SCM proc, SCM ras)
|
||||
{
|
||||
SCM ra1 = SCM_CAR (ras);
|
||||
SCM e1 = SCM_UNDEFINED;
|
||||
|
@ -1514,10 +1514,8 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
|
|||
case scm_tc7_subr_2o:
|
||||
scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
|
||||
return SCM_UNSPECIFIED;
|
||||
case scm_tc7_cxr:
|
||||
if (!SCM_SUBRF (proc))
|
||||
goto gencase;
|
||||
scm_ramapc (ramap_cxr, proc, ra0, lra, FUNC_NAME);
|
||||
case scm_tc7_dsubr:
|
||||
scm_ramapc (ramap_dsubr, proc, ra0, lra, FUNC_NAME);
|
||||
return SCM_UNSPECIFIED;
|
||||
case scm_tc7_rpsubr:
|
||||
{
|
||||
|
|
|
@ -319,7 +319,7 @@ typedef unsigned long scm_t_bits;
|
|||
#define scm_tc7_ivect 79
|
||||
#endif
|
||||
|
||||
/* free 61 */
|
||||
#define scm_tc7_dsubr 61
|
||||
#define scm_tc7_cclo 63
|
||||
#define scm_tc7_rpsubr 69
|
||||
#define scm_tc7_subr_0 85
|
||||
|
@ -497,9 +497,19 @@ SCM_API char *scm_isymnames[]; /* defined in print.c */
|
|||
|
||||
/* For subrs
|
||||
*/
|
||||
#define scm_tcs_subrs scm_tc7_asubr:case scm_tc7_subr_0:case scm_tc7_subr_1: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
|
||||
#define scm_tcs_subrs \
|
||||
scm_tc7_asubr:\
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue