diff --git a/libguile/goops.c b/libguile/goops.c index eb71130aa..b3d4b0126 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -206,7 +206,10 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, switch (SCM_ITAG3 (x)) { case scm_tcs_fixnums: - return class_integer; + if (SCM_I_INUMP (x)) + return class_integer; + else + return class_fraction; #ifdef scm_tcs_iflo case scm_tcs_iflo: diff --git a/libguile/numbers.c b/libguile/numbers.c index 9f9facef0..853a9853d 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -464,6 +464,24 @@ scm_i_make_ratio_already_reduced (SCM numerator, SCM denominator) if (scm_is_eq (denominator, SCM_INUM1)) 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, SCM_UNPACK (numerator), SCM_UNPACK (denominator), 0); @@ -8065,7 +8083,7 @@ scm_product (SCM x, SCM y) 0.0 * SCM_COMPLEX_IMAG (y)); /* we've already handled inexact numbers, so y must be exact, and we return exact0 */ - else if (SCM_NUMP (y)) + else if (SCM_NUMBERP (y)) return SCM_INUM0; else return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product); diff --git a/libguile/numbers.h b/libguile/numbers.h index 0d9253af1..2dca854c6 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -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_BIGP(x) (SCM_HAS_TYP16 (x, scm_tc16_big)) -#define SCM_NUMBERP(x) \ - (SCM_IMP (x) ? SCM_I_INUMP(x) || SCM_I_IFLO_P (x) : SCM_NUMP(x)) +#define SCM_I_FIXRAT_P(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_FRACTIONP(x) (SCM_HAS_TYP16 (x, scm_tc16_fraction)) -#define SCM_FRACTION_NUMERATOR(x) (SCM_CELL_OBJECT_1 (x)) -#define SCM_FRACTION_DENOMINATOR(x) (SCM_CELL_OBJECT_2 (x)) +#define SCM_FRACTIONP(x) \ + (SCM_IMP (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)) diff --git a/libguile/print.c b/libguile/print.c index 7e050989d..0e9a1a38d 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -594,7 +594,10 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) switch (SCM_ITAG3 (exp)) { 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; #ifdef scm_tcs_iflo case scm_tcs_iflo: diff --git a/libguile/scm.h b/libguile/scm.h index 6b229dde6..b73fd1abe 100644 --- a/libguile/scm.h +++ b/libguile/scm.h @@ -440,6 +440,11 @@ typedef uintptr_t scm_t_bits; #define scm_fixnum_tag_mask 15 #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: */ diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index c23a665b4..7aa7bd5ac 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1133,12 +1133,40 @@ immediate, and @code{#f} otherwise." (+ fixint-max 1 (logand x fixint-max)) x))) (logior (ash fixint-bits fixint-shift) fixint-tag)))))) - ((and (number? x) (inexact? x) (real? x)) - (case (asm-word-size asm) - ;; TAGS-SENSITIVE - ((4) #f) - ((8) (pack-iflo x)) - (else (error "unexpected word size")))) + ((and (number? x) (real? x)) + (cond ((inexact? x) + (case (asm-word-size asm) + ;; TAGS-SENSITIVE + ((4) #f) + ((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 ;; Otherwise, the object will be immediate on the target if and ;; only if it is immediate on the host. Except for integers, diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test index a14cd1e44..b22d7a692 100644 --- a/test-suite/tests/srcprop.test +++ b/test-suite/tests/srcprop.test @@ -45,7 +45,7 @@ (pass-if "null string" (reads-with-srcprops? "\"\"")) (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 "bignums" (and (reads-with-srcprops? (number->string (1+ most-positive-fixnum)))