1
Fork 0
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:
Dirk Herrmann 2003-06-01 13:58:42 +00:00
parent e757438dc9
commit 14b18ed6f5
8 changed files with 174 additions and 128 deletions

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>
* eval.c (SCM_CEVAL, SCM_APPLY, scm_trampoline_0,

View file

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

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
* 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}."
*/

View file

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

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",
"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"
}

View file

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

View file

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

View file

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