mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

DRAFT: Add immediate fractions (fixrats).

Browse source
This commit is contained in:
Mark H Weaver 2019-06-05 15:18:40 -04:00
parent 10606b8760
commit f08e08bfac
7 changed files with 112 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

5
libguile/goops.c
View file

@ -206,7 +206,10 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
switch (SCM_ITAG3 (x)) switch (SCM_ITAG3 (x))
{ {
case scm_tcs_fixnums: case scm_tcs_fixnums:
return class_integer; if (SCM_I_INUMP (x))
return class_integer;
else
return class_fraction;
#ifdef scm_tcs_iflo #ifdef scm_tcs_iflo
case scm_tcs_iflo: case scm_tcs_iflo:

20
libguile/numbers.c
View file

@ -464,6 +464,24 @@ scm_i_make_ratio_already_reduced (SCM numerator, SCM denominator)
if (scm_is_eq (denominator, SCM_INUM1)) if (scm_is_eq (denominator, SCM_INUM1))
return numerator; return numerator;
if (SCM_I_INUMP (numerator) && SCM_I_INUMP (denominator)
&& (SCM_I_INUM (denominator) < ((scm_t_inum) 1 << 53))) /* assumes 64-bit XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
{
scm_t_inum nn = SCM_I_INUM (numerator);
int neg = (nn < 0);
scm_t_bits abs_nn = neg ? -nn : nn;
union { double f; uint64_t u; } dd;
int rank;
dd.f = SCM_I_INUM (denominator);
rank = (dd.u >> 52) & 63; /* assumes 64-bit XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
if ((abs_nn >> (52 - rank)) == 0)
return SCM_PACK (scm_fixrat_tag
| (abs_nn << scm_fixrat_tag_size)
| (dd.u << (11 - scm_fixrat_rank_size))
| ((uint64_t) neg << 63));
}
return scm_double_cell (scm_tc16_fraction, return scm_double_cell (scm_tc16_fraction,
SCM_UNPACK (numerator), SCM_UNPACK (numerator),
SCM_UNPACK (denominator), 0); SCM_UNPACK (denominator), 0);
@ -8065,7 +8083,7 @@ scm_product (SCM x, SCM y)
0.0 * SCM_COMPLEX_IMAG (y)); 0.0 * SCM_COMPLEX_IMAG (y));
/* we've already handled inexact numbers, /* we've already handled inexact numbers,
so y must be exact, and we return exact0 */ so y must be exact, and we return exact0 */
else if (SCM_NUMP (y)) else if (SCM_NUMBERP (y))
return SCM_INUM0; return SCM_INUM0;
else else
return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product); return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);

50
libguile/numbers.h
View file

@ -167,13 +167,53 @@ typedef long scm_t_inum;
#define SCM_I_BIG_MPZ(x) (*((mpz_t *) (SCM_CELL_OBJECT_LOC((x),1)))) #define SCM_I_BIG_MPZ(x) (*((mpz_t *) (SCM_CELL_OBJECT_LOC((x),1))))
#define SCM_BIGP(x) (SCM_HAS_TYP16 (x, scm_tc16_big)) #define SCM_BIGP(x) (SCM_HAS_TYP16 (x, scm_tc16_big))
#define SCM_NUMBERP(x) \ #define SCM_I_FIXRAT_P(x) \
(SCM_IMP (x) ? SCM_I_INUMP(x) || SCM_I_IFLO_P (x) : SCM_NUMP(x)) ((SCM_UNPACK (x) & scm_fixrat_tag_mask) == scm_fixrat_tag)
#define SCM_I_FIXRAT_RANK(x) \
((SCM_UNPACK (x) >> (SCM_SIZEOF_UINTPTR_T * 8 \
- 1 - scm_fixrat_rank_size)) \
& ~((scm_t_bits) -1 << scm_fixrat_rank_size))
/* XXX Assumes that any fixrat numerator is an inum, and that doubles
are in IEEE-754 binary-64 format. Verify this. */
/* XXX Assumes 64-bit word size. */
#define SCM_I_FIXRAT_DENOMINATOR(x) \
((scm_t_inum) \
((const union { double f; uint64_t u; }) \
{ .u = (((SCM_UNPACK (x) >> 5) \
& 0x3ffffffffffffff) \
| 0x4000000000000000) } .f))
#define SCM_I_FIXRAT_NUMERATOR(x) \
((SCM_UNPACK (x) >> 63) \
? -(scm_t_inum) ((SCM_UNPACK (x) \
& ((scm_t_bits) -1 \
>> (scm_fixrat_rank_size + 2 \
+ SCM_I_FIXRAT_RANK(x)))) \
>> scm_fixrat_tag_size) \
: (scm_t_inum) ((SCM_UNPACK (x) \
& ((scm_t_bits) -1 \
>> (scm_fixrat_rank_size + 2 \
+ SCM_I_FIXRAT_RANK(x)))) \
>> scm_fixrat_tag_size))
#define SCM_NUMBERP(x) \
(SCM_IMP (x) \
? SCM_I_INUMP(x) || SCM_I_IFLO_P (x) || SCM_I_FIXRAT_P(x) \
: SCM_NUMP(x))
#define SCM_NUMP(x) (SCM_HAS_TYP11 (x, scm_tc11_number)) #define SCM_NUMP(x) (SCM_HAS_TYP11 (x, scm_tc11_number))
#define SCM_FRACTIONP(x) (SCM_HAS_TYP16 (x, scm_tc16_fraction)) #define SCM_FRACTIONP(x) \
#define SCM_FRACTION_NUMERATOR(x) (SCM_CELL_OBJECT_1 (x)) (SCM_IMP (x) \
#define SCM_FRACTION_DENOMINATOR(x) (SCM_CELL_OBJECT_2 (x)) ? SCM_I_FIXRAT_P (x) \
: SCM_HAS_TYP16 (x, scm_tc16_fraction))
#define SCM_FRACTION_NUMERATOR(x) \
(SCM_IMP (x) \
? SCM_I_MAKINUM (SCM_I_FIXRAT_NUMERATOR (x)) \
: SCM_CELL_OBJECT_1 (x))
#define SCM_FRACTION_DENOMINATOR(x) \
(SCM_IMP (x) \
? SCM_I_MAKINUM (SCM_I_FIXRAT_DENOMINATOR (x)) \
: SCM_CELL_OBJECT_2 (x))

5
libguile/print.c
View file

@ -594,7 +594,10 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
switch (SCM_ITAG3 (exp)) switch (SCM_ITAG3 (exp))
{ {
case scm_tcs_fixnums: case scm_tcs_fixnums:
scm_intprint (SCM_I_INUM (exp), 10, port); if (SCM_I_INUMP (exp))
scm_intprint (SCM_I_INUM (exp), 10, port);
else
scm_i_print_fraction (exp, port, pstate);
break; break;
#ifdef scm_tcs_iflo #ifdef scm_tcs_iflo
case scm_tcs_iflo: case scm_tcs_iflo:

5
libguile/scm.h
View file

@ -440,6 +440,11 @@ typedef uintptr_t scm_t_bits;
#define scm_fixnum_tag_mask 15 #define scm_fixnum_tag_mask 15
#define scm_fixnum_tag_size 4 #define scm_fixnum_tag_size 4
#define scm_fixrat_tag 7
#define scm_fixrat_tag_mask 15
#define scm_fixrat_tag_size 4
#define scm_fixrat_rank_size 6
/* Definitions for tc3: */ /* Definitions for tc3: */

40
module/system/vm/assembler.scm
View file

@ -1133,12 +1133,40 @@ immediate, and @code{#f} otherwise."
(+ fixint-max 1 (logand x fixint-max)) (+ fixint-max 1 (logand x fixint-max))
x))) x)))
(logior (ash fixint-bits fixint-shift) fixint-tag)))))) (logior (ash fixint-bits fixint-shift) fixint-tag))))))
((and (number? x) (inexact? x) (real? x)) ((and (number? x) (real? x))
(case (asm-word-size asm) (cond ((inexact? x)
;; TAGS-SENSITIVE (case (asm-word-size asm)
((4) #f) ;; TAGS-SENSITIVE
((8) (pack-iflo x)) ((4) #f)
(else (error "unexpected word size")))) ((8) (pack-iflo x))
(else (error "unexpected word size"))))
((rational? x)
(call-with-values (lambda ()
(case (asm-word-size asm)
;; TAGS-SENSITIVE
((4) (values 2 2 5 25))
((8) (values 7 4 6 54))
(else (error "unexpected word size"))))
(lambda (fixrat-tag tag-bits rank-bits data-bits)
(let ((numer (numerator x))
(denom (denominator x)))
(let* ((sign-bit (if (negative? numer) 1 0))
(numer^ (abs numer))
(numer-len (integer-length numer^))
(denom-len (integer-length denom))
(rank (- denom-len 2))
(denom^ (- denom (ash 1 (+ rank 1)))))
(and (>= data-bits (+ numer-len denom-len))
(logior fixrat-tag
(ash (logior numer^
(ash (logior denom^
(ash (logior rank
(ash sign-bit
rank-bits))
(+ rank 1)))
(- data-bits denom-len)))
tag-bits))))))))
(else #f)))
(else (else
;; Otherwise, the object will be immediate on the target if and ;; Otherwise, the object will be immediate on the target if and
;; only if it is immediate on the host. Except for integers, ;; only if it is immediate on the host. Except for integers,

2
test-suite/tests/srcprop.test
View file

@ -45,7 +45,7 @@
(pass-if "null string" (reads-with-srcprops? "\"\"")) (pass-if "null string" (reads-with-srcprops? "\"\""))
(pass-if "floats" (reads-with-srcprops? "3.1415e200")) (pass-if "floats" (reads-with-srcprops? "3.1415e200"))
(pass-if "fractions" (reads-with-srcprops? "1/2")) (pass-if "fractions" (reads-with-srcprops? "1/111111111111111111111111111111111111"))
(pass-if "complex numbers" (reads-with-srcprops? "1+1i")) (pass-if "complex numbers" (reads-with-srcprops? "1+1i"))
(pass-if "bignums" (pass-if "bignums"
(and (reads-with-srcprops? (number->string (1+ most-positive-fixnum))) (and (reads-with-srcprops? (number->string (1+ most-positive-fixnum)))