~ chicken-core (chicken-5) 1ee218f1a208936dacb4e0dbce0cca79f5e58869
commit 1ee218f1a208936dacb4e0dbce0cca79f5e58869
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Thu Jan 22 22:01:20 2015 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:07:33 2015 +0200
Add basic low-level plumbing for extended numeric types.
This includes the following:
- New header type tag for bignums:
- Bignums are bytevectors for simplicity of GC, but we access C_uword slots
- Data field stores n+1 uwords, where n is the number of digits or limbs
- At slot index 0, we store 0 if the bignum is positive, 1 if it is negative
- At slot index n+1, we store digit n, as an unsigned word
- Some basic C-level support for inspecting bignum internals:
- C_bignum_size(x) to get the number of limbs (digits) in a bignum
- C_SIZEOF_BIGNUM(n) to calculate size requirements for bignum of n limbs
- C_SIZEOF_FIX_BIGNUM for size of upgraded fixnum to unnormalized bignum
- C_bignum_negativep(b) to check if a bignum is negative (first slot)
- C_bignum_digits(b) to get a pointer to the first digit
- C_bignum_mutate_size(b,s) to do a hard reset of the internal bignum size
- Some basic bignum construction functions and macros:
- C_allocate_bignum to dynamically allocate on stack or heap in CPS context
- {allocate,free}_tmp_bignum to allocate with malloc (internal use only!)
- Inlineable allocators C_bignumX for when size is known in advance to be X
- C_a_u_i_fix_to_big for promoting fixnum to (unnormalized!) bignum
- C_bignum_simplify to normalize them again (demote to fixnum if it fits)
- Some other support macros, like signed & unsigned C halfword types etc
- Complex numbers are stored as structures, with type tag ##sys#cplxnum
- Rational numbers are stored as structures, with type tag ##sys#ratnum
- Type tags are kept around in exported C globals, and tracked by GC
- New scrutinizer types "bignum", "cplxnum" and "ratnum"
- New scrutinizer class "integer", for exact integral numbers (or fixnum bignum)
- Scrutinizer class "number" is upgraded to include bignum, cplxnum and ratnum.
- Add "exact type" predicates so you can detect bignums, cplxnums and ratnums.
diff --git a/c-platform.scm b/c-platform.scm
index 5b72e432..31c0f200 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -140,8 +140,8 @@
current-input-port current-output-port) )
(set! default-extended-bindings
- '(bitwise-and bitwise-ior bitwise-xor bitwise-not add1 sub1 o
- fx+ fx- fx* fx/ fx+? fx-? fx*? fx/? fxmod fp/?
+ '(bignum? cplxnum? ratnum? bitwise-and bitwise-ior bitwise-xor bitwise-not
+ add1 sub1 fx+ fx- fx* fx/ fx+? fx-? fx*? fx/? fxmod o fp/?
fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity fp+ fp- fp* fp/ fpmin fpmax fpneg
fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set? fxodd? fxeven?
fpfloor fpceiling fptruncate fpround fpsin fpcos fptan fpasin fpacos fpatan
@@ -578,6 +578,7 @@
(rewrite 'integer? 2 1 "C_i_integerp" #t)
(rewrite 'flonum? 2 1 "C_i_flonump" #t)
(rewrite 'fixnum? 2 1 "C_fixnump" #t)
+(rewrite 'bignum? 2 1 "C_i_bignump" #t)
(rewrite 'finite? 2 1 "C_i_finitep" #f)
(rewrite 'fpinteger? 2 1 "C_u_i_fpintegerp" #f)
(rewrite '##sys#pointer? 2 1 "C_anypointerp" #t)
diff --git a/chicken.h b/chicken.h
index 69e0b952..2b6e274c 100644
--- a/chicken.h
+++ b/chicken.h
@@ -411,11 +411,22 @@ static inline int isinf_ld (long double x)
#ifdef C_SIXTY_FOUR
# define C_MOST_POSITIVE_FIXNUM 0x3fffffffffffffffL
# define C_WORD_SIZE 64
+# define C_HALF_WORD_SIZE 32
#else
# define C_MOST_POSITIVE_FIXNUM 0x3fffffff
# define C_WORD_SIZE 32
+# define C_HALF_WORD_SIZE 16
#endif
+/* These might fit better in runtime.c? */
+#define C_BIGNUM_DIGIT_LENGTH C_WORD_SIZE
+#define C_BIGNUM_HALF_DIGIT_LENGTH C_HALF_WORD_SIZE
+#define C_BIGNUM_BITS_TO_DIGITS(n) \
+ (((n) + (C_BIGNUM_DIGIT_LENGTH - 1)) / C_BIGNUM_DIGIT_LENGTH)
+#define C_BIGNUM_DIGIT_LO_HALF(d) (C_uhword)(d)
+#define C_BIGNUM_DIGIT_HI_HALF(d) (C_uhword)((d) >> C_BIGNUM_HALF_DIGIT_LENGTH)
+#define C_BIGNUM_DIGIT_COMBINE(h,l) ((C_uword)(h) << C_BIGNUM_HALF_DIGIT_LENGTH|(C_uhword)(l))
+
#define C_MOST_POSITIVE_32_BIT_FIXNUM 0x3fffffff
#define C_MOST_NEGATIVE_FIXNUM (-C_MOST_POSITIVE_FIXNUM - 1)
@@ -435,7 +446,7 @@ static inline int isinf_ld (long double x)
# define C_PAIR_TYPE (0x0300000000000000L)
# define C_CLOSURE_TYPE (0x0400000000000000L | C_SPECIALBLOCK_BIT)
# define C_FLONUM_TYPE (0x0500000000000000L | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
-/* unused (0x0600000000000000L ...) */
+# define C_BIGNUM_TYPE (0x0600000000000000L | C_BYTEBLOCK_BIT)
# define C_PORT_TYPE (0x0700000000000000L | C_SPECIALBLOCK_BIT)
# define C_STRUCTURE_TYPE (0x0800000000000000L)
# define C_POINTER_TYPE (0x0900000000000000L | C_SPECIALBLOCK_BIT)
@@ -465,7 +476,7 @@ static inline int isinf_ld (long double x)
# else
# define C_FLONUM_TYPE (0x05000000 | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
# endif
-/* unused (0x06000000 ...) */
+# define C_BIGNUM_TYPE (0x06000000 | C_BYTEBLOCK_BIT)
# define C_PORT_TYPE (0x07000000 | C_SPECIALBLOCK_BIT)
# define C_STRUCTURE_TYPE (0x08000000)
# define C_POINTER_TYPE (0x09000000 | C_SPECIALBLOCK_BIT)
@@ -498,6 +509,9 @@ static inline int isinf_ld (long double x)
#define C_SIZEOF_PORT 16
#define C_SIZEOF_STRUCTURE(n) ((n)+1)
#define C_SIZEOF_CLOSURE(n) ((n)+1)
+#define C_SIZEOF_BIGNUM(n) ((n)+2)
+/* This is for convenience and allows flexibility in representation */
+#define C_SIZEOF_FIX_BIGNUM C_SIZEOF_BIGNUM(1)
/* Fixed size types have pre-computed header tags */
#define C_PAIR_TAG (C_PAIR_TYPE | (C_SIZEOF_PAIR - 1))
@@ -531,13 +545,16 @@ static inline int isinf_ld (long double x)
#ifdef C_SIXTY_FOUR
# ifdef C_LLP
# define C_word C_s64
+# define C_hword long
# else
# define C_word long
+# define C_hword int
# endif
# define C_u32 uint32_t
# define C_s32 int32_t
#else
# define C_word int
+# define C_hword short
# define C_u32 unsigned int
# define C_s32 int
#endif
@@ -546,6 +563,7 @@ static inline int isinf_ld (long double x)
#define C_uchar unsigned C_char
#define C_byte char
#define C_uword unsigned C_word
+#define C_uhword unsigned C_hword
#define C_header C_uword
/* if all else fails, use these:
@@ -1067,6 +1085,7 @@ extern double trunc(double);
#define C_set_block_item(x,i,y) (C_block_item(x, i) = (y))
#define C_header_bits(bh) (C_block_header(bh) & C_HEADER_BITS_MASK)
#define C_header_size(bh) (C_block_header(bh) & C_HEADER_SIZE_MASK)
+#define C_bignum_size(b) (C_bytestowords(C_header_size(b))-1)
#define C_make_header(type, size) ((C_header)(((type) & C_HEADER_BITS_MASK) | ((size) & C_HEADER_SIZE_MASK)))
#define C_symbol_value(x) (C_block_item(x, 0))
#define C_save(x) (*(--C_temporary_stack) = (C_word)(x))
@@ -1108,6 +1127,9 @@ extern double trunc(double);
#define C_mk_nbool(x) ((x) ? C_SCHEME_FALSE : C_SCHEME_TRUE)
#define C_port_file(p) C_CHECKp(p,C_portp(C_VAL1(p)),(C_FILEPTR)C_block_item(C_VAL1(p), 0))
#define C_data_pointer(b) C_CHECKp(b,C_blockp((C_word)C_VAL1(b)),(void *)(((C_SCHEME_BLOCK *)(C_VAL1(b)))->data))
+#define C_bignum_negativep(b) C_CHECKp(b,C_bignump(C_VAL1(b)),(C_block_item(b,0)!=0))
+#define C_bignum_digits(b) C_CHECKp(b,C_bignump(C_VAL1(b)),(((C_uword *)C_data_pointer(C_VAL1(b)))+1))
+#define C_bignum_mutate_size(b,s) (C_block_header(b) = (C_BIGNUM_TYPE | C_wordstobytes((s)+1)))
#define C_fitsinfixnump(n) (((n) & C_INT_SIGN_BIT) == (((n) & C_INT_TOP_BIT) << 1))
#define C_ufitsinfixnump(n) (((n) & (C_INT_SIGN_BIT | (C_INT_SIGN_BIT >> 1))) == 0)
#define C_quickflonumtruncate(n) (C_fix((C_word)C_flonum_magnitude(n)))
@@ -1176,6 +1198,7 @@ extern double trunc(double);
#define C_forwardedp(x) C_mk_bool((C_block_header(x) & C_GC_FORWARDING_BIT) != 0)
#define C_immp(x) C_mk_bool(C_immediatep(x))
#define C_flonump(x) C_mk_bool(C_block_header(x) == C_FLONUM_TAG)
+#define C_bignump(x) C_mk_bool(C_header_bits(x) == C_BIGNUM_TYPE)
#define C_stringp(x) C_mk_bool(C_header_bits(x) == C_STRING_TYPE)
#define C_symbolp(x) C_mk_bool(C_block_header(x) == C_SYMBOL_TAG)
#define C_pairp(x) C_mk_bool(C_block_header(x) == C_PAIR_TAG)
@@ -1290,6 +1313,7 @@ extern double trunc(double);
#define C_random_fixnum(n) C_fix((C_word)(((double)rand())/(RAND_MAX + 1.0) * C_unfix(n)))
#define C_randomize(n) (srand(C_unfix(n)), C_SCHEME_UNDEFINED)
#define C_block_size(x) C_fix(C_header_size(x))
+#define C_u_i_bignum_size(b) C_fix(C_bignum_size(b))
#define C_pointer_address(x) ((C_byte *)C_block_item((x), 0))
#define C_block_address(ptr, n, x) C_a_unsigned_int_to_num(ptr, n, x)
#define C_offset_pointer(x, y) (C_pointer_address(x) + (y))
@@ -1653,7 +1677,9 @@ C_varextern C_TLS C_word
*C_temporary_stack,
*C_temporary_stack_bottom,
*C_temporary_stack_limit,
- *C_stack_limit;
+ *C_stack_limit,
+ C_ratnum_type_tag,
+ C_cplxnum_type_tag;
C_varextern C_TLS C_long
C_timer_interrupt_counter,
C_initial_timer_interrupt_period;
@@ -1844,10 +1870,9 @@ C_fctexport void C_ccall C_expt(C_word c, C_word closure, C_word k, C_word n1, C
C_fctexport void C_ccall C_gc(C_word c, C_word closure, C_word k, ...) C_noret;
C_fctexport void C_ccall C_open_file_port(C_word c, C_word closure, C_word k, C_word port, C_word channel, C_word mode) C_noret;
C_fctexport void C_ccall C_allocate_vector(C_word c, C_word closure, C_word k, C_word size, C_word type, C_word init, C_word align8) C_noret;
+C_fctexport void C_ccall C_allocate_bignum(C_word c, C_word self, C_word k, C_word size, C_word negp, C_word initp) C_noret;
C_fctexport void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
C_fctexport void C_ccall C_build_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
-C_fctexport void C_ccall C_flonum_fraction(C_word c, C_word closure, C_word k, C_word n) C_noret;
-C_fctexport void C_ccall C_flonum_rat(C_word c, C_word closure, C_word k, C_word n) C_noret;
C_fctexport void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2) C_noret;
C_fctexport void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num, ...) C_noret;
C_fctexport void C_ccall C_fixnum_to_string(C_word c, C_word closure, C_word k, C_word num) C_noret;
@@ -1879,6 +1904,7 @@ C_fctexport void C_ccall C_dump_heap_state(C_word x, C_word closure, C_word k) C
C_fctexport void C_ccall C_filter_heap_objects(C_word x, C_word closure, C_word k, C_word func,
C_word vector, C_word userarg) C_noret;
C_fctexport time_t C_fcall C_seconds(C_long *ms) C_regparm;
+C_fctexport C_word C_fcall C_bignum_simplify(C_word big) C_regparm;
C_fctexport C_word C_a_i_list(C_word **a, int c, ...);
C_fctexport C_word C_a_i_string(C_word **a, int c, ...);
C_fctexport C_word C_a_i_record(C_word **a, int c, ...);
@@ -2344,11 +2370,20 @@ C_inline C_word C_i_closurep(C_word x)
return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_CLOSURE_TYPE);
}
+C_inline C_word C_i_bignump(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_BIGNUM_TYPE);
+}
C_inline C_word C_i_numberp(C_word x)
{
- return C_mk_bool((x & C_FIXNUM_BIT)
- || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG));
+ return C_mk_bool((x & C_FIXNUM_BIT) ||
+ (!C_immediatep(x) &&
+ (C_block_header(x) == C_FLONUM_TAG ||
+ C_header_bits(x) == C_BIGNUM_TYPE ||
+ (C_header_bits(x) == C_STRUCTURE_TYPE &&
+ (C_block_item(x, 0) == C_ratnum_type_tag ||
+ C_block_item(x, 0) == C_cplxnum_type_tag)))));
}
@@ -2899,6 +2934,57 @@ C_inline C_word C_a_i_record8(C_word **ptr, int n, C_word x1, C_word x2, C_word
return (C_word)p0;
}
+/* Silly (this is not normalized) but in some cases needed internally */
+C_inline C_word C_bignum0(C_word **ptr)
+{
+ C_word *p = *ptr, p0 = (C_word)p;
+
+ /* Not using C_a_i_vector4, to make it easier to rewrite later */
+ *(p++) = C_BIGNUM_TYPE | C_wordstobytes(1);
+ *(p++) = 0; /* zero is always positive */
+ *ptr = p;
+
+ return p0;
+}
+
+C_inline C_word C_bignum1(C_word **ptr, int negp, C_uword d1)
+{
+ C_word *p = *ptr, p0 = (C_word)p;
+
+ *(p++) = C_BIGNUM_TYPE | C_wordstobytes(2);
+ *(p++) = negp;
+ *(p++) = d1;
+ *ptr = p;
+
+ return p0;
+}
+
+/* Here d1, d2, ... are low to high (ie, little endian)! */
+C_inline C_word C_bignum2(C_word **ptr, int negp, C_uword d1, C_uword d2)
+{
+ C_word *p = *ptr, p0 = (C_word)p;
+
+ *(p++) = C_BIGNUM_TYPE | C_wordstobytes(3);
+ *(p++) = negp;
+ *(p++) = d1;
+ *(p++) = d2;
+ *ptr = p;
+
+ return p0;
+}
+
+/* TODO: Is this correctly named? Shouldn't it accept an argcount? */
+C_inline C_word C_a_u_i_fix_to_big(C_word **ptr, C_word x)
+{
+ x = C_unfix(x);
+ if (x < 0)
+ return C_bignum1(ptr, 1, -x);
+ else if (x == 0)
+ return C_bignum0(ptr);
+ else
+ return C_bignum1(ptr, 0, x);
+}
+
/* These strl* functions are based on public domain code by C.B. Falconer */
#ifdef HAVE_STRLCPY
# define C_strlcpy strlcpy
diff --git a/chicken.import.scm b/chicken.import.scm
index 6389d8c9..aea7d7f6 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -31,6 +31,7 @@
argc+argv
argv
arithmetic-shift
+ bignum?
bit-set?
bitwise-and
bitwise-ior
@@ -56,6 +57,7 @@
continuation-return
continuation?
copy-read-table
+ cplxnum?
cpu-time
current-error-port
current-exception-handler
@@ -194,6 +196,7 @@
promise?
put!
quit
+ ratnum?
register-feature!
remprop!
rename-file
diff --git a/library.scm b/library.scm
index 5b3dedf3..269e05d9 100644
--- a/library.scm
+++ b/library.scm
@@ -747,6 +747,9 @@ EOF
(define flonum-minimum-decimal-exponent (foreign-value "DBL_MIN_10_EXP" int))
(define (flonum? x) (##core#inline "C_i_flonump" x))
+(define (bignum? x) (##core#inline "C_i_bignump" x))
+(define (ratnum? x) (##sys#structure? x '##sys#ratnum))
+(define (cplxnum? x) (##sys#structure? x '##sys#cplxnum))
(define (finite? x)
(##sys#check-number x 'finite?)
@@ -903,8 +906,6 @@ EOF
(define complex? number?)
(define real? number?)
(define (rational? n) (##core#inline "C_i_rationalp" n))
-(define ##sys#flonum-fraction (##core#primitive "C_flonum_fraction"))
-(define ##sys#fprat (##core#primitive "C_flonum_rat"))
(define (integer? x) (##core#inline "C_i_integerp" x))
(define ##sys#integer? integer?)
(define (exact? x) (##core#inline "C_i_exactp" x))
@@ -932,25 +933,40 @@ EOF
(##sys#check-number n 'imag-part)
0)
-(define (numerator n)
- (##sys#check-number n 'numerator)
+;;; Rationals
+
+(define-inline (%ratnum-numerator c) (##sys#slot c 1))
+(define-inline (%ratnum-denominator c) (##sys#slot c 2))
+(define-inline (%make-ratnum r i) (##sys#make-structure '##sys#ratnum r i))
+
+(define (ratnum m n)
(cond
- ((##core#inline "C_u_i_exactp" n) n)
- ((##core#inline "C_i_finitep" n)
- (receive (num denom) (##sys#fprat n) num))
- (else
- (##sys#signal-hook
- #:type-error 'numerator "bad argument type - not a rational number" n)) ) )
+ ((eq? n 1) m)
+ ((eq? n -1) (- m))
+ ((negative? n) (%make-ratnum (- m) (- n)))
+ (else (%make-ratnum m n))))
+
+(define (numerator n)
+ (cond ((exact-integer? n) n)
+ ((##core#inline "C_i_flonump" n)
+ (cond ((not (finite? n)) (bad-inexact 'numerator n))
+ ((##core#inline "C_u_i_fpintegerp" n) n)
+ (else (exact->inexact (numerator (inexact->exact n))))))
+ ((ratnum? n) (%ratnum-numerator n))
+ (else (##sys#signal-hook
+ #:type-error 'numerator
+ "bad argument type - not a rational number" n))))
(define (denominator n)
- (##sys#check-number n 'denominator)
- (cond
- ((##core#inline "C_u_i_exactp" n) 1)
- ((##core#inline "C_i_finitep" n)
- (receive (num denom) (##sys#fprat n) denom))
- (else
- (##sys#signal-hook
- #:type-error 'denominator "bad argument type - not a rational number" n)) ) )
+ (cond ((exact-integer? n) 1)
+ ((##core#inline "C_i_flonump" n)
+ (cond ((not (finite? n)) (bad-inexact 'denominator n))
+ ((##core#inline "C_u_i_fpintegerp" n) 1.0)
+ (else (exact->inexact (denominator (inexact->exact n))))))
+ ((ratnum? n) (%ratnum-denominator n))
+ (else (##sys#signal-hook
+ #:type-error 'numerator
+ "bad argument type - not a rational number" n))))
(define magnitude abs)
diff --git a/manual/C interface b/manual/C interface
index 8daa0c8b..21ef4c69 100644
--- a/manual/C interface
+++ b/manual/C interface
@@ -207,11 +207,29 @@ Is {{x}} a fixnum object?
Is {{x}} ''not'' a fixnum object?
+===== C_bignump
+
+ [C macro] C_word C_bignump(C_word x)
+
+Is {{x}} a Scheme bignum object? Accepts only non-immediate objects.
+
===== C_i_numberp
[C function] C_word C_i_numberp(C_word x)
-Is {{x}} a number object (fixnum or flonum)?
+Is {{x}} a number object (fixnum, bignum, flonum, ratnum, cplxnum)?
+
+===== C_i_bignump
+
+ [C function] C_word C_i_bignump(C_word x)
+
+Is {{x}} a Scheme bignum object?
+
+===== C_i_flonump
+
+ [C function] C_word C_i_flonump(C_word x)
+
+Is {{x}} a flonum object?
===== C_pointerp
@@ -504,6 +522,18 @@ Returns the size in words needed for allocation of a closure with {{length}} slo
Returns the size in words needed for allocation of a structure (record type) object with {{length}} slots. The structure's type tag also counts as a slot, so always remember to include it when calculating {{length}}.
+===== C_SIZEOF_BIGNUM
+
+ [C macro] int C_SIZEOF_BIGNUM (int length)
+
+Returns the size in words needed for allocation of a bignum object with {{length}} word-sized digits (limbs).
+
+===== C_SIZEOF_FIX_BIGNUM
+
+ [C macro] int C_SIZEOF_FIX_BIGNUM
+
+The size in words needed for allocation of a bignum object which is large enough to store any fixnum (ie, if it were converted to a denormalized bignum, because if a number ''can'' be represented as a fixnum, it ''will'' be).
+
===== C_SIZEOF_INTERNED_SYMBOL
[C macro] int C_SIZEOF_INTERNED_SYMBOL (int length)
@@ -744,6 +774,33 @@ Is {{x}} an inexact number (i.e., not a fixnum)?
Is {{x}} a finite number? This returns false only when {{x}} is a
flonum representing {{-inf}} or {{+inf}}.
+==== Bignums
+
+===== C_bignum_negativep
+
+ [C macro] int C_bignum_negativep(C_word b)
+
+Returns nonzero if the bignum {{b}} is negative, zero if it is not.
+
+===== C_bignum_digits
+
+ [C macro] C_uword *C_bignum_digits(C_word b)
+
+Returns a pointer to the first digit (the least significant one) of the bignum {{b}}.
+
+===== C_bignum_size
+
+ [C macro] C_word C_bignum_size(b)
+
+Returns the number of digits in the bignum {{b}}, as an unboxed C number. If you want a fixnum, use {{C_u_i_bignum_size}}.
+
+===== C_u_i_bignum_size
+
+ [C macro] C_word C_u_i_bignum_size(b)
+
+Returns the number of digits in the bignum {{b}}, as a Scheme fixnum. If you want an unboxed integer, use {{C_bignum_size}}.
+
+
==== Fixnums
Note: Fixnums are immediates, so there is no {{C_fixnum_equalp}}
diff --git a/manual/Data representation b/manual/Data representation
index 129e7058..efc29df7 100644
--- a/manual/Data representation
+++ b/manual/Data representation
@@ -86,6 +86,13 @@ a flat closure representation is used).
64 bit architectures) contain a 64-bit floating-point number, in the
representation used by the host system's C compiler.
+'''bignums''': byte-vector objects with type bits {{C_BIGNUM_TYPE}},
+currently 0110. The first word of the data element contains 0 if the
+number is positive or 1 if it is negative. The remaining data encodes
+the bignum's digits (sometimes called "bigits" or "limbs"), which are
+accessed as machine words. The internal byte representation will be
+stored in the endianness of the host machine.
+
'''ports''': special vector objects with type bits
{{C_PORT_TYPE}}, currently 0111. The first slot contains a pointer to a file-
stream, if this is a file-pointer, or NULL if not. The other slots
diff --git a/manual/Unit library b/manual/Unit library
index 61c81dba..10944eee 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -38,6 +38,37 @@ platforms).
Returns {{#t}} if the bit at the position {{INDEX}} in the integer {{N}} is
set, or {{#f}} otherwise. The rightmost/least-significant bit is bit 0.
+==== bignum?
+
+<procedure>(bignum? X)</procedure>
+
+Returns {{#t}} if {{X}} is a bignum (integer larger than fits in a
+fixnum), or {{#f}} otherwise.
+
+==== cplxnum?
+
+<procedure>(cplxnum? X)</procedure>
+
+Returns {{#t}} if {{X}} is a true complex number (it has an imaginary
+component), or {{#f}} otherwise.
+
+Please note that {{complex?}} will always return {{#t}} for any number
+type supported by CHICKEN, so you can use this predicate if you want
+to know the representational type of a number.
+
+==== ratnum?
+
+<procedure>(ratnum? X)</procedure>
+
+Returns {{#t}} if {{X}} is a true rational number (it is a fraction
+with a denominator that's not 1), or {{#f}} otherwise.
+
+Please note that {{rational?}} will always return {{#t}} for any
+number type supported by CHICKEN except complex numbers and non-finite
+flonums, so you can use this predicate if you want to know the
+representational type of a number.
+
+
==== Arithmetic fixnum operations
<procedure>(fx+ N1 N2)</procedure>
diff --git a/manual/faq b/manual/faq
index 00293da1..024e7944 100644
--- a/manual/faq
+++ b/manual/faq
@@ -512,6 +512,7 @@ The following extended bindings are handled specially:
{{any?}}
{{arithmetic-shift}}
{{atom?}}
+{{bignum?}}
{{bit-set?}}
{{bitwise-and}}
{{bitwise-ior}}
diff --git a/runtime.c b/runtime.c
index 841c5bc4..41748117 100644
--- a/runtime.c
+++ b/runtime.c
@@ -216,6 +216,7 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
#define nmin(x, y) ((x) < (y) ? (x) : (y))
#define percentage(n, p) ((C_long)(((double)(n) * (double)p) / 100))
+#define free_tmp_bignum(b) C_free((void *)(b))
#define is_fptr(x) (((x) & C_GC_FORWARDING_BIT) != 0)
#define ptr_to_fptr(x) ((((x) >> FORWARDING_BIT_SHIFT) & 1) | C_GC_FORWARDING_BIT | ((x) & ~1))
#define fptr_to_ptr(x) (((x) << FORWARDING_BIT_SHIFT) | ((x) & ~(C_GC_FORWARDING_BIT | 1)))
@@ -325,7 +326,9 @@ C_TLS C_word
*C_temporary_stack,
*C_temporary_stack_bottom,
*C_temporary_stack_limit,
- *C_stack_limit;
+ *C_stack_limit,
+ C_ratnum_type_tag,
+ C_cplxnum_type_tag;
C_TLS C_long
C_timer_interrupt_counter,
C_initial_timer_interrupt_period;
@@ -512,6 +515,8 @@ static C_ccall void call_cc_wrapper(C_word c, C_word closure, C_word k, C_word r
static C_ccall void call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...) C_noret;
static void gc_2(void *dummy) C_noret;
static void allocate_vector_2(void *dummy) C_noret;
+static void allocate_bignum_2(void *dummy) C_noret;
+static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp);
static void make_structure_2(void *dummy) C_noret;
static void generic_trampoline(void *dummy) C_noret;
static void handle_interrupt(void *trampoline, void *proc) C_noret;
@@ -784,7 +789,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
{
/* IMPORTANT: hardcoded table size -
this must match the number of C_pte calls + 1 (NULL terminator)! */
- C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 56);
+ C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 54);
int i = 0;
if(pt == NULL)
@@ -819,8 +824,6 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_greater_or_equal_p);
C_pte(C_less_or_equal_p);
C_pte(C_quotient);
- C_pte(C_flonum_fraction);
- C_pte(C_flonum_rat);
C_pte(C_expt);
C_pte(C_number_to_string);
C_pte(C_make_symbol);
@@ -1006,6 +1009,8 @@ void initialize_symbol_table(void)
for(i = 0; i < symbol_table->size; symbol_table->table[ i++ ] = C_SCHEME_END_OF_LIST);
/* Obtain reference to hooks for later: */
+ C_ratnum_type_tag = C_intern2(C_heaptop, C_text("\003sysratnum"));
+ C_cplxnum_type_tag = C_intern2(C_heaptop, C_text("\003syscplxnum"));
interrupt_hook_symbol = C_intern2(C_heaptop, C_text("\003sysinterrupt-hook"));
error_hook_symbol = C_intern2(C_heaptop, C_text("\003syserror-hook"));
callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("\003syscallback-continuation-stack"), C_SCHEME_END_OF_LIST);
@@ -3073,6 +3078,8 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
C_regparm void C_fcall mark_system_globals(void)
{
+ mark(&C_ratnum_type_tag);
+ mark(&C_cplxnum_type_tag);
mark(&interrupt_hook_symbol);
mark(&error_hook_symbol);
mark(&callback_continuation_stack_symbol);
@@ -3411,6 +3418,8 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int double_plus)
C_regparm void C_fcall remark_system_globals(void)
{
+ remark(&C_ratnum_type_tag);
+ remark(&C_cplxnum_type_tag);
remark(&interrupt_hook_symbol);
remark(&error_hook_symbol);
remark(&callback_continuation_stack_symbol);
@@ -7258,6 +7267,115 @@ void allocate_vector_2(void *dummy)
}
+void C_ccall
+C_allocate_bignum(C_word c, C_word self, C_word k, C_word size, C_word negp, C_word initp)
+{
+ C_uword bytes = C_wordstobytes(C_unfix(size) + 1); /* add slot for negp */
+
+ if(bytes > C_HEADER_SIZE_MASK)
+ barf(C_OUT_OF_RANGE_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));
+
+ bytes += sizeof(C_word); /* header slot */
+
+ C_save(k);
+ C_save(negp);
+ C_save(initp);
+ C_save(C_fix(bytes));
+
+ if(!C_demand(C_bytestowords(bytes))) {
+ /* Allocate on heap: */
+ if((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size * 2))
+ C_fromspace_top = C_fromspace_limit; /* trigger major GC */
+
+ C_save(C_SCHEME_TRUE);
+ C_reclaim((void *)allocate_bignum_2, NULL);
+ }
+
+ C_save(C_SCHEME_FALSE);
+ allocate_bignum_2(NULL);
+}
+
+static void allocate_bignum_2(void *dummy)
+{
+ C_word mode = C_restore;
+ C_uword bytes = C_unfix(C_restore);
+ C_word initp = C_restore;
+ C_word negp = C_restore;
+ C_word k = C_restore;
+ C_word *v0, v;
+
+ if(C_truep(mode)) {
+ while((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size)) {
+ if(C_heap_size_is_fixed)
+ panic(C_text("out of memory - cannot allocate bignum (heap resizing disabled)"));
+
+ C_save(k);
+ C_rereclaim2(percentage(heap_size, C_heap_growth) + (C_uword)bytes, 0);
+ k = C_restore;
+ }
+
+ v0 = (C_word *)C_align((C_word)C_fromspace_top);
+ C_fromspace_top += C_align(bytes);
+ }
+ else v0 = C_alloc(C_bytestowords(bytes));
+
+ v = (C_word)v0;
+
+ *(v0++) = C_BIGNUM_TYPE | (bytes-sizeof(C_word)); /* subtract header again */
+
+ *(v0++) = C_truep(negp);
+ if(C_truep(initp)) C_memset(v0, '\0', bytes - sizeof(C_word));
+
+ C_kontinue(k, v);
+}
+
+static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp)
+{
+ C_word *mem = C_malloc(C_wordstobytes(C_SIZEOF_BIGNUM(C_unfix(size)))),
+ bignum = (C_word)mem;
+ if (mem == NULL) abort(); /* TODO: panic */
+
+ C_block_header_init(bignum, C_BIGNUM_TYPE | C_wordstobytes(C_unfix(size)+1));
+ C_set_block_item(bignum, 0, C_truep(negp));
+
+ if (C_truep(initp)) {
+ C_memset(((C_uword *)C_data_pointer(bignum))+1,
+ 0, C_wordstobytes(C_unfix(size)));
+ }
+
+ return bignum;
+}
+
+/* Simplification: scan trailing zeroes, then return a fixnum if the
+ * value fits, or trim the bignum's length. */
+C_regparm C_word C_fcall C_bignum_simplify(C_word big)
+{
+ C_uword *start = C_bignum_digits(big),
+ *last_digit = start + C_bignum_size(big) - 1,
+ *scan = last_digit, tmp;
+ int length;
+
+ while (scan >= start && *scan == 0)
+ scan--;
+ length = scan - start + 1;
+
+ switch(length) {
+ case 0:
+ return C_fix(0);
+ case 1:
+ tmp = *start;
+ if (C_bignum_negativep(big) ?
+ !(tmp & C_INT_SIGN_BIT) && C_fitsinfixnump(-(C_word)tmp) :
+ C_ufitsinfixnump(tmp))
+ return C_bignum_negativep(big) ? C_fix(-(C_word)tmp) : C_fix(tmp);
+ /* FALLTHROUGH */
+ default:
+ if (scan < last_digit) C_bignum_mutate_size(big, length);
+ return big;
+ }
+}
+
+
void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string)
{
int len, key;
@@ -7280,41 +7398,6 @@ void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word strin
}
-void C_ccall C_flonum_fraction(C_word c, C_word closure, C_word k, C_word n)
-{
- double i, fn = C_flonum_magnitude(n);
- C_alloc_flonum;
-
- C_kontinue_flonum(k, modf(fn, &i));
-}
-
-void C_ccall C_flonum_rat(C_word c, C_word closure, C_word k, C_word n)
-{
- double frac, tmp, numer, denom, fn = C_flonum_magnitude(n);
- double ga, gb;
- C_word ab[WORDS_PER_FLONUM * 2], *ap = ab;
- int i = 0;
-
- if (isnormal(fn)) {
- /* Calculate bit-length of the fractional part (ie, after decimal point) */
- frac = fn;
- while(!C_isnan(frac) && !C_isinf(frac) && C_modf(frac, &tmp) != 0.0) {
- frac *= 2;
- if (i++ > 3000) /* should this be flonum-maximum-exponent? */
- barf(C_CANT_REPRESENT_INEXACT_ERROR, "fprat", n);
- }
-
- /* Now we can compute the rational number r = 2^i/X*2^i = numer/denom. */
- denom = pow(2, i);
- numer = fn*denom;
- } else { /* denormalised/subnormal number: [+-]1.0/+inf.0 */
- numer = fn > 0.0 ? 1.0 : -1.0;
- denom = 1.0/0.0; /* +inf */
- }
- C_values(4, C_SCHEME_UNDEFINED, k, C_flonum(&ap, numer), C_flonum(&ap, denom));
-}
-
-
C_regparm C_word C_fcall
C_a_i_exact_to_inexact(C_word **a, int c, C_word n)
{
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 26469f44..46ed5e80 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -70,8 +70,8 @@
; | (deprecated NAME)
; BASIC = * | string | symbol | char | number | boolean | true | false | list | pair |
; procedure | vector | null | eof | undefined | input-port | output-port |
-; blob | noreturn | pointer | locative | fixnum | float |
-; pointer-vector
+; blob | noreturn | pointer | locative | fixnum | float | bignum |
+; ratnum | compnum | integer | pointer-vector
; COMPLEX = (pair VAL VAL)
; | (vector-of VAL)
; | (list-of VAL)
@@ -136,7 +136,10 @@
(cond ((string? lit) 'string)
((symbol? lit) 'symbol)
((fixnum? lit) 'fixnum)
- ((flonum? lit) 'float)
+ ((flonum? lit) 'float) ; Why not "flonum", for consistency?
+ ((bignum? lit) 'bignum)
+ ((ratnum? lit) 'ratnum)
+ ((cplxnum? lit) 'cplxnum)
((number? lit)
(case number-type
((fixnum) 'fixnum)
@@ -1055,12 +1058,18 @@
((eq? t2 'boolean)
(and (not exact)
(match1 t1 '(or true false))))
+ ((eq? t1 'integer)
+ (and (not exact)
+ (match1 '(or fixnum bignum) t2)))
((eq? t1 'number)
(and (not exact)
- (match1 '(or fixnum float) t2)))
+ (match1 '(or fixnum float bignum ratnum cplxnum) t2)))
+ ((eq? t2 'integer)
+ (and (not exact)
+ (match1 t1 '(or fixnum bignum))))
((eq? t2 'number)
(and (not exact)
- (match1 t1 '(or fixnum float))))
+ (match1 t1 '(or fixnum float bignum ratnum cplxnum))))
((eq? 'procedure t1)
(and (pair? t2)
(eq? 'procedure (car t2))))
@@ -1268,7 +1277,8 @@
(car ts)
(cdr ts))))
((lset=/eq? '(true false) ts) 'boolean)
- ((lset=/eq? '(fixnum float) ts) 'number)
+ ((lset=/eq? '(fixnum bignum) ts) 'integer)
+ ((lset=/eq? '(fixnum float bignum ratnum cplxnum) ts) 'number)
(else
(let* ((ts (append-map
(lambda (t)
@@ -1423,7 +1433,8 @@
((eq? 'vector t1) (test '(vector-of *) t2))
((eq? 'list t1) (test '(list-of *) t2))
((eq? 'boolean t1) (test '(or true false) t2))
- ((eq? 'number t1) (test '(or fixnum float) t2))
+ ((eq? 'integer t1) (test '(or fixnum bignum) t2))
+ ((eq? 'number t1) (test '(or fixnum float bignum ratnum cplxnum) t2))
((and (eq? 'null t1)
(pair? t2)
(eq? (car t2) 'list-of)))
@@ -1452,7 +1463,8 @@
(case t2
((procedure) (and (pair? t1) (eq? 'procedure (car t1))))
((boolean) (memq t1 '(true false)))
- ((number) (memq t1 '(fixnum float)))
+ ((integer) (memq t1 '(fixnum bignum)))
+ ((number) (memq t1 '(fixnum float bignum ratnum cplxnum)))
((vector) (test t1 '(vector-of *)))
((list) (test t1 '(list-of *)))
((pair) (test t1 '(pair * *)))
@@ -1735,8 +1747,10 @@
'*)
(resolve t2 (cons t done))))))
((not (pair? t))
- (if (memq t '(* fixnum eof char string symbol float number list vector pair
- undefined blob input-port output-port pointer locative boolean
+ (if (memq t '(* eof char string symbol
+ fixnum float bignum ratnum cplxnum
+ number integer list vector pair undefined blob
+ input-port output-port pointer locative boolean
true false pointer-vector null procedure noreturn))
t
(bomb "resolve: can't resolve unknown type-variable" t)))
@@ -1951,7 +1965,7 @@
(define (validate t #!optional (rec #t))
(cond ((memq t '(* string symbol char number boolean true false list pair
procedure vector null eof undefined input-port output-port
- blob pointer locative fixnum float pointer-vector
+ blob pointer locative fixnum float integer bignum ratnum cplxnum pointer-vector
deprecated noreturn values))
t)
((memq t '(u8vector s8vector u16vector s16vector u32vector s32vector
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 1e254cd1..50dcf3fb 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -116,7 +116,7 @@
(check #\x 1.2 char)
(check #t #f true)
(check #f #t false)
-(check (+ 1 2) 'a number)
+(check (+ 1 2) 'a integer)
(check '(1) 1.2 (list fixnum))
(check '(a) 1.2 (list symbol))
(check (list 1) '(1 . 2) (list fixnum))
@@ -255,11 +255,12 @@
(define x 1)
(assert
- (eq? 'number
- (compiler-typecase (vector-ref '#(1 2 3.4) x)
- (fixnum 'fixnum)
- (float 'float)
- (number 'number))))
+ (equal? 'float-or-fixnum
+ (compiler-typecase (vector-ref '#(1 2 3.4) x)
+ (fixnum 'fixnum)
+ (float 'float)
+ (number 'number)
+ ((or float fixnum) 'float-or-fixnum))))
(assert
(eq? 'boolean
diff --git a/types.db b/types.db
index 8693e568..e192f488 100644
--- a/types.db
+++ b/types.db
@@ -716,11 +716,15 @@
((float) (float)
(##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1))))
-(numerator (#(procedure #:clean #:enforce) numerator (number) number)
- ((fixnum) (fixnum) #(1)))
+(numerator (#(procedure #:clean #:enforce #:foldable) numerator ((or float integer ratnum)) (or float integer))
+ ((fixnum) (fixnum) #(1))
+ ((bignum) (bignum) #(1))
+ ((integer) (integer) #(1))
+ ((ratnum) (integer) (##sys#slot #(1) '1)))
-(denominator (#(procedure #:clean #:enforce) denominator (number) number)
- ((fixnum) (fixnum) (let ((#(tmp) #(1))) '1)))
+(denominator (#(procedure #:clean #:enforce #:foldable) denominator ((or float integer ratnum)) (or float integer))
+ ((integer) (fixnum) (let ((#(tmp) #(1))) '1))
+ ((ratnum) (integer) (##sys#slot #(1) '1)))
(scheme-report-environment
(#(procedure #:clean #:enforce) scheme-report-environment (#!optional fixnum) (struct environment)))
@@ -748,6 +752,8 @@
(argv (#(procedure #:clean) argv () (list-of string)))
(arithmetic-shift (#(procedure #:clean #:enforce #:foldable) arithmetic-shift (number number) number))
+(bignum? (#(procedure #:pure #:predicate bignum) bignum? (*) boolean))
+
(bit-set? (#(procedure #:clean #:enforce #:foldable) bit-set? (number fixnum) boolean)
((fixnum fixnum) (##core#inline "C_u_i_bit_setp" #(1) #(2))))
@@ -793,6 +799,9 @@
(continuation? (#(procedure #:pure #:predicate (struct continuation)) continuation? (*) boolean))
(copy-read-table (#(procedure #:clean #:enforce) copy-read-table ((struct read-table)) (struct read-table)))
+
+(cplxnum? (#(procedure #:pure #:predicate cplxnum) cplxnum? (*) boolean))
+
(cpu-time (#(procedure #:clean) cpu-time () fixnum fixnum))
(current-error-port
@@ -1060,6 +1069,9 @@
(##core#inline_allocate ("C_a_i_putprop" 8) #(1) #(2) #(3))))
(quit (procedure quit (#!optional *) noreturn))
+
+(ratnum? (#(procedure #:pure #:predicate ratnum) ratnum? (*) boolean))
+
(register-feature! (#(procedure #:clean #:enforce) register-feature! (#!rest symbol) undefined))
(remprop! (#(procedure #:clean #:enforce) remprop! (symbol symbol) undefined))
(rename-file (#(procedure #:clean #:enforce) rename-file (string string) string))
Trap