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

* print.c (scm_iprin1): Handle fractions.

Browse source 
* objects.h (scm_class_fraction): New.
* objects.c (scm_class_fraction): New.
(scm_class_of): Handle fractions.

* hash.c (scm_hasher): Handle fractions.

* numbers.c: New code for handling fraction all over the place.
(scm_odd_p, scm_even_p): Handle inexact integers.
(scm_rational_p): New function, same as scm_real_p.
(scm_round_number, scm_truncate_number, scm_ceiling, scm_floor):
New exact functions that replace the inexact 'dsubr'
implementations.
(scm_numerator, scm_denominator): New.

* numbers.h (SCM_NUMP): Recognize fractions.
(SCM_FRACTIONP, SCM_SLOPPY_FRACTIONP, SCM_FRACTION_NUMERATOR,
SCM_FRACTION_DENOMINATOR, SCM_FRACTION_SET_NUMERATOR,
SCM_FRACTION_SET_DENOMINATOR, SCM_FRACTION_REDUCED_BIT,
SCM_FRACTION_REDUCED_SET, SCM_FRACTION_REDUCED_CLEAR,
SCM_FRACTION_REDUCED): New.
(scm_floor, scm_ceiling, scm_truncate_number, scm_round_number):
New prototypes.
(scm_make_ratio, scm_rationalize, scm_numerator, scm_denominator,
scm_rational_p): New prototypes.
(scm_i_dbl2num, scm_i_fraction2double, scm_i_fraction_equalp,
scm_i_print_fraction): New prototypes.

* goops.c (create_standard_classes): Create "<fraction>" class.

* gc-mark.c (scm_gc_mark_dependencies): Handle fractions.

* gc-card.c (scm_i_sweep_card): Include scm_tc16_fraction as a
case in the switch, but do nothing for now.

* eval.c (SCM_CEVAL, SCM_APPLY, call_dsubr_1): Convert fractions
to doubles when calling 'dsubr' functions.

* eq.c (scm_eqv_p, scm_equal_p): Handle fractions.
This commit is contained in:
Marius Vollmer 2003-11-18 19:59:53 +00:00
parent 9dd9857f77
commit f92e85f735
11 changed files with 993 additions and 90 deletions
Download patch file Download diff file Expand all files Collapse all files

35
libguile/eq.c
View file

@ -61,6 +61,7 @@ real_eqv (double x, double y)
return !memcmp (&x, &y, sizeof(double));
}
#include <stdio.h>
SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
(SCM x, SCM y),
"The @code{eqv?} procedure defines a useful equivalence relation on objects.\n"
@ -77,8 +78,14 @@ SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
if (SCM_IMP (y))
return SCM_BOOL_F;
/* this ensures that types and scm_length are the same. */
if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
{
/* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer),
but this checks the entire type word, so fractions may be accidentally
flagged here as unequal. Perhaps I should use the 4th double_cell word?
*/
/* treat mixes of real and complex types specially */
if (SCM_INEXACTP (x))
{
@ -93,6 +100,9 @@ SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
SCM_REAL_VALUE (y))
&& SCM_COMPLEX_IMAG (x) == 0.0);
}
if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y))
return scm_i_fraction_equalp (x, y);
return SCM_BOOL_F;
}
if (SCM_NUMP (x))
@ -101,6 +111,8 @@ SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
return SCM_BOOL (scm_i_bigcmp (x, y) == 0);
} else if (SCM_REALP (x)) {
return SCM_BOOL (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y)));
} else if (SCM_FRACTIONP (x)) {
return scm_i_fraction_equalp (x, y);
} else { /* complex */
return SCM_BOOL (real_eqv (SCM_COMPLEX_REAL (x),
SCM_COMPLEX_REAL (y))
@ -149,7 +161,7 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
{
/* treat mixes of real and complex types specially */
if (SCM_INEXACTP (x))
if (SCM_INEXACTP (x) && SCM_INEXACTP (y))
{
if (SCM_REALP (x))
return SCM_BOOL (SCM_COMPLEXP (y)
@ -160,6 +172,25 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
&& SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)
&& SCM_COMPLEX_IMAG (x) == 0.0);
}
/* should we handle fractions here also? */
else if ((SCM_FRACTIONP (x)) && (SCM_INEXACTP (y)))
{
if (SCM_REALP (y))
return SCM_BOOL (scm_i_fraction2double (x) == SCM_REAL_VALUE (y));
else
return SCM_BOOL (SCM_COMPLEX_REAL (y) == scm_i_fraction2double (x)
&& SCM_COMPLEX_IMAG (y) == 0.0);
}
else if ((SCM_FRACTIONP (y)) && (SCM_INEXACTP (x)))
{
if (SCM_REALP (x))
return SCM_BOOL (scm_i_fraction2double (y) == SCM_REAL_VALUE (x));
else
return SCM_BOOL (SCM_COMPLEX_REAL (x) == scm_i_fraction2double (y)
&& SCM_COMPLEX_IMAG (x) == 0.0);
}
return SCM_BOOL_F;
}
switch (SCM_TYP7 (x))
@ -175,6 +206,8 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
return scm_real_equalp (x, y);
case scm_tc16_complex:
return scm_complex_equalp (x, y);
case scm_tc16_fraction:
return scm_i_fraction_equalp (x, y);
}
case scm_tc7_vector:
case scm_tc7_wvect:

22
libguile/eval.c
View file

@ -3856,7 +3856,11 @@ evapply: /* inputs: x, proc */
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
else if (SCM_FRACTIONP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
case scm_tc7_cxr:
{
@ -4536,7 +4540,13 @@ tail:
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))));
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
}
else if (SCM_FRACTIONP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
case scm_tc7_cxr:
@ -4882,7 +4892,13 @@ call_dsubr_1 (SCM proc, SCM 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))));
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
}
else if (SCM_FRACTIONP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
}

4
libguile/gc-card.c
View file

@ -186,6 +186,10 @@ scm_i_sweep_card (scm_t_cell * p, SCM *free_list, scm_t_heap_segment*seg)
scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex),
"complex");
break;
case scm_tc16_fraction:
/* nothing to do here since the num/denum of a fraction
are proper SCM objects themselves. */
break;
}
break;
case scm_tc7_string:

6
libguile/gc-mark.c
View file

@ -281,6 +281,12 @@ scm_gc_mark_dependencies (SCM p)
break;
case scm_tc7_number:
if (SCM_TYP16 (ptr) == scm_tc16_fraction)
{
scm_gc_mark (SCM_CELL_OBJECT_1 (ptr));
ptr = SCM_CELL_OBJECT_2 (ptr);
goto gc_mark_loop;
}
break;
case scm_tc7_wvect:

2
libguile/goops.c
View file

@ -2406,6 +2406,8 @@ create_standard_classes (void)
scm_class_class, scm_class_complex, SCM_EOL);
make_stdcls (&scm_class_integer, "<integer>",
scm_class_class, scm_class_real, SCM_EOL);
make_stdcls (&scm_class_fraction, "<fraction>",
scm_class_class, scm_class_real, SCM_EOL);
make_stdcls (&scm_class_keyword, "<keyword>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_unknown, "<unknown>",

1
libguile/hash.c
View file

@ -103,6 +103,7 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
}
/* Fall through */
case scm_tc16_complex:
case scm_tc16_fraction:
obj = scm_number_to_string (obj, SCM_MAKINUM (10));
/* Fall through */
}

971
libguile/numbers.c
View file

File diff suppressed because it is too large Load diff

34
libguile/numbers.h
View file

@ -131,6 +131,7 @@
#define scm_tc16_big (scm_tc7_number + 1 * 256L)
#define scm_tc16_real (scm_tc7_number + 2 * 256L)
#define scm_tc16_complex (scm_tc7_number + 3 * 256L)
#define scm_tc16_fraction (scm_tc7_number + 4 * 256L)
#define SCM_INEXACTP(x) \
(!SCM_IMP (x) && (0xfeff & SCM_CELL_TYPE (x)) == scm_tc16_real)
@ -148,7 +149,21 @@
#define SCM_NUMBERP(x) (SCM_INUMP(x) || SCM_NUMP(x))
#define SCM_NUMP(x) (!SCM_IMP(x) \
&& (0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number)
&& (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) \
|| ((0xfbff & SCM_CELL_TYPE (x)) == scm_tc7_number)))
/* 0xfcff (#b1100) for 0 free, 1 big, 2 real, 3 complex, then 0xfbff (#b1011) for 4 fraction */
#define SCM_FRACTIONP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_fraction)
#define SCM_SLOPPY_FRACTIONP(x) (SCM_TYP16 (x) == scm_tc16_fraction)
#define SCM_FRACTION_NUMERATOR(x) ((SCM) (SCM_CELL_WORD_1 (x)))
#define SCM_FRACTION_DENOMINATOR(x) ((SCM) (SCM_CELL_WORD_2 (x)))
#define SCM_FRACTION_SET_NUMERATOR(x, v) ((SCM) (SCM_SET_CELL_WORD_1 ((x), (v))))
#define SCM_FRACTION_SET_DENOMINATOR(x, v) ((SCM) (SCM_SET_CELL_WORD_2 ((x), (v))))
/* I think the left half word is free in the type, so I'll use bit 17 */
#define SCM_FRACTION_REDUCED_BIT 0x10000
#define SCM_FRACTION_REDUCED_SET(x) (SCM_SET_CELL_TYPE((x), (SCM_CELL_TYPE (x) | SCM_FRACTION_REDUCED_BIT)))
#define SCM_FRACTION_REDUCED_CLEAR(x) (SCM_SET_CELL_TYPE((x), (SCM_CELL_TYPE (x) & ~SCM_FRACTION_REDUCED_BIT)))
#define SCM_FRACTION_REDUCED(x) (0x10000 & SCM_CELL_TYPE (x))
@ -223,11 +238,15 @@ SCM_API SCM scm_difference (SCM x, SCM y);
SCM_API SCM scm_product (SCM x, SCM y);
SCM_API double scm_num2dbl (SCM a, const char * why);
SCM_API SCM scm_divide (SCM x, SCM y);
SCM_API SCM scm_floor (SCM x);
SCM_API SCM scm_ceiling (SCM x);
SCM_API double scm_asinh (double x);
SCM_API double scm_acosh (double x);
SCM_API double scm_atanh (double x);
SCM_API double scm_truncate (double x);
SCM_API double scm_round (double x);
SCM_API SCM scm_truncate_number (SCM x);
SCM_API SCM scm_round_number (SCM x);
SCM_API SCM scm_sys_expt (SCM z1, SCM z2);
SCM_API SCM scm_sys_atan2 (SCM z1, SCM z2);
SCM_API SCM scm_make_rectangular (SCM z1, SCM z2);
@ -286,6 +305,7 @@ SCM_API SCM scm_i_mkbig (void);
SCM_API SCM scm_i_normbig (SCM x);
SCM_API int scm_i_bigcmp (SCM a, SCM b);
SCM_API SCM scm_i_dbl2big (double d);
SCM_API SCM scm_i_dbl2num (double d);
SCM_API double scm_i_big2dbl (SCM b);
SCM_API SCM scm_i_short2big (short n);
SCM_API SCM scm_i_ushort2big (unsigned short n);
@ -302,6 +322,18 @@ SCM_API SCM scm_i_ulong_long2big (unsigned long long n);
#endif
/* ratio functions */
SCM_API SCM scm_make_ratio (SCM num, SCM den);
SCM_API SCM scm_rationalize (SCM x, SCM err);
SCM_API SCM scm_numerator (SCM z);
SCM_API SCM scm_denominator (SCM z);
SCM_API SCM scm_rational_p (SCM z);
/* fraction internal functions */
SCM_API double scm_i_fraction2double (SCM z);
SCM_API SCM scm_i_fraction_equalp (SCM x, SCM y);
SCM_API int scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate);
#ifdef GUILE_DEBUG
SCM_API SCM scm_sys_check_number_conversions (void);

4
libguile/objects.c
View file

@ -48,7 +48,7 @@ SCM scm_class_boolean, scm_class_char, scm_class_pair;
SCM scm_class_procedure, scm_class_string, scm_class_symbol;
SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
SCM scm_class_vector, scm_class_null;
SCM scm_class_integer, scm_class_real, scm_class_complex;
SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
SCM scm_class_unknown;
SCM *scm_port_class = 0;
@ -110,6 +110,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return scm_class_real;
case scm_tc16_complex:
return scm_class_complex;
case scm_tc16_fraction:
return scm_class_fraction;
}
case scm_tc7_asubr:
case scm_tc7_subr_0:

1
libguile/objects.h
View file

@ -190,6 +190,7 @@ SCM_API SCM scm_class_vector, scm_class_null;
SCM_API SCM scm_class_real;
SCM_API SCM scm_class_complex;
SCM_API SCM scm_class_integer;
SCM_API SCM scm_class_fraction;
SCM_API SCM scm_class_unknown;
SCM_API SCM *scm_port_class;
SCM_API SCM *scm_smob_class;

3
libguile/print.c
View file

@ -529,6 +529,9 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc16_complex:
scm_print_complex (exp, port, pstate);
break;
case scm_tc16_fraction:
scm_i_print_fraction (exp, port, pstate);
break;
}
break;
case scm_tc7_string: